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         (progress-msg (format "Expiring NOV database for nnshimbun+%s:%s "
 515                               server group))
 516         (pinwheel "-/|\\")
 517         (counter 0)
 518         should-close-nov name article expirable end time)
 519     (if (and
 520          server
 521          (or (let ((current (nnoo-current-server 'nnshimbun)))
 522                (and current
 523                     (string-equal server current)
 524                     (buffer-live-p buffer)))
 525              (when force
 526                (setq should-close-nov t
 527                      buffer (gnus-get-buffer-create
 528                              (format " *nnshimbun overview %s %s*"
 529                                      server group)))
 530                (save-excursion
 531                  (set-buffer buffer)
 532                  (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 533                       (expand-file-name
 534                        nnshimbun-nov-file-name
 535                        (expand-file-name
 536                         group
 537                         (expand-file-name
 538                          server
 539                          nnshimbun-directory))))
 540                  (erase-buffer)
 541                  (nnheader-insert-file-contents
 542                   nnshimbun-nov-buffer-file-name))
 543                (set-buffer-modified-p nil)
 544                t)))
 545         (prog1
 546             (save-excursion
 547               (setq name (concat "nnshimbun+" server ":" group))
 548               (set-buffer buffer)
 549               (when (eq 'all articles)
 550                 (setq articles nil)
 551                 (goto-char (point-min))
 552                 (while (not (eobp))
 553                   (when (looking-at "[0-9]+\t")
 554                     (push (read buffer) articles))
 555                   (forward-line 1))
 556                 (setq articles (nreverse articles)))
 557               (setq expirable (copy-sequence articles))
 558               (while expirable
 559                 (setq article (pop expirable))
 560                 (when (and (nnheader-find-nov-line article)
 561                            (setq end (line-end-position))
 562                            (not (and nnshimbun-keep-last-article
 563                                      (= (point-max) (1+ end)))))
 564                   (setq time (and (search-forward "\t" end t)
 565                                   (search-forward "\t" end t)
 566                                   (search-forward "\t" end t)
 567                                   (parse-time-string
 568                                    (buffer-substring
 569                                     (point)
 570                                     (if (search-forward "\t" end t)
 571                                         (1- (point))
 572                                       end)))))
 573                   (if (and
 574                        (or (setq time (condition-case nil
 575                                           (apply 'encode-time time)
 576                                         (error nil)))
 577                            ;; Inhibit expiring if there's no parsable date
 578                            ;; and the following option is non-nil.
 579                            (not nnshimbun-keep-unparsable-dated-articles))
 580                        (nnmail-expired-article-p name time nil))
 581                       (progn
 582                         (when force
 583                           (message "%s(%c)..." progress-msg article))
 584                         (beginning-of-line)
 585                         (delete-region (point) (1+ end))
 586                         (setq articles (delq article articles)))
 587                     (when force
 588                       (message "%s(%c)..."
 589                                progress-msg
 590                                (aref pinwheel
 591                                      (setq counter
 592                                            (logand 3 (1+ counter)))))))))
 593               (when (buffer-modified-p)
 594                 (nnmail-write-region 1 (point-max)
 595                                      nnshimbun-nov-buffer-file-name
 596                                      nil 'nomesg)
 597                 (set-buffer-modified-p nil))
 598               articles)
 599           (when should-close-nov
 600             (kill-buffer buffer)))
 601       t)))
 602
 603 ;;;###autoload
 604 (defun nnshimbun-expire-nov-databases (&optional arg)
 605   "Expire NOV databases for all the auto expirable nnshimbun groups.
 606 If the prefix argument is given, the value of
 607 `nnshimbun-keep-unparsable-dated-articles' will be ignored (treated as
 608 nil)."
 609   (interactive "P")
 610   (let ((nnshimbun-keep-unparsable-dated-articles
 611          (unless arg
 612            nnshimbun-keep-unparsable-dated-articles))
 613         (servers (delq nil
 614                        (mapcar
 615                         (lambda (dir)
 616                           (if (and (not (string-equal ".." dir))
 617                                    (file-directory-p (expand-file-name
 618                                                       dir
 619                                                       nnshimbun-directory)))
 620                               dir))
 621                         (directory-files nnshimbun-directory))))
 622         server directory groups group nov did)
 623     (while servers
 624       (setq server (car servers)
 625             servers (cdr servers)
 626             directory (expand-file-name server nnshimbun-directory)
 627             groups (delq nil
 628                          (mapcar (lambda (dir)
 629                                    (if (and (not (string-equal ".." dir))
 630                                             (file-directory-p
 631                                              (expand-file-name
 632                                               dir directory)))
 633                                        dir))
 634                                  (directory-files directory))))
 635       (while groups
 636         (setq group (car groups)
 637               groups (cdr groups)
 638               nov (expand-file-name nnshimbun-nov-file-name
 639                                     (expand-file-name group directory)))
 640         (when (and (gnus-group-auto-expirable-p (concat "nnshimbun+"
 641                                                         server ":" group))
 642                    (file-exists-p nov))
 643           (message "Expiring NOV database for nnshimbun+%s:%s..."
 644                    server group)
 645           (nnshimbun-request-expire-articles 'all group server t)
 646           (setq did t))))
 647     (message (if did
 648                  "Expiring NOV databases...done"
 649                "Nothing to be done"))))
 650
 651
 652
 653 ;;; Server Initialize
 654
 655 (defun nnshimbun-possibly-change-group (group &optional server)
 656   (when server
 657     (unless (nnshimbun-server-opened server)
 658       (nnshimbun-open-server server)))
 659   (unless (gnus-buffer-live-p nnshimbun-buffer)
 660     (setq nnshimbun-buffer
 661           (save-excursion
 662             (nnheader-set-temp-buffer
 663              (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
 664   (if (not group)
 665       t
 666     (condition-case err
 667         (shimbun-open-group nnshimbun-shimbun group)
 668       (error (nnheader-report 'nnshimbun "%s" (error-message-string err))))
 669     (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
 670           (file-name-coding-system nnmail-pathname-coding-system)
 671           (pathname-coding-system nnmail-pathname-coding-system))
 672       (unless (equal pathname nnshimbun-current-directory)
 673         (setq nnshimbun-current-directory pathname
 674               nnshimbun-current-group group))
 675       (unless (file-exists-p nnshimbun-current-directory)
 676         (ignore-errors (make-directory nnshimbun-current-directory t)))
 677       (cond
 678        ((not (file-exists-p nnshimbun-current-directory))
 679         (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 680                          nnshimbun-current-directory))
 681        ((not (file-directory-p (file-truename nnshimbun-current-directory)))
 682         (nnheader-report 'nnshimbun "Not a directory: %s"
 683                          nnshimbun-current-directory))
 684        (t t)))))
 685
 686
 687
 688 ;;; shimbun-gnus-mua
 689 (luna-define-class shimbun-gnus-mua (shimbun-mua) ())
 690
 691 (luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id)
 692   (nnshimbun-search-id
 693    (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
 694    id))
 695
 696 (luna-define-method shimbun-mua-use-entire-index ((mua shimbun-gnus-mua))
 697   nnshimbun-use-entire-index)
 698
 699
 700 (provide 'nnshimbun)
 701 ;;; nnshimbun.el ends here.