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