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

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