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-use-entire-index t
  77   "*Nil means that nnshimbun check the last index of articles.")
  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   (shimbun-close nnshimbun-shimbun)
 159   (and (nnshimbun-server-opened server)
 160        (gnus-buffer-live-p nnshimbun-buffer)
 161        (kill-buffer nnshimbun-buffer))
 162   (nnshimbun-backlog (gnus-backlog-shutdown))
 163   (nnshimbun-save-nov)
 164   (nnoo-close-server 'nnshimbun server)
 165   t)
 166
 167 (eval-and-compile
 168   (let ((Gnus-p
 169          (eval-when-compile
 170            (let ((gnus (locate-library "gnus"))
 171                  ;; Gnus has mailcap.el in the same directory of gnus.el.
 172                  (mailcap (locate-library "mailcap")))
 173              (and gnus mailcap
 174                   (string-equal (file-name-directory gnus)
 175                                 (file-name-directory mailcap)))))))
 176     (if Gnus-p
 177         (progn
 178           (defmacro nnshimbun-mail-header-subject (header)
 179             `(mail-header-subject ,header))
 180           (defmacro nnshimbun-mail-header-from (header)
 181             `(mail-header-from ,header)))
 182       (defmacro nnshimbun-mail-header-subject (header)
 183         `(mime-entity-fetch-field ,header 'Subject))
 184       (defmacro nnshimbun-mail-header-from (header)
 185         `(mime-entity-fetch-field ,header 'From)))))
 186
 187 (defun nnshimbun-make-shimbun-header (header)
 188   (shimbun-make-header
 189    (mail-header-number header)
 190    (nnshimbun-mail-header-subject header)
 191    (nnshimbun-mail-header-from header)
 192    (mail-header-date header)
 193    (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header)))
 194        (mail-header-id header))
 195    (mail-header-references header)
 196    (mail-header-chars header)
 197    (mail-header-lines header)
 198    (let ((xref (mail-header-xref header)))
 199      (if (and xref (string-match "^Xref: " xref))
 200          (substring xref 6)
 201        xref))))
 202
 203 (eval-when-compile
 204   (require 'gnus-sum));; For the macro `gnus-summary-article-header'.
 205
 206 (defun nnshimbun-request-article-1 (article &optional group server to-buffer)
 207   (if (nnshimbun-backlog
 208         (gnus-backlog-request-article
 209          group article (or to-buffer nntp-server-buffer)))
 210       (cons group article)
 211     (let* ((header (with-current-buffer (nnshimbun-open-nov group)
 212                      (and (nnheader-find-nov-line article)
 213                           (nnshimbun-make-shimbun-header
 214                            (nnheader-parse-nov)))))
 215            (original-id (shimbun-header-id header)))
 216       (when header
 217         (with-current-buffer (or to-buffer nntp-server-buffer)
 218           (delete-region (point-min) (point-max))
 219           (shimbun-article nnshimbun-shimbun header)
 220           ;; Kludge! replace a date string in `gnus-newsgroup-data'
 221           ;; based on the newly retrieved article.
 222           (mail-header-set-date (gnus-summary-article-header article)
 223                                 (shimbun-header-date header))
 224           (when (> (buffer-size) 0)
 225             (nnshimbun-replace-nov-entry group article header original-id)
 226             (nnshimbun-backlog
 227               (gnus-backlog-enter-article group article (current-buffer)))
 228             (nnheader-report 'nnshimbun "Article %s retrieved"
 229                              (shimbun-header-id header))
 230             (cons group article)))))))
 231
 232 (deffoo nnshimbun-request-article (article &optional group server to-buffer)
 233   (when (nnshimbun-possibly-change-group group server)
 234     (when (stringp article)
 235       (setq article (nnshimbun-search-id group article)))
 236     (if (integerp article)
 237         (nnshimbun-request-article-1 article group server to-buffer)
 238       (nnheader-report 'nnshimbun "Couldn't retrieve article: %s"
 239                        (prin1-to-string article))
 240       nil)))
 241
 242 (deffoo nnshimbun-request-group (group &optional server dont-check)
 243   (let ((file-name-coding-system nnmail-pathname-coding-system)
 244         (pathname-coding-system nnmail-pathname-coding-system))
 245     (cond
 246      ((not (nnshimbun-possibly-change-group group server))
 247       (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
 248      ((not (file-exists-p nnshimbun-current-directory))
 249       (nnheader-report 'nnshimbun "Directory %s does not exist"
 250                        nnshimbun-current-directory))
 251      ((not (file-directory-p nnshimbun-current-directory))
 252       (nnheader-report 'nnshimbun "%s is not a directory"
 253                        nnshimbun-current-directory))
 254      (dont-check
 255       (nnheader-report 'nnshimbun "Group %s selected" group)
 256       t)
 257      (t
 258       (let (beg end lines)
 259         (with-current-buffer (nnshimbun-open-nov group)
 260           (goto-char (point-min))
 261           (setq beg (ignore-errors (read (current-buffer))))
 262           (goto-char (point-max))
 263           (forward-line -1)
 264           (setq end (ignore-errors (read (current-buffer)))
 265                 lines (count-lines (point-min) (point-max))))
 266         (nnheader-report 'nnshimbunw "Selected group %s" group)
 267         (nnheader-insert "211 %d %d %d %s\n"
 268                          lines (or beg 0) (or end 0) group))))))
 269
 270 (deffoo nnshimbun-request-scan (&optional group server)
 271   (nnshimbun-possibly-change-group group server)
 272   (nnshimbun-generate-nov-database group))
 273
 274 (deffoo nnshimbun-close-group (group &optional server)
 275   (nnshimbun-write-nov group)
 276   t)
 277
 278 (deffoo nnshimbun-request-list (&optional server)
 279   (with-current-buffer nntp-server-buffer
 280     (delete-region (point-min) (point-max))
 281     (dolist (group (shimbun-groups nnshimbun-shimbun))
 282       (when (nnshimbun-possibly-change-group group server)
 283         (let (beg end)
 284           (with-current-buffer (nnshimbun-open-nov group)
 285             (goto-char (point-min))
 286             (setq beg (ignore-errors (read (current-buffer))))
 287             (goto-char (point-max))
 288             (forward-line -1)
 289             (setq end (ignore-errors (read (current-buffer)))))
 290           (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
 291   t) ; return value
 292
 293 (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
 294   (when (nnshimbun-possibly-change-group group server)
 295     (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
 296         'nov
 297       (with-current-buffer nntp-server-buffer
 298         (delete-region (point-min) (point-max))
 299         (let (header)
 300           (dolist (art articles)
 301             (if (stringp art)
 302                 (setq art (nnshimbun-search-id group art)))
 303             (if (integerp art)
 304                 (when (setq header
 305                             (with-current-buffer (nnshimbun-open-nov group)
 306                               (and (nnheader-find-nov-line art)
 307                                    (nnheader-parse-nov))))
 308                   (insert (format "220 %d Article retrieved.\n" art))
 309                   (shimbun-header-insert
 310                    nnshimbun-shimbun
 311                    (nnshimbun-make-shimbun-header header))
 312                   (insert ".\n")
 313                   (delete-region (point) (point-max))))))
 314         'header))))
 315
 316 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
 317   (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
 318       nil
 319     (let ((nov (expand-file-name nnshimbun-nov-file-name
 320                                  nnshimbun-current-directory)))
 321       (when (file-exists-p nov)
 322         (save-excursion
 323           (set-buffer nntp-server-buffer)
 324           (erase-buffer)
 325           (nnheader-insert-file-contents nov)
 326           (if (and fetch-old (not (numberp fetch-old)))
 327               t                         ; Don't remove anything.
 328             (nnheader-nov-delete-outside-range
 329              (if fetch-old (max 1 (- (car articles) fetch-old))
 330                (car articles))
 331              (and articles (nth (1- (length articles)) articles)))
 332             t))))))
 333
 334
 335
 336 ;;; Nov Database Operations
 337
 338 (defvar nnshimbun-tmp-string nil
 339   "Internal variable used to just a rest for a temporary string.  The
 340 macro `nnshimbun-string-or' uses it exclusively.")
 341
 342 (defmacro nnshimbun-string-or (&rest strings)
 343   "Return the first element of STRINGS that is a non-blank string.  It
 344 should run fast, especially if two strings are given.  Each string can
 345 also be nil."
 346   (cond ((null strings)
 347          nil)
 348         ((= 1 (length strings))
 349          ;; Return irregularly nil if one blank string is given.
 350          `(unless (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 351             nnshimbun-tmp-string))
 352         ((= 2 (length strings))
 353          ;; Return the second string when the first string is blank.
 354          `(if (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 355               ,(cadr strings)
 356             nnshimbun-tmp-string))
 357         (t
 358          `(let ((strings (list ,@strings)))
 359             (while strings
 360               (setq strings (if (zerop (length (setq nnshimbun-tmp-string
 361                                                      (car strings))))
 362                                 (cdr strings))))
 363             nnshimbun-tmp-string))))
 364
 365 (defsubst nnshimbun-insert-nov (number header &optional id)
 366   (insert "\n")
 367   (backward-char 1)
 368   (let ((header-id (nnshimbun-string-or (shimbun-header-id header)))
 369         ;; Force `princ' to work in the current buffer.
 370         (standard-output (current-buffer))
 371         (xref (nnshimbun-string-or (shimbun-header-xref header)))
 372         (start (point)))
 373     (unless (and (stringp id)
 374                  header-id
 375                  (string-equal id header-id))
 376       (setq id nil))
 377     (princ number)
 378     (insert
 379      "\t"
 380      (nnshimbun-string-or (shimbun-header-subject header) "(none)") "\t"
 381      (nnshimbun-string-or (shimbun-header-from header) "(nobody)") "\t"
 382      (nnshimbun-string-or (shimbun-header-date header) (message-make-date))
 383      "\t"
 384      (or header-id (nnmail-message-id)) "\t"
 385      (or (shimbun-header-references header) "") "\t")
 386     (princ (or (shimbun-header-chars header) 0))
 387     (insert "\t")
 388     (princ (or (shimbun-header-lines header) 0))
 389     (insert "\t")
 390     (if xref
 391         (progn
 392           (insert "Xref: " xref "\t")
 393           (when id
 394             (insert "X-Nnshimbun-Id: " id "\t")))
 395       (if id
 396           (insert "\tX-Nnshimbun-Id: " id "\t")))
 397     ;; Replace newlines with spaces in the current NOV line.
 398     (while (progn
 399              (beginning-of-line)
 400              (> (point) start))
 401       (backward-delete-char 1)
 402       (insert " "))
 403     (forward-line 1)))
 404
 405 (defun nnshimbun-generate-nov-database (group)
 406   (nnshimbun-possibly-change-group group)
 407   (with-current-buffer (nnshimbun-open-nov group)
 408     (goto-char (point-max))
 409     (forward-line -1)
 410     (let ((i (or (ignore-errors (read (current-buffer))) 0)))
 411       (dolist (header (shimbun-headers nnshimbun-shimbun))
 412         (unless (nnshimbun-search-id group (shimbun-header-id header))
 413           (goto-char (point-max))
 414           (nnshimbun-insert-nov (setq i (1+ i)) header)
 415           (when nnshimbun-pre-fetch-article
 416             (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))
 417   (nnshimbun-write-nov group)))
 418
 419 (defun nnshimbun-replace-nov-entry (group article header &optional id)
 420   (with-current-buffer (nnshimbun-open-nov group)
 421     (when (nnheader-find-nov-line article)
 422       (delete-region (point) (progn (forward-line 1) (point)))
 423       (nnshimbun-insert-nov article header id))))
 424
 425 (defun nnshimbun-search-id (group id &optional nov)
 426   (with-current-buffer (nnshimbun-open-nov group)
 427     (goto-char (point-min))
 428     (let (found)
 429       (while (and (not found)
 430                   (search-forward id nil t)) ; We find the ID.
 431         ;; And the id is in the fourth field.
 432         (if (not (and (search-backward "\t" nil t 4)
 433                       (not (search-backward "\t" (gnus-point-at-bol) t))))
 434             (forward-line 1)
 435           (forward-line 0)
 436           (setq found t)))
 437       (unless found
 438         (goto-char (point-min))
 439         (setq id (concat "X-Nnshimbun-Id: " id))
 440         (while (and (not found)
 441                     (search-forward id nil t))
 442           (if (not (search-backward "\t" (gnus-point-at-bol) t 8))
 443               (forward-line 1)
 444             (forward-line 0)
 445             (setq found t))))
 446       (if found
 447           (if nov
 448               (nnheader-parse-nov)
 449             ;; We return the article number.
 450             (ignore-errors (read (current-buffer))))))))
 451
 452 (defun nnshimbun-open-nov (group)
 453   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 454     (if (buffer-live-p buffer)
 455         buffer
 456       (setq buffer (gnus-get-buffer-create
 457                     (format " *nnshimbun overview %s %s*"
 458                             (nnoo-current-server 'nnshimbun) group)))
 459       (save-excursion
 460         (set-buffer buffer)
 461         (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 462              (expand-file-name
 463               nnshimbun-nov-file-name
 464               (nnmail-group-pathname group nnshimbun-server-directory)))
 465         (erase-buffer)
 466         (when (file-exists-p nnshimbun-nov-buffer-file-name)
 467           (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
 468         (set-buffer-modified-p nil))
 469       (push (cons group buffer) nnshimbun-nov-buffer-alist)
 470       buffer)))
 471
 472 (defun nnshimbun-write-nov (group)
 473   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 474     (when (buffer-live-p buffer)
 475       (save-excursion
 476         (set-buffer buffer)
 477         (buffer-modified-p)
 478         (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 479                              nil 'nomesg)))))
 480
 481 (defun nnshimbun-save-nov ()
 482   (save-excursion
 483     (while nnshimbun-nov-buffer-alist
 484       (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
 485         (set-buffer (cdar nnshimbun-nov-buffer-alist))
 486         (when (buffer-modified-p)
 487           (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 488                                nil 'nomesg))
 489         (set-buffer-modified-p nil)
 490         (kill-buffer (current-buffer)))
 491       (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
 492
 493 (defvar nnshimbun-keep-last-article t
 494   "*If non-nil, nnshimbun will never delete a group's last article.  It
 495 can be marked expirable, so it will be deleted when it is no longer
 496 last.")
 497
 498 (defvar nnshimbun-keep-unparsable-dated-articles t
 499   "*If non-nil, nnshimbun will never delete articles whose NOV date is
 500 unparsable.  Even so, you can expire such articles using the command
 501 `nnshimbun-expire-nov-databases' with a prefix argument.")
 502
 503 (deffoo nnshimbun-request-expire-articles (articles group
 504                                                     &optional server force)
 505   "Do expire for the specified ARTICLES in the nnshimbun GROUP.  Notice
 506 that nnshimbun does not actually delete any articles, it just delete
 507 the corresponding entries in the NOV database locally.  If ARTICLES is
 508 `all', the expiring is performed on all the NOV lines.  It does expire
 509 only when the current SERVER is specified and the NOV is open.
 510 However, the optional FORCE if it is non-nil (it is supposed to be
 511 specified by the command `nnshimbun-expire-nov-databases'), it does
 512 expire for the SERVER:GROUP even if whose NOV is not open."
 513   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist)))
 514         (nnmail-expiry-wait-function nnmail-expiry-wait-function)
 515         (nnmail-expiry-wait nnmail-expiry-wait)
 516         (progress-msg (format "Expiring NOV database for nnshimbun+%s:%s "
 517                               server group))
 518         (pinwheel "-/|\\")
 519         (counter 0)
 520         name should-close-nov article expirable end time)
 521     (if (and
 522          server
 523          (setq name (concat "nnshimbun+" server ":" group))
 524          (or (let ((current (nnoo-current-server 'nnshimbun)))
 525                (and current
 526                     (string-equal server current)
 527                     (buffer-live-p buffer)))
 528              (when force
 529                (setq should-close-nov t
 530                      buffer (gnus-get-buffer-create
 531                              (format " *nnshimbun overview %s %s*"
 532                                      server group)))
 533                (let ((expiry-wait (gnus-group-find-parameter name
 534                                                              'expiry-wait)))
 535                  (when expiry-wait
 536                    ;; Prefer the group parameter `expiry-wait'.
 537                    (setq nnmail-expiry-wait-function nil
 538                          nnmail-expiry-wait expiry-wait)))
 539                (save-excursion
 540                  (set-buffer buffer)
 541                  (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 542                       (expand-file-name
 543                        nnshimbun-nov-file-name
 544                        (expand-file-name
 545                         group
 546                         (expand-file-name
 547                          server
 548                          nnshimbun-directory))))
 549                  (erase-buffer)
 550                  (nnheader-insert-file-contents
 551                   nnshimbun-nov-buffer-file-name))
 552                (set-buffer-modified-p nil)
 553                t)))
 554         (prog1
 555             (save-excursion
 556               (set-buffer buffer)
 557               (when (eq 'all articles)
 558                 (setq articles nil)
 559                 (goto-char (point-min))
 560                 (while (not (eobp))
 561                   (when (looking-at "[0-9]+\t")
 562                     (push (read buffer) articles))
 563                   (forward-line 1))
 564                 (setq articles (nreverse articles)))
 565               (setq expirable (copy-sequence articles))
 566               (while expirable
 567                 (setq article (pop expirable))
 568                 (when (and (nnheader-find-nov-line article)
 569                            (setq end (line-end-position))
 570                            (not (and nnshimbun-keep-last-article
 571                                      (= (point-max) (1+ end)))))
 572                   (setq time (and (search-forward "\t" end t)
 573                                   (search-forward "\t" end t)
 574                                   (search-forward "\t" end t)
 575                                   (parse-time-string
 576                                    (buffer-substring
 577                                     (point)
 578                                     (if (search-forward "\t" end t)
 579                                         (1- (point))
 580                                       end)))))
 581                   (if (and
 582                        (or (setq time (condition-case nil
 583                                           (apply 'encode-time time)
 584                                         (error nil)))
 585                            ;; Inhibit expiring if there's no parsable date
 586                            ;; and the following option is non-nil.
 587                            (not nnshimbun-keep-unparsable-dated-articles))
 588                        (nnmail-expired-article-p name time nil))
 589                       (progn
 590                         (when force
 591                           (message "%s(%c)..." progress-msg article))
 592                         (beginning-of-line)
 593                         (delete-region (point) (1+ end))
 594                         (setq articles (delq article articles)))
 595                     (when force
 596                       (message "%s(%c)..."
 597                                progress-msg
 598                                (aref pinwheel
 599                                      (setq counter
 600                                            (logand 3 (1+ counter)))))))))
 601               (when (buffer-modified-p)
 602                 (nnmail-write-region 1 (point-max)
 603                                      nnshimbun-nov-buffer-file-name
 604                                      nil 'nomesg)
 605                 (set-buffer-modified-p nil))
 606               articles)
 607           (when should-close-nov
 608             (kill-buffer buffer)))
 609       t)))
 610
 611 ;;;###autoload
 612 (defun nnshimbun-expire-nov-databases (&optional arg)
 613   "Expire NOV databases for all the auto expirable nnshimbun groups.
 614 If the prefix argument is given, the value of
 615 `nnshimbun-keep-unparsable-dated-articles' will be ignored (treated as
 616 nil)."
 617   (interactive "P")
 618   (let ((nnshimbun-keep-unparsable-dated-articles
 619          (unless arg
 620            nnshimbun-keep-unparsable-dated-articles))
 621         (servers (delq nil
 622                        (mapcar
 623                         (lambda (dir)
 624                           (if (and (not (string-equal ".." dir))
 625                                    (file-directory-p (expand-file-name
 626                                                       dir
 627                                                       nnshimbun-directory)))
 628                               dir))
 629                         (directory-files nnshimbun-directory))))
 630         server directory groups group nov did)
 631     (while servers
 632       (setq server (car servers)
 633             servers (cdr servers)
 634             directory (expand-file-name server nnshimbun-directory)
 635             groups (delq nil
 636                          (mapcar (lambda (dir)
 637                                    (if (and (not (string-equal ".." dir))
 638                                             (file-directory-p
 639                                              (expand-file-name
 640                                               dir directory)))
 641                                        dir))
 642                                  (directory-files directory))))
 643       (while groups
 644         (setq group (car groups)
 645               groups (cdr groups)
 646               nov (expand-file-name nnshimbun-nov-file-name
 647                                     (expand-file-name group directory)))
 648         (when (and (gnus-group-auto-expirable-p (concat "nnshimbun+"
 649                                                         server ":" group))
 650                    (file-exists-p nov))
 651           (message "Expiring NOV database for nnshimbun+%s:%s..."
 652                    server group)
 653           (nnshimbun-request-expire-articles 'all group server t)
 654           (setq did t))))
 655     (message (if did
 656                  "Expiring NOV databases...done"
 657                "Nothing to be done"))))
 658
 659
 660
 661 ;;; Server Initialize
 662
 663 (defun nnshimbun-possibly-change-group (group &optional server)
 664   (when server
 665     (unless (nnshimbun-server-opened server)
 666       (nnshimbun-open-server server)))
 667   (unless (gnus-buffer-live-p nnshimbun-buffer)
 668     (setq nnshimbun-buffer
 669           (save-excursion
 670             (nnheader-set-temp-buffer
 671              (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
 672   (if (not group)
 673       t
 674     (condition-case err
 675         (shimbun-open-group nnshimbun-shimbun group)
 676       (error (nnheader-report 'nnshimbun "%s" (error-message-string err))))
 677     (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
 678           (file-name-coding-system nnmail-pathname-coding-system)
 679           (pathname-coding-system nnmail-pathname-coding-system))
 680       (unless (equal pathname nnshimbun-current-directory)
 681         (setq nnshimbun-current-directory pathname
 682               nnshimbun-current-group group))
 683       (unless (file-exists-p nnshimbun-current-directory)
 684         (ignore-errors (make-directory nnshimbun-current-directory t)))
 685       (cond
 686        ((not (file-exists-p nnshimbun-current-directory))
 687         (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 688                          nnshimbun-current-directory))
 689        ((not (file-directory-p (file-truename nnshimbun-current-directory)))
 690         (nnheader-report 'nnshimbun "Not a directory: %s"
 691                          nnshimbun-current-directory))
 692        (t t)))))
 693
 694
 695
 696 ;;; shimbun-gnus-mua
 697 (luna-define-class shimbun-gnus-mua (shimbun-mua) ())
 698
 699 (luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id)
 700   (nnshimbun-search-id
 701    (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
 702    id))
 703
 704 (luna-define-method shimbun-mua-use-entire-index ((mua shimbun-gnus-mua))
 705   nnshimbun-use-entire-index)
 706
 707
 708 (provide 'nnshimbun)
 709 ;;; nnshimbun.el ends here.