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*" (nnoo-current-server 'nnshimbun)))
 101          (gnus-backlog-articles nnshimbun-backlog-articles)
 102          (gnus-backlog-hashtb nnshimbun-backlog-hashtb))
 103      (unwind-protect
 104          (progn ,@form)
 105        (setq nnshimbun-backlog-articles gnus-backlog-articles
 106              nnshimbun-backlog-hashtb gnus-backlog-hashtb))))
 107 (put 'nnshimbun-backlog 'lisp-indent-function 0)
 108 (put 'nnshimbun-backlog 'edebug-form-spec '(form body))
 109
 110
 111 ;;; Interface Functions
 112 (nnoo-define-basics nnshimbun)
 113
 114 (deffoo nnshimbun-open-server (server &optional defs)
 115   (push (list 'nnshimbun-shimbun
 116               (condition-case err
 117                   (shimbun-open server (luna-make-entity 'shimbun-gnus-mua))
 118                 (error (nnheader-report 'nnshimbun "%s" (error-message-string err)))))
 119         defs)
 120   ;; Set directory for server working files.
 121   (push (list 'nnshimbun-server-directory
 122               (file-name-as-directory
 123                (expand-file-name server nnshimbun-directory)))
 124         defs)
 125   (nnoo-change-server 'nnshimbun server defs)
 126   (nnshimbun-possibly-change-group nil server)
 127   ;; Make directories.
 128   (unless (file-exists-p nnshimbun-directory)
 129     (ignore-errors (make-directory nnshimbun-directory t)))
 130   (cond
 131    ((not (file-exists-p nnshimbun-directory))
 132     (nnshimbun-close-server)
 133     (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-directory))
 134    ((not (file-directory-p (file-truename nnshimbun-directory)))
 135     (nnshimbun-close-server)
 136     (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-directory))
 137    (t
 138     (unless (file-exists-p nnshimbun-server-directory)
 139       (ignore-errors (make-directory nnshimbun-server-directory t)))
 140     (cond
 141      ((not (file-exists-p nnshimbun-server-directory))
 142       (nnshimbun-close-server)
 143       (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-server-directory))
 144      ((not (file-directory-p (file-truename nnshimbun-server-directory)))
 145       (nnshimbun-close-server)
 146       (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-server-directory))
 147      (t
 148       (nnheader-report 'nnshimbun "Opened server %s using directory %s"
 149                        server nnshimbun-server-directory)
 150       t)))))
 151
 152 (deffoo nnshimbun-close-server (&optional server)
 153   (shimbun-close nnshimbun-shimbun)
 154   (and (nnshimbun-server-opened server)
 155        (gnus-buffer-live-p nnshimbun-buffer)
 156        (kill-buffer nnshimbun-buffer))
 157   (nnshimbun-backlog (gnus-backlog-shutdown))
 158   (nnshimbun-save-nov)
 159   (nnoo-close-server 'nnshimbun server)
 160   t)
 161
 162 (eval-and-compile
 163   (let ((Gnus-p
 164          (eval-when-compile
 165            (let ((gnus (locate-library "gnus"))
 166                  ;; Gnus has mailcap.el in the same directory of gnus.el.
 167                  (mailcap (locate-library "mailcap")))
 168              (and gnus mailcap
 169                   (string-equal (file-name-directory gnus)
 170                                 (file-name-directory mailcap)))))))
 171     (if Gnus-p
 172         (progn
 173           (defmacro nnshimbun-mail-header-subject (header)
 174             `(mail-header-subject ,header))
 175           (defmacro nnshimbun-mail-header-from (header)
 176             `(mail-header-from ,header)))
 177       (defmacro nnshimbun-mail-header-subject (header)
 178         `(mime-entity-fetch-field ,header 'Subject))
 179       (defmacro nnshimbun-mail-header-from (header)
 180         `(mime-entity-fetch-field ,header 'From)))))
 181
 182 (defun nnshimbun-make-shimbun-header (header)
 183   (shimbun-make-header
 184    (mail-header-number header)
 185    (nnshimbun-mail-header-subject header)
 186    (nnshimbun-mail-header-from header)
 187    (mail-header-date header)
 188    (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header)))
 189        (mail-header-id header))
 190    (mail-header-references header)
 191    (mail-header-chars header)
 192    (mail-header-lines header)
 193    (let ((xref (mail-header-xref header)))
 194      (if (and xref (string-match "^Xref: " xref))
 195          (substring xref 6)
 196        xref))))
 197
 198 (defun nnshimbun-request-article-1 (article &optional group server to-buffer)
 199   (if (nnshimbun-backlog
 200         (gnus-backlog-request-article
 201          group article (or to-buffer nntp-server-buffer)))
 202       (cons group article)
 203     (let* ((header (with-current-buffer (nnshimbun-open-nov group)
 204                      (and (nnheader-find-nov-line article)
 205                           (nnshimbun-make-shimbun-header
 206                            (nnheader-parse-nov)))))
 207            (original-id (shimbun-header-id header)))
 208       (when header
 209         (with-current-buffer (or to-buffer nntp-server-buffer)
 210           (delete-region (point-min) (point-max))
 211           (shimbun-article nnshimbun-shimbun header)
 212           (when (> (buffer-size) 0)
 213             (nnshimbun-replace-nov-entry group article header original-id)
 214             (nnshimbun-backlog
 215               (gnus-backlog-enter-article group article (current-buffer)))
 216             (nnheader-report 'nnshimbun "Article %s retrieved"
 217                              (shimbun-header-id header))
 218             (cons group article)))))))
 219
 220 (deffoo nnshimbun-request-article (article &optional group server to-buffer)
 221   (when (nnshimbun-possibly-change-group group server)
 222     (when (stringp article)
 223       (setq article (nnshimbun-search-id group article)))
 224     (if (integerp article)
 225         (nnshimbun-request-article-1 article group server to-buffer)
 226       (nnheader-report 'nnshimbun "Couldn't retrieve article: %s"
 227                        (prin1-to-string article))
 228       nil)))
 229
 230 (deffoo nnshimbun-request-group (group &optional server dont-check)
 231   (let ((file-name-coding-system nnmail-pathname-coding-system)
 232         (pathname-coding-system nnmail-pathname-coding-system))
 233     (cond
 234      ((not (nnshimbun-possibly-change-group group server))
 235       (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
 236      ((not (file-exists-p nnshimbun-current-directory))
 237       (nnheader-report 'nnshimbun "Directory %s does not exist"
 238                        nnshimbun-current-directory))
 239      ((not (file-directory-p nnshimbun-current-directory))
 240       (nnheader-report 'nnshimbun "%s is not a directory"
 241                        nnshimbun-current-directory))
 242      (dont-check
 243       (nnheader-report 'nnshimbun "Group %s selected" group)
 244       t)
 245      (t
 246       (let (beg end lines)
 247         (with-current-buffer (nnshimbun-open-nov group)
 248           (goto-char (point-min))
 249           (setq beg (ignore-errors (read (current-buffer))))
 250           (goto-char (point-max))
 251           (forward-line -1)
 252           (setq end (ignore-errors (read (current-buffer)))
 253                 lines (count-lines (point-min) (point-max))))
 254         (nnheader-report 'nnshimbunw "Selected group %s" group)
 255         (nnheader-insert "211 %d %d %d %s\n"
 256                          lines (or beg 0) (or end 0) group))))))
 257
 258 (deffoo nnshimbun-request-scan (&optional group server)
 259   (nnshimbun-possibly-change-group group server)
 260   (nnshimbun-generate-nov-database group))
 261
 262 (deffoo nnshimbun-close-group (group &optional server)
 263   (nnshimbun-write-nov group)
 264   t)
 265
 266 (deffoo nnshimbun-request-list (&optional server)
 267   (with-current-buffer nntp-server-buffer
 268     (delete-region (point-min) (point-max))
 269     (dolist (group (shimbun-groups nnshimbun-shimbun))
 270       (when (nnshimbun-possibly-change-group group server)
 271         (let (beg end)
 272           (with-current-buffer (nnshimbun-open-nov group)
 273             (goto-char (point-min))
 274             (setq beg (ignore-errors (read (current-buffer))))
 275             (goto-char (point-max))
 276             (forward-line -1)
 277             (setq end (ignore-errors (read (current-buffer)))))
 278           (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
 279   t) ; return value
 280
 281 (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
 282   (when (nnshimbun-possibly-change-group group server)
 283     (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
 284         'nov
 285       (with-current-buffer nntp-server-buffer
 286         (delete-region (point-min) (point-max))
 287         (let (header)
 288           (dolist (art articles)
 289             (if (stringp art)
 290                 (setq art (nnshimbun-search-id group art)))
 291             (if (integerp art)
 292                 (when (setq header
 293                             (with-current-buffer (nnshimbun-open-nov group)
 294                               (and (nnheader-find-nov-line art)
 295                                    (nnheader-parse-nov))))
 296                   (insert (format "220 %d Article retrieved.\n" art))
 297                   (shimbun-header-insert
 298                    nnshimbun-shimbun
 299                    (nnshimbun-make-shimbun-header header))
 300                   (insert ".\n")
 301                   (delete-region (point) (point-max))))))
 302         'header))))
 303
 304 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
 305   (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
 306       nil
 307     (let ((nov (expand-file-name nnshimbun-nov-file-name nnshimbun-current-directory)))
 308       (when (file-exists-p nov)
 309         (save-excursion
 310           (set-buffer nntp-server-buffer)
 311           (erase-buffer)
 312           (nnheader-insert-file-contents nov)
 313           (if (and fetch-old (not (numberp fetch-old)))
 314               t                         ; Don't remove anything.
 315             (nnheader-nov-delete-outside-range
 316              (if fetch-old (max 1 (- (car articles) fetch-old))
 317                (car articles))
 318              (and articles (nth (1- (length articles)) articles)))
 319             t))))))
 320
 321
 322
 323 ;;; Nov Database Operations
 324
 325 (defvar nnshimbun-tmp-string nil
 326   "Internal variable used to just a rest for a temporary string.  The
 327 macro `nnshimbun-string-or' uses it exclusively.")
 328
 329 (defmacro nnshimbun-string-or (&rest strings)
 330   "Return the first element of STRINGS that is a non-blank string.  It
 331 should run fast, especially if two strings are given.  Each string can
 332 also be nil."
 333   (cond ((null strings)
 334          nil)
 335         ((= 1 (length strings))
 336          ;; Return irregularly nil if one blank string is given.
 337          `(unless (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 338             nnshimbun-tmp-string))
 339         ((= 2 (length strings))
 340          ;; Return the second string when the first string is blank.
 341          `(if (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 342               ,(cadr strings)
 343             nnshimbun-tmp-string))
 344         (t
 345          `(let ((strings (list ,@strings)))
 346             (while strings
 347               (setq strings (if (zerop (length (setq nnshimbun-tmp-string
 348                                                      (car strings))))
 349                                 (cdr strings))))
 350             nnshimbun-tmp-string))))
 351
 352 (defsubst nnshimbun-insert-nov (number header &optional id)
 353   (insert "\n")
 354   (backward-char 1)
 355   (let ((header-id (nnshimbun-string-or (shimbun-header-id header)))
 356         ;; Force `princ' to work in the current buffer.
 357         (standard-output (current-buffer))
 358         (xref (nnshimbun-string-or (shimbun-header-xref header)))
 359         (start (point)))
 360     (unless (and (stringp id)
 361                  header-id
 362                  (string-equal id header-id))
 363       (setq id nil))
 364     (princ number)
 365     (insert
 366      "\t"
 367      (nnshimbun-string-or (shimbun-header-subject header) "(none)") "\t"
 368      (nnshimbun-string-or (shimbun-header-from header) "(nobody)") "\t"
 369      (nnshimbun-string-or (shimbun-header-date header) (message-make-date))
 370      "\t"
 371      (or header-id (nnmail-message-id)) "\t"
 372      (or (shimbun-header-references header) "") "\t")
 373     (princ (or (shimbun-header-chars header) 0))
 374     (insert "\t")
 375     (princ (or (shimbun-header-lines header) 0))
 376     (insert "\t")
 377     (if xref
 378         (progn
 379           (insert "Xref: " xref "\t")
 380           (when id
 381             (insert "X-Nnshimbun-Id: " id "\t")))
 382       (if id
 383           (insert "\tX-Nnshimbun-Id: " id "\t")))
 384     ;; Replace newlines with spaces in the current NOV line.
 385     (while (progn
 386              (beginning-of-line)
 387              (> (point) start))
 388       (backward-delete-char 1)
 389       (insert " "))
 390     (forward-line 1)))
 391
 392 (defun nnshimbun-generate-nov-database (group)
 393   (nnshimbun-possibly-change-group group)
 394   (with-current-buffer (nnshimbun-open-nov group)
 395     (goto-char (point-max))
 396     (forward-line -1)
 397     (let ((i (or (ignore-errors (read (current-buffer))) 0)))
 398       (dolist (header (shimbun-headers nnshimbun-shimbun))
 399         (unless (nnshimbun-search-id group (shimbun-header-id header))
 400           (goto-char (point-max))
 401           (nnshimbun-insert-nov (setq i (1+ i)) header)
 402           (when nnshimbun-pre-fetch-article
 403             (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))
 404   (nnshimbun-write-nov group)))
 405
 406 (defun nnshimbun-replace-nov-entry (group article header &optional id)
 407   (with-current-buffer (nnshimbun-open-nov group)
 408     (when (nnheader-find-nov-line article)
 409       (delete-region (point) (progn (forward-line 1) (point)))
 410       (nnshimbun-insert-nov article header id))))
 411
 412 (defun nnshimbun-search-id (group id &optional nov)
 413   (with-current-buffer (nnshimbun-open-nov group)
 414     (goto-char (point-min))
 415     (let (found)
 416       (while (and (not found)
 417                   (search-forward id nil t)) ; We find the ID.
 418         ;; And the id is in the fourth field.
 419         (if (not (and (search-backward "\t" nil t 4)
 420                       (not (search-backward "\t" (gnus-point-at-bol) t))))
 421             (forward-line 1)
 422           (forward-line 0)
 423           (setq found t)))
 424       (unless found
 425         (goto-char (point-min))
 426         (setq id (concat "X-Nnshimbun-Id: " id))
 427         (while (and (not found)
 428                     (search-forward id nil t))
 429           (if (not (search-backward "\t" (gnus-point-at-bol) t 8))
 430               (forward-line 1)
 431             (forward-line 0)
 432             (setq found t))))
 433       (if found
 434           (if nov
 435               (nnheader-parse-nov)
 436             ;; We return the article number.
 437             (ignore-errors (read (current-buffer))))))))
 438
 439 (defun nnshimbun-open-nov (group)
 440   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 441     (if (buffer-live-p buffer)
 442         buffer
 443       (setq buffer (gnus-get-buffer-create
 444                     (format " *nnshimbun overview %s %s*"
 445                             (nnoo-current-server 'nnshimbun) group)))
 446       (save-excursion
 447         (set-buffer buffer)
 448         (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 449              (expand-file-name
 450               nnshimbun-nov-file-name
 451               (nnmail-group-pathname group nnshimbun-server-directory)))
 452         (erase-buffer)
 453         (when (file-exists-p nnshimbun-nov-buffer-file-name)
 454           (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
 455         (set-buffer-modified-p nil))
 456       (push (cons group buffer) nnshimbun-nov-buffer-alist)
 457       buffer)))
 458
 459 (defun nnshimbun-write-nov (group)
 460   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 461     (when (buffer-live-p buffer)
 462       (save-excursion
 463         (set-buffer buffer)
 464         (buffer-modified-p)
 465         (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 466                              nil 'nomesg)))))
 467
 468 (defun nnshimbun-save-nov ()
 469   (save-excursion
 470     (while nnshimbun-nov-buffer-alist
 471       (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
 472         (set-buffer (cdar nnshimbun-nov-buffer-alist))
 473         (when (buffer-modified-p)
 474           (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 475                                nil 'nomesg))
 476         (set-buffer-modified-p nil)
 477         (kill-buffer (current-buffer)))
 478       (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
 479
 480 (defvar nnshimbun-keep-last-article t
 481   "*If non-nil, nnshimbun will never delete a group's last article.  It
 482 can be marked expirable, so it will be deleted when it is no longer
 483 last.")
 484
 485 (defvar nnshimbun-keep-unparsable-dated-articles t
 486   "*If non-nil, nnshimbun will never delete articles whose NOV date is
 487 unparsable.  Even so, you can expire such articles using the command
 488 `nnshimbun-expire-nov-databases' with a prefix argument.")
 489
 490 (deffoo nnshimbun-request-expire-articles (articles group
 491                                                     &optional server force)
 492   "Do expire for the specified ARTICLES in the nnshimbun GROUP.  Notice
 493 that nnshimbun does not actually delete any articles, it just delete
 494 the corresponding entries in the NOV database locally.  If ARTICLES is
 495 `all', the expiring is performed on all the NOV lines.  It does expire
 496 only when the current SERVER is specified and the NOV is open.
 497 However, the optional FORCE if it is non-nil (it is supposed to be
 498 specified by the command `nnshimbun-expire-nov-databases'), it does
 499 expire for the SERVER:GROUP even if whose NOV is not open."
 500   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist)))
 501         (progress-msg (format "Expiring NOV database for nnshimbun+%s:%s "
 502                               server group))
 503         (pinwheel "-/|\\")
 504         (counter 0)
 505         should-close-nov name article expirable end time)
 506     (if (and
 507          server
 508          (or (let ((current (nnoo-current-server 'nnshimbun)))
 509                (and current
 510                     (string-equal server current)
 511                     (buffer-live-p buffer)))
 512              (when force
 513                (setq should-close-nov t
 514                      buffer (gnus-get-buffer-create
 515                              (format " *nnshimbun overview %s %s*"
 516                                      server group)))
 517                (save-excursion
 518                  (set-buffer buffer)
 519                  (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 520                       (expand-file-name
 521                        nnshimbun-nov-file-name
 522                        (expand-file-name
 523                         group
 524                         (expand-file-name
 525                          server
 526                          nnshimbun-directory))))
 527                  (erase-buffer)
 528                  (nnheader-insert-file-contents
 529                   nnshimbun-nov-buffer-file-name))
 530                (set-buffer-modified-p nil)
 531                t)))
 532         (prog1
 533             (save-excursion
 534               (setq name (concat "nnshimbun+" server ":" group))
 535               (set-buffer buffer)
 536               (when (eq 'all articles)
 537                 (setq articles nil)
 538                 (goto-char (point-min))
 539                 (while (not (eobp))
 540                   (when (looking-at "[0-9]+\t")
 541                     (push (read buffer) articles))
 542                   (forward-line 1))
 543                 (setq articles (nreverse articles)))
 544               (setq expirable (copy-sequence articles))
 545               (while expirable
 546                 (setq article (pop expirable))
 547                 (when (and (nnheader-find-nov-line article)
 548                            (setq end (line-end-position))
 549                            (not (and nnshimbun-keep-last-article
 550                                      (= (point-max) (1+ end)))))
 551                   (setq time (and (search-forward "\t" end t)
 552                                   (search-forward "\t" end t)
 553                                   (search-forward "\t" end t)
 554                                   (parse-time-string
 555                                    (buffer-substring
 556                                     (point)
 557                                     (if (search-forward "\t" end t)
 558                                         (1- (point))
 559                                       end)))))
 560                   (if (and
 561                        (or (setq time (condition-case nil
 562                                           (apply 'encode-time time)
 563                                         (error nil)))
 564                            ;; Inhibit expiring if there's no parsable date
 565                            ;; and the following option is non-nil.
 566                            (not nnshimbun-keep-unparsable-dated-articles))
 567                        (nnmail-expired-article-p name time nil))
 568                       (progn
 569                         (when force
 570                           (message "%s(%c)..." progress-msg article))
 571                         (beginning-of-line)
 572                         (delete-region (point) (1+ end))
 573                         (setq articles (delq article articles)))
 574                     (when force
 575                       (message "%s(%c)..."
 576                                progress-msg
 577                                (aref pinwheel
 578                                      (setq counter
 579                                            (logand 3 (1+ counter)))))))))
 580               (when (buffer-modified-p)
 581                 (nnmail-write-region 1 (point-max)
 582                                      nnshimbun-nov-buffer-file-name
 583                                      nil 'nomesg)
 584                 (set-buffer-modified-p nil))
 585               articles)
 586           (when should-close-nov
 587             (kill-buffer buffer)))
 588       t)))
 589
 590 ;;;###autoload
 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" nnshimbun-current-directory))
 667        ((not (file-directory-p (file-truename nnshimbun-current-directory)))
 668         (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-current-directory))
 669        (t t)))))
 670
 671
 672
 673 ;;; shimbun-gnus-mua
 674 (luna-define-class shimbun-gnus-mua (shimbun-mua) ())
 675
 676 (luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id)
 677   (nnshimbun-search-id
 678    (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
 679    id))
 680
 681 (luna-define-method shimbun-mua-use-entire-index ((mua shimbun-gnus-mua))
 682   nnshimbun-use-entire-index)
 683
 684
 685 (provide 'nnshimbun)
 686 ;;; nnshimbun.el ends here.