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