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

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