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