git.chise.org Git - elisp/gnus.git-/blob - lisp/nnshimbun.el

   1 ;;; nnshimbun.el --- interfacing with web newspapers -*- coding: junet; -*-
   2
   3 ;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.org>,
   4 ;;          Akihiro Arisawa    <ari@atesoft.advantest.co.jp>,
   5 ;;          Katsumi Yamaoka    <yamaoka@jpl.org>,
   6 ;;          Yuuichi Teranishi  <teranisi@gohome.org>
   7 ;; Keywords: news
   8
   9 ;;; Copyright:
  10
  11 ;; This file is a part of Semi-Gnus.
  12
  13 ;; This program is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; This program is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with this program; if not, you can either send email to this
  25 ;; program's maintainer or write to: The Free Software Foundation,
  26 ;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; Gnus (or gnus) backend to read newspapers on the World Wide Web.
  31 ;; This module requires the Emacs-W3M and the external command W3M.
  32 ;; Visit the following pages for more information.
  33 ;;
  34 ;;      http://namazu.org/~tsuchiya/emacs-w3m/
  35 ;;      http://ei5nazha.yz.yamagata-u.ac.jp/~aito/w3m/
  36
  37 ;; If you would like to use this module in Gnus (not T-gnus), put this
  38 ;; file into the lisp/ directory in the Gnus source tree and run
  39 ;; `make install'.  And then, copy the function definition of
  40 ;; `gnus-group-make-shimbun-group' from the file gnus-group.el of
  41 ;; T-gnus to somewhere else, for example .gnus file as follows:
  42 ;;
  43 ;;(eval-after-load "gnus-group"
  44 ;;  '(if (not (fboundp 'gnus-group-make-shimbun-group))
  45 ;;       (defun gnus-group-make-shimbun-group ()
  46 ;;         "Create a nnshimbun group."
  47 ;;         [...a function definition...])))
  48
  49 ;;; Definitions:
  50
  51 (gnus-declare-backend "nnshimbun" 'address)
  52
  53 (eval-when-compile (require 'cl))
  54
  55 (require 'nnheader)
  56 (require 'nnmail)
  57 (require 'nnoo)
  58 (require 'gnus-bcklg)
  59 (require 'shimbun)
  60 (require 'message)
  61
  62
  63 (nnoo-declare nnshimbun)
  64
  65 (defvoo nnshimbun-directory (nnheader-concat gnus-directory "shimbun/")
  66   "Where nnshimbun will save its files.")
  67
  68 (defvoo nnshimbun-nov-is-evil nil
  69   "*Non-nil means that nnshimbun will never retrieve NOV headers.")
  70
  71 (defvoo nnshimbun-nov-file-name ".overview")
  72
  73 (defvoo nnshimbun-pre-fetch-article nil
  74   "*Non nil means that nnshimbun fetch unread articles when scanning groups.")
  75
  76 (defvoo nnshimbun-index-range nil
  77   "*Range of indecis to detect new pages.")
  78
  79 ;; set by nnshimbun-possibly-change-group
  80 (defvoo nnshimbun-buffer nil)
  81 (defvoo nnshimbun-current-directory nil)
  82 (defvoo nnshimbun-current-group nil)
  83
  84 ;; set by nnshimbun-open-server
  85 (defvoo nnshimbun-shimbun nil)
  86 (defvoo nnshimbun-server-directory nil)
  87
  88 (defvoo nnshimbun-status-string "")
  89 (defvoo nnshimbun-nov-last-check nil)
  90 (defvoo nnshimbun-nov-buffer-alist nil)
  91 (defvoo nnshimbun-nov-buffer-file-name nil)
  92
  93 (defvoo nnshimbun-keep-backlog 300)
  94 (defvoo nnshimbun-backlog-articles nil)
  95 (defvoo nnshimbun-backlog-hashtb nil)
  96
  97 ;;; backlog
  98 (defmacro nnshimbun-backlog (&rest form)
  99   `(let ((gnus-keep-backlog nnshimbun-keep-backlog)
 100          (gnus-backlog-buffer (format " *nnshimbun backlog %s*"
 101                                       (nnoo-current-server 'nnshimbun)))
 102          (gnus-backlog-articles nnshimbun-backlog-articles)
 103          (gnus-backlog-hashtb nnshimbun-backlog-hashtb))
 104      (unwind-protect
 105          (progn ,@form)
 106        (setq nnshimbun-backlog-articles gnus-backlog-articles
 107              nnshimbun-backlog-hashtb gnus-backlog-hashtb))))
 108 (put 'nnshimbun-backlog 'lisp-indent-function 0)
 109 (put 'nnshimbun-backlog 'edebug-form-spec '(form body))
 110
 111
 112 ;;; Interface Functions
 113 (nnoo-define-basics nnshimbun)
 114
 115 (deffoo nnshimbun-open-server (server &optional defs)
 116   (push (list 'nnshimbun-shimbun
 117               (condition-case err
 118                   (shimbun-open server (luna-make-entity 'shimbun-gnus-mua))
 119                 (error (nnheader-report 'nnshimbun "%s" (error-message-string
 120                                                          err)))))
 121         defs)
 122   ;; Set directory for server working files.
 123   (push (list 'nnshimbun-server-directory
 124               (file-name-as-directory
 125                (expand-file-name server nnshimbun-directory)))
 126         defs)
 127   (nnoo-change-server 'nnshimbun server defs)
 128   (nnshimbun-possibly-change-group nil server)
 129   ;; Make directories.
 130   (unless (file-exists-p nnshimbun-directory)
 131     (ignore-errors (make-directory nnshimbun-directory t)))
 132   (cond
 133    ((not (file-exists-p nnshimbun-directory))
 134     (nnshimbun-close-server)
 135     (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 136                      nnshimbun-directory))
 137    ((not (file-directory-p (file-truename nnshimbun-directory)))
 138     (nnshimbun-close-server)
 139     (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-directory))
 140    (t
 141     (unless (file-exists-p nnshimbun-server-directory)
 142       (ignore-errors (make-directory nnshimbun-server-directory t)))
 143     (cond
 144      ((not (file-exists-p nnshimbun-server-directory))
 145       (nnshimbun-close-server)
 146       (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 147                        nnshimbun-server-directory))
 148      ((not (file-directory-p (file-truename nnshimbun-server-directory)))
 149       (nnshimbun-close-server)
 150       (nnheader-report 'nnshimbun "Not a directory: %s"
 151                        nnshimbun-server-directory))
 152      (t
 153       (nnheader-report 'nnshimbun "Opened server %s using directory %s"
 154                        server nnshimbun-server-directory)
 155       t)))))
 156
 157 (deffoo nnshimbun-close-server (&optional server)
 158   (when (nnshimbun-server-opened server)
 159     (when nnshimbun-shimbun
 160       (shimbun-close nnshimbun-shimbun))
 161     (when (gnus-buffer-live-p nnshimbun-buffer)
 162       (kill-buffer nnshimbun-buffer)))
 163   (nnshimbun-backlog (gnus-backlog-shutdown))
 164   (nnshimbun-save-nov)
 165   (nnoo-close-server 'nnshimbun server)
 166   t)
 167
 168 (eval-and-compile
 169   (let ((Gnus-p
 170          (eval-when-compile
 171            (let ((gnus (locate-library "gnus"))
 172                  ;; Gnus has mailcap.el in the same directory of gnus.el.
 173                  (mailcap (locate-library "mailcap")))
 174              (and gnus mailcap
 175                   (string-equal (file-name-directory gnus)
 176                                 (file-name-directory mailcap)))))))
 177     (if Gnus-p
 178         (progn
 179           (defmacro nnshimbun-mail-header-subject (header)
 180             `(mail-header-subject ,header))
 181           (defmacro nnshimbun-mail-header-from (header)
 182             `(mail-header-from ,header)))
 183       (defmacro nnshimbun-mail-header-subject (header)
 184         `(mime-entity-fetch-field ,header 'Subject))
 185       (defmacro nnshimbun-mail-header-from (header)
 186         `(mime-entity-fetch-field ,header 'From)))))
 187
 188 (defun nnshimbun-make-shimbun-header (header)
 189   (shimbun-make-header
 190    (mail-header-number header)
 191    (nnshimbun-mail-header-subject header)
 192    (nnshimbun-mail-header-from header)
 193    (mail-header-date header)
 194    (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header)))
 195        (mail-header-id header))
 196    (mail-header-references header)
 197    (mail-header-chars header)
 198    (mail-header-lines header)
 199    (let ((xref (mail-header-xref header)))
 200      (if (and xref (string-match "^Xref: " xref))
 201          (substring xref 6)
 202        xref))))
 203
 204 (eval-when-compile
 205   (require 'gnus-sum));; For the macro `gnus-summary-article-header'.
 206
 207 (defun nnshimbun-request-article-1 (article &optional group server to-buffer)
 208   (if (nnshimbun-backlog
 209         (gnus-backlog-request-article
 210          group article (or to-buffer nntp-server-buffer)))
 211       (cons group article)
 212     (let* ((header (with-current-buffer (nnshimbun-open-nov group)
 213                      (and (nnheader-find-nov-line article)
 214                           (nnshimbun-make-shimbun-header
 215                            (nnheader-parse-nov)))))
 216            (original-id (shimbun-header-id header)))
 217       (when header
 218         (with-current-buffer (or to-buffer nntp-server-buffer)
 219           (delete-region (point-min) (point-max))
 220           (shimbun-article nnshimbun-shimbun header)
 221           ;; Kludge! replace a date string in `gnus-newsgroup-data'
 222           ;; based on the newly retrieved article.
 223           (let ((x (gnus-summary-article-header article)))
 224             (when x
 225               (mail-header-set-date x (shimbun-header-date header))))
 226           (when (> (buffer-size) 0)
 227             (nnshimbun-replace-nov-entry group article header original-id)
 228             (nnshimbun-backlog
 229               (gnus-backlog-enter-article group article (current-buffer)))
 230             (nnheader-report 'nnshimbun "Article %s retrieved"
 231                              (shimbun-header-id header))
 232             (cons group article)))))))
 233
 234 (deffoo nnshimbun-request-article (article &optional group server to-buffer)
 235   (when (nnshimbun-possibly-change-group group server)
 236     (when (stringp article)
 237       (setq article (nnshimbun-search-id group article)))
 238     (if (integerp article)
 239         (nnshimbun-request-article-1 article group server to-buffer)
 240       (nnheader-report 'nnshimbun "Couldn't retrieve article: %s"
 241                        (prin1-to-string article))
 242       nil)))
 243
 244 (deffoo nnshimbun-request-group (group &optional server dont-check)
 245   (let ((file-name-coding-system nnmail-pathname-coding-system)
 246         (pathname-coding-system nnmail-pathname-coding-system))
 247     (cond
 248      ((not (nnshimbun-possibly-change-group group server))
 249       (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
 250      ((not (file-exists-p nnshimbun-current-directory))
 251       (nnheader-report 'nnshimbun "Directory %s does not exist"
 252                        nnshimbun-current-directory))
 253      ((not (file-directory-p nnshimbun-current-directory))
 254       (nnheader-report 'nnshimbun "%s is not a directory"
 255                        nnshimbun-current-directory))
 256      (dont-check
 257       (nnheader-report 'nnshimbun "Group %s selected" group)
 258       t)
 259      (t
 260       (let (beg end lines)
 261         (with-current-buffer (nnshimbun-open-nov group)
 262           (goto-char (point-min))
 263           (setq beg (ignore-errors (read (current-buffer))))
 264           (goto-char (point-max))
 265           (forward-line -1)
 266           (setq end (ignore-errors (read (current-buffer)))
 267                 lines (count-lines (point-min) (point-max))))
 268         (nnheader-report 'nnshimbunw "Selected group %s" group)
 269         (nnheader-insert "211 %d %d %d %s\n"
 270                          lines (or beg 0) (or end 0) group))))))
 271
 272 (deffoo nnshimbun-request-scan (&optional group server)
 273   (nnshimbun-possibly-change-group group server)
 274   (nnshimbun-generate-nov-database group))
 275
 276 (deffoo nnshimbun-close-group (group &optional server)
 277   (nnshimbun-write-nov group)
 278   t)
 279
 280 (deffoo nnshimbun-request-list (&optional server)
 281   (with-current-buffer nntp-server-buffer
 282     (delete-region (point-min) (point-max))
 283     (dolist (group (shimbun-groups nnshimbun-shimbun))
 284       (when (nnshimbun-possibly-change-group group server)
 285         (let (beg end)
 286           (with-current-buffer (nnshimbun-open-nov group)
 287             (goto-char (point-min))
 288             (setq beg (ignore-errors (read (current-buffer))))
 289             (goto-char (point-max))
 290             (forward-line -1)
 291             (setq end (ignore-errors (read (current-buffer)))))
 292           (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
 293   t) ; return value
 294
 295 (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
 296   (when (nnshimbun-possibly-change-group group server)
 297     (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
 298         'nov
 299       (with-current-buffer nntp-server-buffer
 300         (delete-region (point-min) (point-max))
 301         (let (header)
 302           (dolist (art articles)
 303             (if (stringp art)
 304                 (setq art (nnshimbun-search-id group art)))
 305             (if (integerp art)
 306                 (when (setq header
 307                             (with-current-buffer (nnshimbun-open-nov group)
 308                               (and (nnheader-find-nov-line art)
 309                                    (nnheader-parse-nov))))
 310                   (insert (format "220 %d Article retrieved.\n" art))
 311                   (shimbun-header-insert
 312                    nnshimbun-shimbun
 313                    (nnshimbun-make-shimbun-header header))
 314                   (insert ".\n")
 315                   (delete-region (point) (point-max))))))
 316         'header))))
 317
 318 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
 319   (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
 320       nil
 321     (let ((nov (expand-file-name nnshimbun-nov-file-name
 322                                  nnshimbun-current-directory)))
 323       (when (file-exists-p nov)
 324         (save-excursion
 325           (set-buffer nntp-server-buffer)
 326           (erase-buffer)
 327           (nnheader-insert-file-contents nov)
 328           (if (and fetch-old (not (numberp fetch-old)))
 329               t                         ; Don't remove anything.
 330             (nnheader-nov-delete-outside-range
 331              (if fetch-old (max 1 (- (car articles) fetch-old))
 332                (car articles))
 333              (and articles (nth (1- (length articles)) articles)))
 334             t))))))
 335
 336
 337
 338 ;;; Nov Database Operations
 339
 340 (defvar nnshimbun-tmp-string nil
 341   "Internal variable used to just a rest for a temporary string.  The
 342 macro `nnshimbun-string-or' uses it exclusively.")
 343
 344 (defmacro nnshimbun-string-or (&rest strings)
 345   "Return the first element of STRINGS that is a non-blank string.  It
 346 should run fast, especially if two strings are given.  Each string can
 347 also be nil."
 348   (cond ((null strings)
 349          nil)
 350         ((= 1 (length strings))
 351          ;; Return irregularly nil if one blank string is given.
 352          `(unless (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 353             nnshimbun-tmp-string))
 354         ((= 2 (length strings))
 355          ;; Return the second string when the first string is blank.
 356          `(if (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 357               ,(cadr strings)
 358             nnshimbun-tmp-string))
 359         (t
 360          `(let ((strings (list ,@strings)))
 361             (while strings
 362               (setq strings (if (zerop (length (setq nnshimbun-tmp-string
 363                                                      (car strings))))
 364                                 (cdr strings))))
 365             nnshimbun-tmp-string))))
 366
 367 (defsubst nnshimbun-insert-nov (number header &optional id)
 368   (insert "\n")
 369   (backward-char 1)
 370   (let ((header-id (nnshimbun-string-or (shimbun-header-id header)))
 371         ;; Force `princ' to work in the current buffer.
 372         (standard-output (current-buffer))
 373         (xref (nnshimbun-string-or (shimbun-header-xref header)))
 374         (start (point)))
 375     (and (stringp id)
 376          header-id
 377          (string-equal id header-id)
 378          (setq id nil))
 379     (princ number)
 380     (insert
 381      "\t"
 382      (nnshimbun-string-or (shimbun-header-subject header) "(none)") "\t"
 383      (nnshimbun-string-or (shimbun-header-from header) "(nobody)") "\t"
 384      (nnshimbun-string-or (shimbun-header-date header) (message-make-date))
 385      "\t"
 386      (or header-id (nnmail-message-id)) "\t"
 387      (or (shimbun-header-references header) "") "\t")
 388     (princ (or (shimbun-header-chars header) 0))
 389     (insert "\t")
 390     (princ (or (shimbun-header-lines header) 0))
 391     (insert "\t")
 392     (if xref
 393         (progn
 394           (insert "Xref: " xref "\t")
 395           (when id
 396             (insert "X-Nnshimbun-Id: " id "\t")))
 397       (if id
 398           (insert "\tX-Nnshimbun-Id: " id "\t")))
 399     ;; Replace newlines with spaces in the current NOV line.
 400     (while (progn
 401              (beginning-of-line)
 402              (> (point) start))
 403       (backward-delete-char 1)
 404       (insert " "))
 405     (forward-line 1)))
 406
 407 (defun nnshimbun-generate-nov-database (group)
 408   (nnshimbun-possibly-change-group group)
 409   (with-current-buffer (nnshimbun-open-nov group)
 410     (goto-char (point-max))
 411     (forward-line -1)
 412     (let ((i (or (ignore-errors (read (current-buffer))) 0)))
 413       (dolist (header (shimbun-headers
 414                        nnshimbun-shimbun
 415                        (or (gnus-group-find-parameter
 416                             (concat "nnshimbun+"
 417                                     (nnoo-current-server 'nnshimbun)
 418                                     ":" group)
 419                             'nnshimbun-index-range)
 420                            nnshimbun-index-range)))
 421         (unless (nnshimbun-search-id group (shimbun-header-id header))
 422           (goto-char (point-max))
 423           (nnshimbun-insert-nov (setq i (1+ i)) header)
 424           (when nnshimbun-pre-fetch-article
 425             (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))
 426   (nnshimbun-write-nov group)))
 427
 428 (defun nnshimbun-replace-nov-entry (group article header &optional id)
 429   (with-current-buffer (nnshimbun-open-nov group)
 430     (when (nnheader-find-nov-line article)
 431       (delete-region (point) (progn (forward-line 1) (point)))
 432       (nnshimbun-insert-nov article header id))))
 433
 434 (defun nnshimbun-search-id (group id &optional nov)
 435   (with-current-buffer (nnshimbun-open-nov group)
 436     (goto-char (point-min))
 437     (let (found)
 438       (while (and (not found)
 439                   (search-forward id nil t)) ; We find the ID.
 440         ;; And the id is in the fourth field.
 441         (if (not (and (search-backward "\t" nil t 4)
 442                       (not (search-backward "\t" (gnus-point-at-bol) t))))
 443             (forward-line 1)
 444           (forward-line 0)
 445           (setq found t)))
 446       (unless found
 447         (goto-char (point-min))
 448         (setq id (concat "X-Nnshimbun-Id: " id))
 449         (while (and (not found)
 450                     (search-forward id nil t))
 451           (if (not (search-backward "\t" (gnus-point-at-bol) t 8))
 452               (forward-line 1)
 453             (forward-line 0)
 454             (setq found t))))
 455       (if found
 456           (if nov
 457               (nnheader-parse-nov)
 458             ;; We return the article number.
 459             (ignore-errors (read (current-buffer))))))))
 460
 461 (defun nnshimbun-open-nov (group)
 462   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 463     (if (buffer-live-p buffer)
 464         buffer
 465       (setq buffer (gnus-get-buffer-create
 466                     (format " *nnshimbun overview %s %s*"
 467                             (nnoo-current-server 'nnshimbun) group)))
 468       (save-excursion
 469         (set-buffer buffer)
 470         (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 471              (expand-file-name
 472               nnshimbun-nov-file-name
 473               (nnmail-group-pathname group nnshimbun-server-directory)))
 474         (erase-buffer)
 475         (when (file-exists-p nnshimbun-nov-buffer-file-name)
 476           (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
 477         (set-buffer-modified-p nil))
 478       (push (cons group buffer) nnshimbun-nov-buffer-alist)
 479       buffer)))
 480
 481 (defun nnshimbun-write-nov (group)
 482   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 483     (when (buffer-live-p buffer)
 484       (save-excursion
 485         (set-buffer buffer)
 486         (buffer-modified-p)
 487         (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 488                              nil 'nomesg)))))
 489
 490 (defun nnshimbun-save-nov ()
 491   (save-excursion
 492     (while nnshimbun-nov-buffer-alist
 493       (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
 494         (set-buffer (cdar nnshimbun-nov-buffer-alist))
 495         (when (buffer-modified-p)
 496           (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 497                                nil 'nomesg))
 498         (set-buffer-modified-p nil)
 499         (kill-buffer (current-buffer)))
 500       (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
 501
 502 (defvar nnshimbun-keep-last-article t
 503   "*If non-nil, nnshimbun will never delete a group's last article.  It
 504 can be marked expirable, so it will be deleted when it is no longer
 505 last.")
 506
 507 (defvar nnshimbun-keep-unparsable-dated-articles t
 508   "*If non-nil, nnshimbun will never delete articles whose NOV date is
 509 unparsable.")
 510
 511 (deffoo nnshimbun-request-expire-articles (articles group
 512                                                     &optional server force)
 513   "Do expiration for the specified ARTICLES in the nnshimbun GROUP.
 514 Notice that nnshimbun does not actually delete any articles, it just
 515 delete the corresponding entries in the NOV database locally.  The
 516 expiration will be performed only when the current SERVER is specified
 517 and the NOV is open.  The optional fourth argument FORCE is ignored."
 518   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 519     (if (and server
 520              ;; Don't use 'string-equal' in the following.
 521              (equal server (nnoo-current-server 'nnshimbun))
 522              (buffer-live-p buffer))
 523         (let* ((expirable (copy-sequence articles))
 524                (name (concat "nnshimbun+" server ":" group))
 525                ;; If the group's parameter `expiry-wait' is non-nil,
 526                ;; `nnmail-expiry-wait' is bound to that value, and
 527                ;; `nnmail-expiry-wait-function' is bound to nil.
 528                ;; See the source code of `gnus-summary-expire-articles'.
 529                ;; Prefer the shimbun's default to `nnmail-expiry-wait'
 530                ;; only when the group's parameter is nil.
 531                (nnmail-expiry-wait
 532                 (if (gnus-group-find-parameter name 'expiry-wait)
 533                     nnmail-expiry-wait
 534                   (or (shimbun-article-expiration-days nnshimbun-shimbun)
 535                       nnmail-expiry-wait)))
 536                article end time)
 537           (save-excursion
 538             (set-buffer buffer)
 539             (while expirable
 540               (setq article (pop expirable))
 541               (when (and (nnheader-find-nov-line article)
 542                          (setq end (line-end-position))
 543                          (not (and nnshimbun-keep-last-article
 544                                    (= (point-max) (1+ end)))))
 545                 (setq time (and (search-forward "\t" end t)
 546                                 (search-forward "\t" end t)
 547                                 (search-forward "\t" end t)
 548                                 (parse-time-string
 549                                  (buffer-substring
 550                                   (point)
 551                                   (if (search-forward "\t" end t)
 552                                       (1- (point))
 553                                     end)))))
 554                 (when (and (or (setq time (condition-case nil
 555                                               (apply 'encode-time time)
 556                                             (error nil)))
 557                                ;; Inhibit expiration if there's no parsable
 558                                ;; date and the following option is non-nil.
 559                                (not nnshimbun-keep-unparsable-dated-articles))
 560                            (nnmail-expired-article-p name time nil))
 561                   (beginning-of-line)
 562                   (delete-region (point) (1+ end))
 563                   (setq articles (delq article articles)))))
 564             (when (buffer-modified-p)
 565               (nnmail-write-region 1 (point-max)
 566                                    nnshimbun-nov-buffer-file-name
 567                                    nil 'nomesg)
 568               (set-buffer-modified-p nil))
 569             articles))
 570       t)))
 571
 572
 573
 574 ;;; Server Initialize
 575
 576 (defun nnshimbun-possibly-change-group (group &optional server)
 577   (when server
 578     (unless (nnshimbun-server-opened server)
 579       (nnshimbun-open-server server)))
 580   (unless (gnus-buffer-live-p nnshimbun-buffer)
 581     (setq nnshimbun-buffer
 582           (save-excursion
 583             (nnheader-set-temp-buffer
 584              (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
 585   (if (not group)
 586       t
 587     (condition-case err
 588         (shimbun-open-group nnshimbun-shimbun group)
 589       (error (nnheader-report 'nnshimbun "%s" (error-message-string err))))
 590     (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
 591           (file-name-coding-system nnmail-pathname-coding-system)
 592           (pathname-coding-system nnmail-pathname-coding-system))
 593       (unless (equal pathname nnshimbun-current-directory)
 594         (setq nnshimbun-current-directory pathname
 595               nnshimbun-current-group group))
 596       (unless (file-exists-p nnshimbun-current-directory)
 597         (ignore-errors (make-directory nnshimbun-current-directory t)))
 598       (cond
 599        ((not (file-exists-p nnshimbun-current-directory))
 600         (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 601                          nnshimbun-current-directory))
 602        ((not (file-directory-p (file-truename nnshimbun-current-directory)))
 603         (nnheader-report 'nnshimbun "Not a directory: %s"
 604                          nnshimbun-current-directory))
 605        (t t)))))
 606
 607
 608
 609 ;;; shimbun-gnus-mua
 610 (luna-define-class shimbun-gnus-mua (shimbun-mua) ())
 611
 612 (luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id)
 613   (nnshimbun-search-id
 614    (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
 615    id))
 616
 617
 618 (provide 'nnshimbun)
 619 ;;; nnshimbun.el ends here.