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://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 ((val (or (plist-get (nnshimbun-find-group-parameters ,name)
 240                                       'prefetch-articles)
 241                            nnshimbun-pre-fetch-article)))
 242               (if (eq 'off val)
 243                   nil
 244                 val)))
 245           ((eq 'encapsulate-images (eval symbol))
 246            `(let ((val (or (plist-get (nnshimbun-find-group-parameters ,name)
 247                                       'encapsulate-images)
 248                            nnshimbun-encapsulate-images)))
 249               (if (eq 'off val)
 250                   nil
 251                 val)))
 252           ((eq 'expiry-wait (eval symbol))
 253            (if full-name-p
 254                `(or (plist-get (nnshimbun-find-group-parameters ,group)
 255                                'expiry-wait)
 256                     (gnus-group-find-parameter ,group 'expiry-wait))
 257              `(let ((name ,name))
 258                 (or (plist-get (nnshimbun-find-group-parameters name)
 259                                'expiry-wait)
 260                     (gnus-group-find-parameter name 'expiry-wait)))))
 261           (t
 262            `(plist-get (nnshimbun-find-group-parameters ,name) ,symbol)))))
 263
 264
 265 ;;; Interface Functions
 266 (nnoo-define-basics nnshimbun)
 267
 268 (deffoo nnshimbun-open-server (server &optional defs)
 269   (push (list 'nnshimbun-shimbun
 270               (condition-case err
 271                   (shimbun-open server (luna-make-entity 'shimbun-gnus-mua))
 272                 (error (nnheader-report 'nnshimbun "%s" (error-message-string
 273                                                          err)))))
 274         defs)
 275   ;; Set directory for server working files.
 276   (push (list 'nnshimbun-server-directory
 277               (file-name-as-directory
 278                (expand-file-name server nnshimbun-directory)))
 279         defs)
 280   (nnoo-change-server 'nnshimbun server defs)
 281   (nnshimbun-possibly-change-group nil server)
 282   ;; Make directories.
 283   (unless (file-exists-p nnshimbun-directory)
 284     (ignore-errors (make-directory nnshimbun-directory t)))
 285   (cond
 286    ((not (file-exists-p nnshimbun-directory))
 287     (nnshimbun-close-server)
 288     (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 289                      nnshimbun-directory))
 290    ((not (file-directory-p (file-truename nnshimbun-directory)))
 291     (nnshimbun-close-server)
 292     (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-directory))
 293    (t
 294     (unless (file-exists-p nnshimbun-server-directory)
 295       (ignore-errors (make-directory nnshimbun-server-directory t)))
 296     (cond
 297      ((not (file-exists-p nnshimbun-server-directory))
 298       (nnshimbun-close-server)
 299       (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 300                        nnshimbun-server-directory))
 301      ((not (file-directory-p (file-truename nnshimbun-server-directory)))
 302       (nnshimbun-close-server)
 303       (nnheader-report 'nnshimbun "Not a directory: %s"
 304                        nnshimbun-server-directory))
 305      (t
 306       (nnheader-report 'nnshimbun "Opened server %s using directory %s"
 307                        server nnshimbun-server-directory)
 308       t)))))
 309
 310 (deffoo nnshimbun-close-server (&optional server)
 311   (when (nnshimbun-server-opened server)
 312     (when nnshimbun-shimbun
 313       (shimbun-close nnshimbun-shimbun))
 314     (when (gnus-buffer-live-p nnshimbun-buffer)
 315       (kill-buffer nnshimbun-buffer)))
 316   (nnshimbun-backlog (gnus-backlog-shutdown))
 317   (nnshimbun-save-nov)
 318   (nnoo-close-server 'nnshimbun server)
 319   t)
 320
 321 (eval-and-compile
 322   (let ((Gnus-p
 323          (eval-when-compile
 324            (let ((gnus (locate-library "gnus")))
 325              (and gnus
 326                   ;; Gnus has mailcap.el in the same directory of gnus.el.
 327                   (file-exists-p (expand-file-name
 328                                   "mailcap.el"
 329                                   (file-name-directory gnus))))))))
 330     (if Gnus-p
 331         (progn
 332           (defmacro nnshimbun-mail-header-subject (header)
 333             `(mail-header-subject ,header))
 334           (defmacro nnshimbun-mail-header-from (header)
 335             `(mail-header-from ,header)))
 336       (defmacro nnshimbun-mail-header-subject (header)
 337         `(mime-entity-fetch-field ,header 'Subject))
 338       (defmacro nnshimbun-mail-header-from (header)
 339         `(mime-entity-fetch-field ,header 'From)))))
 340
 341 (defun nnshimbun-make-shimbun-header (header)
 342   (shimbun-make-header
 343    (mail-header-number header)
 344    (nnshimbun-mail-header-subject header)
 345    (nnshimbun-mail-header-from header)
 346    (mail-header-date header)
 347    (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header)))
 348        (mail-header-id header))
 349    (mail-header-references header)
 350    (mail-header-chars header)
 351    (mail-header-lines header)
 352    (let ((xref (mail-header-xref header)))
 353      (if (and xref (string-match "^Xref: " xref))
 354          (substring xref 6)
 355        xref))))
 356
 357 (eval-when-compile
 358   (require 'gnus-sum));; For the macro `gnus-summary-article-header'.
 359
 360 (defun nnshimbun-request-article-1 (article &optional group server to-buffer)
 361   (if (nnshimbun-backlog
 362         (gnus-backlog-request-article
 363          group article (or to-buffer nntp-server-buffer)))
 364       (cons group article)
 365     (let* ((header (with-current-buffer (nnshimbun-open-nov group)
 366                      (and (nnheader-find-nov-line article)
 367                           (nnshimbun-make-shimbun-header
 368                            (nnheader-parse-nov)))))
 369            (original-id (shimbun-header-id header)))
 370       (when header
 371         (with-current-buffer (or to-buffer nntp-server-buffer)
 372           (delete-region (point-min) (point-max))
 373           (let ((shimbun-encapsulate-images
 374                  (nnshimbun-find-parameter group 'encapsulate-images)))
 375             (shimbun-article nnshimbun-shimbun header))
 376           (when (> (buffer-size) 0)
 377             ;; Kludge! replace a date string in `gnus-newsgroup-data'
 378             ;; based on the newly retrieved article.
 379             (let ((x (gnus-summary-article-header article)))
 380               (when x
 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     (when (stringp article)
 392       (let ((num (when (or group (setq group nnshimbun-current-group))
 393                    (nnshimbun-search-id group article))))
 394         (unless num
 395           (let ((groups (shimbun-groups (shimbun-open server))))
 396             (while (and (not num) groups)
 397               (setq group (pop groups)
 398                     num (nnshimbun-search-id group article)))))
 399         (setq article num)))
 400     (if (integerp article)
 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       nil)))
 405
 406 (deffoo nnshimbun-request-group (group &optional server dont-check)
 407   (let ((file-name-coding-system nnmail-pathname-coding-system)
 408         (pathname-coding-system nnmail-pathname-coding-system))
 409     (cond
 410      ((not (nnshimbun-possibly-change-group group server))
 411       (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
 412      ((not (file-exists-p nnshimbun-current-directory))
 413       (nnheader-report 'nnshimbun "Directory %s does not exist"
 414                        nnshimbun-current-directory))
 415      ((not (file-directory-p nnshimbun-current-directory))
 416       (nnheader-report 'nnshimbun "%s is not a directory"
 417                        nnshimbun-current-directory))
 418      (dont-check
 419       (nnheader-report 'nnshimbun "Group %s selected" group)
 420       t)
 421      (t
 422       (let (beg end lines)
 423         (with-current-buffer (nnshimbun-open-nov group)
 424           (goto-char (point-min))
 425           (setq beg (ignore-errors (read (current-buffer))))
 426           (goto-char (point-max))
 427           (forward-line -1)
 428           (setq end (ignore-errors (read (current-buffer)))
 429                 lines (count-lines (point-min) (point-max))))
 430         (nnheader-report 'nnshimbun "Selected group %s" group)
 431         (nnheader-insert "211 %d %d %d %s\n"
 432                          lines (or beg 0) (or end 0) group))))))
 433
 434 (deffoo nnshimbun-request-scan (&optional group server)
 435   (nnshimbun-possibly-change-group group server)
 436   (nnshimbun-generate-nov-database group))
 437
 438 (deffoo nnshimbun-close-group (group &optional server)
 439   (nnshimbun-write-nov group)
 440   t)
 441
 442 (deffoo nnshimbun-request-list (&optional server)
 443   (with-current-buffer nntp-server-buffer
 444     (delete-region (point-min) (point-max))
 445     (dolist (group (shimbun-groups nnshimbun-shimbun))
 446       (when (nnshimbun-possibly-change-group group server)
 447         (let (beg end)
 448           (with-current-buffer (nnshimbun-open-nov group)
 449             (goto-char (point-min))
 450             (setq beg (ignore-errors (read (current-buffer))))
 451             (goto-char (point-max))
 452             (forward-line -1)
 453             (setq end (ignore-errors (read (current-buffer)))))
 454           (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
 455   t) ; return value
 456
 457 (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
 458   (when (nnshimbun-possibly-change-group group server)
 459     (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
 460         'nov
 461       (with-current-buffer nntp-server-buffer
 462         (delete-region (point-min) (point-max))
 463         (let (header)
 464           (dolist (art articles)
 465             (if (stringp art)
 466                 (setq art (nnshimbun-search-id group art)))
 467             (if (integerp art)
 468                 (when (setq header
 469                             (with-current-buffer (nnshimbun-open-nov group)
 470                               (and (nnheader-find-nov-line art)
 471                                    (nnheader-parse-nov))))
 472                   (insert (format "220 %d Article retrieved.\n" art))
 473                   (shimbun-header-insert
 474                    nnshimbun-shimbun
 475                    (nnshimbun-make-shimbun-header header))
 476                   (insert ".\n")
 477                   (delete-region (point) (point-max))))))
 478         'header))))
 479
 480 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
 481   (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
 482       nil
 483     (let ((nov (expand-file-name nnshimbun-nov-file-name
 484                                  nnshimbun-current-directory)))
 485       (when (file-exists-p nov)
 486         (save-excursion
 487           (set-buffer nntp-server-buffer)
 488           (erase-buffer)
 489           (nnheader-insert-file-contents nov)
 490           (if (and fetch-old (not (numberp fetch-old)))
 491               t                         ; Don't remove anything.
 492             (nnheader-nov-delete-outside-range
 493              (if fetch-old (max 1 (- (car articles) fetch-old))
 494                (car articles))
 495              (nth (1- (length articles)) articles))
 496             t))))))
 497
 498
 499
 500 ;;; Nov Database Operations
 501
 502 (defvar nnshimbun-tmp-string nil
 503   "Internal variable used to just a rest for a temporary string.  The
 504 macro `nnshimbun-string-or' uses it exclusively.")
 505
 506 (defmacro nnshimbun-string-or (&rest strings)
 507   "Return the first element of STRINGS that is a non-blank string.  It
 508 should run fast, especially if two strings are given.  Each string can
 509 also be nil."
 510   (cond ((null strings)
 511          nil)
 512         ((= 1 (length strings))
 513          ;; Return irregularly nil if one blank string is given.
 514          `(unless (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 515             nnshimbun-tmp-string))
 516         ((= 2 (length strings))
 517          ;; Return the second string when the first string is blank.
 518          `(if (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 519               ,(cadr strings)
 520             nnshimbun-tmp-string))
 521         (t
 522          `(let ((strings (list ,@strings)))
 523             (while strings
 524               (setq strings (if (zerop (length (setq nnshimbun-tmp-string
 525                                                      (car strings))))
 526                                 (cdr strings))))
 527             nnshimbun-tmp-string))))
 528
 529 (defsubst nnshimbun-insert-nov (number header &optional id)
 530   (insert "\n")
 531   (backward-char 1)
 532   (let ((header-id (nnshimbun-string-or (shimbun-header-id header)))
 533         ;; Force `princ' to work in the current buffer.
 534         (standard-output (current-buffer))
 535         (xref (nnshimbun-string-or (shimbun-header-xref header)))
 536         (start (point)))
 537     (and (stringp id)
 538          header-id
 539          (string-equal id header-id)
 540          (setq id nil))
 541     (princ number)
 542     (insert
 543      "\t"
 544      (nnshimbun-string-or (shimbun-header-subject header) "(none)") "\t"
 545      (nnshimbun-string-or (shimbun-header-from header) "(nobody)") "\t"
 546      (nnshimbun-string-or (shimbun-header-date header) (message-make-date))
 547      "\t"
 548      (or header-id (nnmail-message-id)) "\t"
 549      (or (shimbun-header-references header) "") "\t")
 550     (princ (or (shimbun-header-chars header) 0))
 551     (insert "\t")
 552     (princ (or (shimbun-header-lines header) 0))
 553     (insert "\t")
 554     (if xref
 555         (progn
 556           (insert "Xref: " xref "\t")
 557           (when id
 558             (insert "X-Nnshimbun-Id: " id "\t")))
 559       (when id
 560         (insert "\tX-Nnshimbun-Id: " id "\t")))
 561     ;; Replace newlines with spaces in the current NOV line.
 562     (while (progn
 563              (forward-line 0)
 564              (> (point) start))
 565       (backward-delete-char 1)
 566       (insert " "))
 567     (forward-line 1)))
 568
 569 (defun nnshimbun-generate-nov-database (group)
 570   (nnshimbun-possibly-change-group group)
 571   (with-current-buffer (nnshimbun-open-nov group)
 572     (goto-char (point-max))
 573     (forward-line -1)
 574     (let* ((i (or (ignore-errors (read (current-buffer))) 0))
 575            (name (concat "nnshimbun+" (nnoo-current-server 'nnshimbun)
 576                          ":" group))
 577            (pre-fetch (nnshimbun-find-parameter name 'prefetch-articles t)))
 578       (dolist (header
 579                (shimbun-headers
 580                 nnshimbun-shimbun
 581                 (nnshimbun-find-parameter name 'index-range t)))
 582         (unless (nnshimbun-search-id group (shimbun-header-id header))
 583           (goto-char (point-max))
 584           (nnshimbun-insert-nov (setq i (1+ i)) header)
 585           (when pre-fetch
 586             (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))
 587     (nnshimbun-write-nov group)))
 588
 589 (defun nnshimbun-replace-nov-entry (group article header &optional id)
 590   (with-current-buffer (nnshimbun-open-nov group)
 591     (when (nnheader-find-nov-line article)
 592       (delete-region (point) (progn (forward-line 1) (point)))
 593       (nnshimbun-insert-nov article header id))))
 594
 595 (defun nnshimbun-search-id (group id &optional nov)
 596   (with-current-buffer (nnshimbun-open-nov group)
 597     (goto-char (point-min))
 598     (let (found)
 599       (while (and (not found)
 600                   (search-forward id nil t)) ; We find the ID.
 601         ;; And the id is in the fourth field.
 602         (if (not (and (search-backward "\t" nil t 4)
 603                       (not (search-backward "\t" (gnus-point-at-bol) t))))
 604             (forward-line 1)
 605           (forward-line 0)
 606           (setq found t)))
 607       (unless found
 608         (goto-char (point-min))
 609         (setq id (concat "X-Nnshimbun-Id: " id))
 610         (while (and (not found)
 611                     (search-forward id nil t))
 612           (if (not (search-backward "\t" (gnus-point-at-bol) t 8))
 613               (forward-line 1)
 614             (forward-line 0)
 615             (setq found t))))
 616       (when found
 617         (if nov
 618             (nnheader-parse-nov)
 619           ;; We return the article number.
 620           (ignore-errors (read (current-buffer))))))))
 621
 622 (defun nnshimbun-open-nov (group)
 623   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 624     (if (buffer-live-p buffer)
 625         buffer
 626       (setq buffer (gnus-get-buffer-create
 627                     (format " *nnshimbun overview %s %s*"
 628                             (nnoo-current-server 'nnshimbun) group)))
 629       (save-excursion
 630         (set-buffer buffer)
 631         (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 632              (expand-file-name
 633               nnshimbun-nov-file-name
 634               (nnmail-group-pathname group nnshimbun-server-directory)))
 635         (erase-buffer)
 636         (when (file-exists-p nnshimbun-nov-buffer-file-name)
 637           (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
 638         (set-buffer-modified-p nil))
 639       (push (cons group buffer) nnshimbun-nov-buffer-alist)
 640       buffer)))
 641
 642 (defun nnshimbun-write-nov (group)
 643   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 644     (when (buffer-live-p buffer)
 645       (save-excursion
 646         (set-buffer buffer)
 647         (and (> (buffer-size) 0)
 648              (buffer-modified-p)
 649              (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 650                                   nil 'nomesg))))))
 651
 652 (defun nnshimbun-save-nov ()
 653   (save-excursion
 654     (while nnshimbun-nov-buffer-alist
 655       (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
 656         (set-buffer (cdar nnshimbun-nov-buffer-alist))
 657         (and (> (buffer-size) 0)
 658              (buffer-modified-p)
 659              (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 660                                   nil 'nomesg))
 661         (kill-buffer (current-buffer)))
 662       (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
 663
 664 (deffoo nnshimbun-request-expire-articles (articles group
 665                                                     &optional server force)
 666   "Do expiration for the specified ARTICLES in the nnshimbun GROUP.
 667 Notice that nnshimbun does not actually delete any articles, it just
 668 delete the corresponding entries in the NOV database locally.  The
 669 expiration will be performed only when the current SERVER is specified
 670 and the NOV is open.  The optional fourth argument FORCE is ignored."
 671   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 672     (if (and server
 673              ;; Don't use 'string-equal' in the following.
 674              (equal server (nnoo-current-server 'nnshimbun))
 675              (buffer-live-p buffer))
 676         (let* ((expirable (copy-sequence articles))
 677                (name (concat "nnshimbun+" server ":" group))
 678                ;; If the group's parameter `expiry-wait' is non-nil,
 679                ;; the value of the option `nnmail-expiry-wait' will be
 680                ;; bound to that value, and the value of the option
 681                ;; `nnmail-expiry-wait-function' will be bound to nil.
 682                ;; See the source code of `gnus-summary-expire-articles'
 683                ;; how does it work.  If the group's parameter is not
 684                ;; specified by user, the shimbun's default value will
 685                ;; be used.
 686                (expiry-wait
 687                 (or (nnshimbun-find-parameter name 'expiry-wait t)
 688                     (shimbun-article-expiration-days nnshimbun-shimbun)))
 689                (nnmail-expiry-wait (or expiry-wait nnmail-expiry-wait))
 690                (nnmail-expiry-wait-function (if expiry-wait
 691                                                 nil
 692                                               nnmail-expiry-wait-function))
 693                article end time)
 694           (save-excursion
 695             (set-buffer buffer)
 696             (while expirable
 697               (setq article (pop expirable))
 698               (when (and (nnheader-find-nov-line article)
 699                          (setq end (line-end-position))
 700                          (not (= (point-max) (1+ end))))
 701                 (setq time (and (search-forward "\t" end t)
 702                                 (search-forward "\t" end t)
 703                                 (search-forward "\t" end t)
 704                                 (parse-time-string
 705                                  (buffer-substring
 706                                   (point)
 707                                   (if (search-forward "\t" end t)
 708                                       (1- (point))
 709                                     end)))))
 710                 (when (cond ((setq time (condition-case nil
 711                                             (apply 'encode-time time)
 712                                           (error nil)))
 713                              (nnmail-expired-article-p name time nil))
 714                             (t
 715                              ;; Inhibit expiration if there's no parsable
 716                              ;; date and the following option is non-nil.
 717                              (not nnshimbun-keep-unparsable-dated-articles)))
 718                   (beginning-of-line)
 719                   (delete-region (point) (1+ end))
 720                   (setq articles (delq article articles)))))
 721             (when (buffer-modified-p)
 722               (nnmail-write-region 1 (point-max)
 723                                    nnshimbun-nov-buffer-file-name
 724                                    nil 'nomesg)
 725               (set-buffer-modified-p nil))
 726             articles))
 727       t)))
 728
 729
 730
 731 ;;; Server Initialize
 732
 733 (defun nnshimbun-possibly-change-group (group &optional server)
 734   (when server
 735     (unless (nnshimbun-server-opened server)
 736       (nnshimbun-open-server server)))
 737   (unless (gnus-buffer-live-p nnshimbun-buffer)
 738     (setq nnshimbun-buffer
 739           (save-excursion
 740             (nnheader-set-temp-buffer
 741              (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
 742   (if (not group)
 743       t
 744     (condition-case err
 745         (shimbun-open-group nnshimbun-shimbun group)
 746       (error (nnheader-report 'nnshimbun "%s" (error-message-string err))))
 747     (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
 748           (file-name-coding-system nnmail-pathname-coding-system)
 749           (pathname-coding-system nnmail-pathname-coding-system))
 750       (unless (equal pathname nnshimbun-current-directory)
 751         (setq nnshimbun-current-directory pathname
 752               nnshimbun-current-group group))
 753       (unless (file-exists-p nnshimbun-current-directory)
 754         (ignore-errors (make-directory nnshimbun-current-directory t)))
 755       (cond
 756        ((not (file-exists-p nnshimbun-current-directory))
 757         (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 758                          nnshimbun-current-directory))
 759        ((not (file-directory-p (file-truename nnshimbun-current-directory)))
 760         (nnheader-report 'nnshimbun "Not a directory: %s"
 761                          nnshimbun-current-directory))
 762        (t t)))))
 763
 764
 765
 766 ;;; shimbun-gnus-mua
 767 (luna-define-class shimbun-gnus-mua (shimbun-mua) ())
 768
 769 (luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id)
 770   (nnshimbun-search-id
 771    (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
 772    id))
 773
 774
 775
 776 ;;; Command to create nnshimbun group
 777
 778 (defvar nnshimbun-server-history nil)
 779
 780 ;;;###autoload
 781 (defun gnus-group-make-shimbun-group ()
 782   "Create a nnshimbun group."
 783   (interactive)
 784   (let* ((minibuffer-setup-hook
 785           (append minibuffer-setup-hook '(beginning-of-line)))
 786          (alist
 787           (apply 'nconc
 788                  (mapcar
 789                   (lambda (d)
 790                     (and (stringp d)
 791                          (file-directory-p d)
 792                          (delq nil
 793                                (mapcar
 794                                 (lambda (f)
 795                                   (and (string-match "^sb-\\(.*\\)\\.el$" f)
 796                                        (list (match-string 1 f))))
 797                                 (directory-files d)))))
 798                   load-path)))
 799          (server (completing-read
 800                   "Shimbun address: "
 801                   alist nil t
 802                   (or (car nnshimbun-server-history)
 803                       (caar alist))
 804                   'nnshimbun-server-history))
 805          (groups)
 806          (nnshimbun-pre-fetch-article))
 807     (if (setq groups (shimbun-groups (shimbun-open server)))
 808         (gnus-group-make-group
 809          (completing-read "Group name: " (mapcar 'list groups) nil t nil)
 810          (list 'nnshimbun server))
 811       (error "%s" "Can't find group"))))
 812
 813
 814 (provide 'nnshimbun)
 815
 816 ;;; nnshimbun.el ends here