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