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