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

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