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://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       (setq article (nnshimbun-search-id group article)))
 393     (if (integerp article)
 394         (nnshimbun-request-article-1 article group server to-buffer)
 395       (nnheader-report 'nnshimbun "Couldn't retrieve article: %s"
 396                        (prin1-to-string article))
 397       nil)))
 398
 399 (deffoo nnshimbun-request-group (group &optional server dont-check)
 400   (let ((file-name-coding-system nnmail-pathname-coding-system)
 401         (pathname-coding-system nnmail-pathname-coding-system))
 402     (cond
 403      ((not (nnshimbun-possibly-change-group group server))
 404       (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
 405      ((not (file-exists-p nnshimbun-current-directory))
 406       (nnheader-report 'nnshimbun "Directory %s does not exist"
 407                        nnshimbun-current-directory))
 408      ((not (file-directory-p nnshimbun-current-directory))
 409       (nnheader-report 'nnshimbun "%s is not a directory"
 410                        nnshimbun-current-directory))
 411      (dont-check
 412       (nnheader-report 'nnshimbun "Group %s selected" group)
 413       t)
 414      (t
 415       (let (beg end lines)
 416         (with-current-buffer (nnshimbun-open-nov group)
 417           (goto-char (point-min))
 418           (setq beg (ignore-errors (read (current-buffer))))
 419           (goto-char (point-max))
 420           (forward-line -1)
 421           (setq end (ignore-errors (read (current-buffer)))
 422                 lines (count-lines (point-min) (point-max))))
 423         (nnheader-report 'nnshimbun "Selected group %s" group)
 424         (nnheader-insert "211 %d %d %d %s\n"
 425                          lines (or beg 0) (or end 0) group))))))
 426
 427 (deffoo nnshimbun-request-scan (&optional group server)
 428   (nnshimbun-possibly-change-group group server)
 429   (nnshimbun-generate-nov-database group))
 430
 431 (deffoo nnshimbun-close-group (group &optional server)
 432   (nnshimbun-write-nov group)
 433   t)
 434
 435 (deffoo nnshimbun-request-list (&optional server)
 436   (with-current-buffer nntp-server-buffer
 437     (delete-region (point-min) (point-max))
 438     (dolist (group (shimbun-groups nnshimbun-shimbun))
 439       (when (nnshimbun-possibly-change-group group server)
 440         (let (beg end)
 441           (with-current-buffer (nnshimbun-open-nov group)
 442             (goto-char (point-min))
 443             (setq beg (ignore-errors (read (current-buffer))))
 444             (goto-char (point-max))
 445             (forward-line -1)
 446             (setq end (ignore-errors (read (current-buffer)))))
 447           (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
 448   t) ; return value
 449
 450 (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
 451   (when (nnshimbun-possibly-change-group group server)
 452     (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
 453         'nov
 454       (with-current-buffer nntp-server-buffer
 455         (delete-region (point-min) (point-max))
 456         (let (header)
 457           (dolist (art articles)
 458             (if (stringp art)
 459                 (setq art (nnshimbun-search-id group art)))
 460             (if (integerp art)
 461                 (when (setq header
 462                             (with-current-buffer (nnshimbun-open-nov group)
 463                               (and (nnheader-find-nov-line art)
 464                                    (nnheader-parse-nov))))
 465                   (insert (format "220 %d Article retrieved.\n" art))
 466                   (shimbun-header-insert
 467                    nnshimbun-shimbun
 468                    (nnshimbun-make-shimbun-header header))
 469                   (insert ".\n")
 470                   (delete-region (point) (point-max))))))
 471         'header))))
 472
 473 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
 474   (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
 475       nil
 476     (let ((nov (expand-file-name nnshimbun-nov-file-name
 477                                  nnshimbun-current-directory)))
 478       (when (file-exists-p nov)
 479         (save-excursion
 480           (set-buffer nntp-server-buffer)
 481           (erase-buffer)
 482           (nnheader-insert-file-contents nov)
 483           (if (and fetch-old (not (numberp fetch-old)))
 484               t                         ; Don't remove anything.
 485             (nnheader-nov-delete-outside-range
 486              (if fetch-old (max 1 (- (car articles) fetch-old))
 487                (car articles))
 488              (nth (1- (length articles)) articles))
 489             t))))))
 490
 491
 492
 493 ;;; Nov Database Operations
 494
 495 (defvar nnshimbun-tmp-string nil
 496   "Internal variable used to just a rest for a temporary string.  The
 497 macro `nnshimbun-string-or' uses it exclusively.")
 498
 499 (defmacro nnshimbun-string-or (&rest strings)
 500   "Return the first element of STRINGS that is a non-blank string.  It
 501 should run fast, especially if two strings are given.  Each string can
 502 also be nil."
 503   (cond ((null strings)
 504          nil)
 505         ((= 1 (length strings))
 506          ;; Return irregularly nil if one blank string is given.
 507          `(unless (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 508             nnshimbun-tmp-string))
 509         ((= 2 (length strings))
 510          ;; Return the second string when the first string is blank.
 511          `(if (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 512               ,(cadr strings)
 513             nnshimbun-tmp-string))
 514         (t
 515          `(let ((strings (list ,@strings)))
 516             (while strings
 517               (setq strings (if (zerop (length (setq nnshimbun-tmp-string
 518                                                      (car strings))))
 519                                 (cdr strings))))
 520             nnshimbun-tmp-string))))
 521
 522 (defsubst nnshimbun-insert-nov (number header &optional id)
 523   (insert "\n")
 524   (backward-char 1)
 525   (let ((header-id (nnshimbun-string-or (shimbun-header-id header)))
 526         ;; Force `princ' to work in the current buffer.
 527         (standard-output (current-buffer))
 528         (xref (nnshimbun-string-or (shimbun-header-xref header)))
 529         (start (point)))
 530     (and (stringp id)
 531          header-id
 532          (string-equal id header-id)
 533          (setq id nil))
 534     (princ number)
 535     (insert
 536      "\t"
 537      (nnshimbun-string-or (shimbun-header-subject header) "(none)") "\t"
 538      (nnshimbun-string-or (shimbun-header-from header) "(nobody)") "\t"
 539      (nnshimbun-string-or (shimbun-header-date header) (message-make-date))
 540      "\t"
 541      (or header-id (nnmail-message-id)) "\t"
 542      (or (shimbun-header-references header) "") "\t")
 543     (princ (or (shimbun-header-chars header) 0))
 544     (insert "\t")
 545     (princ (or (shimbun-header-lines header) 0))
 546     (insert "\t")
 547     (if xref
 548         (progn
 549           (insert "Xref: " xref "\t")
 550           (when id
 551             (insert "X-Nnshimbun-Id: " id "\t")))
 552       (when id
 553         (insert "\tX-Nnshimbun-Id: " id "\t")))
 554     ;; Replace newlines with spaces in the current NOV line.
 555     (while (progn
 556              (forward-line 0)
 557              (> (point) start))
 558       (backward-delete-char 1)
 559       (insert " "))
 560     (forward-line 1)))
 561
 562 (defun nnshimbun-generate-nov-database (group)
 563   (nnshimbun-possibly-change-group group)
 564   (with-current-buffer (nnshimbun-open-nov group)
 565     (goto-char (point-max))
 566     (forward-line -1)
 567     (let* ((i (or (ignore-errors (read (current-buffer))) 0))
 568            (name (concat "nnshimbun+" (nnoo-current-server 'nnshimbun)
 569                          ":" group))
 570            (pre-fetch (nnshimbun-find-parameter name 'prefetch-articles t)))
 571       (dolist (header
 572                (shimbun-headers
 573                 nnshimbun-shimbun
 574                 (nnshimbun-find-parameter name 'index-range t)))
 575         (unless (nnshimbun-search-id group (shimbun-header-id header))
 576           (goto-char (point-max))
 577           (nnshimbun-insert-nov (setq i (1+ i)) header)
 578           (when pre-fetch
 579             (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))
 580     (nnshimbun-write-nov group)))
 581
 582 (defun nnshimbun-replace-nov-entry (group article header &optional id)
 583   (with-current-buffer (nnshimbun-open-nov group)
 584     (when (nnheader-find-nov-line article)
 585       (delete-region (point) (progn (forward-line 1) (point)))
 586       (nnshimbun-insert-nov article header id))))
 587
 588 (defun nnshimbun-search-id (group id &optional nov)
 589   (with-current-buffer (nnshimbun-open-nov group)
 590     (goto-char (point-min))
 591     (let (found)
 592       (while (and (not found)
 593                   (search-forward id nil t)) ; We find the ID.
 594         ;; And the id is in the fourth field.
 595         (if (not (and (search-backward "\t" nil t 4)
 596                       (not (search-backward "\t" (gnus-point-at-bol) t))))
 597             (forward-line 1)
 598           (forward-line 0)
 599           (setq found t)))
 600       (unless found
 601         (goto-char (point-min))
 602         (setq id (concat "X-Nnshimbun-Id: " id))
 603         (while (and (not found)
 604                     (search-forward id nil t))
 605           (if (not (search-backward "\t" (gnus-point-at-bol) t 8))
 606               (forward-line 1)
 607             (forward-line 0)
 608             (setq found t))))
 609       (when found
 610         (if nov
 611             (nnheader-parse-nov)
 612           ;; We return the article number.
 613           (ignore-errors (read (current-buffer))))))))
 614
 615 (defun nnshimbun-open-nov (group)
 616   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 617     (if (buffer-live-p buffer)
 618         buffer
 619       (setq buffer (gnus-get-buffer-create
 620                     (format " *nnshimbun overview %s %s*"
 621                             (nnoo-current-server 'nnshimbun) group)))
 622       (save-excursion
 623         (set-buffer buffer)
 624         (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 625              (expand-file-name
 626               nnshimbun-nov-file-name
 627               (nnmail-group-pathname group nnshimbun-server-directory)))
 628         (erase-buffer)
 629         (when (file-exists-p nnshimbun-nov-buffer-file-name)
 630           (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
 631         (set-buffer-modified-p nil))
 632       (push (cons group buffer) nnshimbun-nov-buffer-alist)
 633       buffer)))
 634
 635 (defun nnshimbun-write-nov (group)
 636   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 637     (when (buffer-live-p buffer)
 638       (save-excursion
 639         (set-buffer buffer)
 640         (buffer-modified-p)
 641         (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 642                              nil 'nomesg)))))
 643
 644 (defun nnshimbun-save-nov ()
 645   (save-excursion
 646     (while nnshimbun-nov-buffer-alist
 647       (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
 648         (set-buffer (cdar nnshimbun-nov-buffer-alist))
 649         (when (buffer-modified-p)
 650           (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 651                                nil 'nomesg))
 652         (set-buffer-modified-p nil)
 653         (kill-buffer (current-buffer)))
 654       (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
 655
 656 (deffoo nnshimbun-request-expire-articles (articles group
 657                                                     &optional server force)
 658   "Do expiration for the specified ARTICLES in the nnshimbun GROUP.
 659 Notice that nnshimbun does not actually delete any articles, it just
 660 delete the corresponding entries in the NOV database locally.  The
 661 expiration will be performed only when the current SERVER is specified
 662 and the NOV is open.  The optional fourth argument FORCE is ignored."
 663   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 664     (if (and server
 665              ;; Don't use 'string-equal' in the following.
 666              (equal server (nnoo-current-server 'nnshimbun))
 667              (buffer-live-p buffer))
 668         (let* ((expirable (copy-sequence articles))
 669                (name (concat "nnshimbun+" server ":" group))
 670                ;; If the group's parameter `expiry-wait' is non-nil,
 671                ;; the value of the option `nnmail-expiry-wait' will be
 672                ;; bound to that value, and the value of the option
 673                ;; `nnmail-expiry-wait-function' will be bound to nil.
 674                ;; See the source code of `gnus-summary-expire-articles'
 675                ;; how does it work.  If the group's parameter is not
 676                ;; specified by user, the shimbun's default value will
 677                ;; be used.
 678                (expiry-wait
 679                 (or (nnshimbun-find-parameter name 'expiry-wait t)
 680                     (shimbun-article-expiration-days nnshimbun-shimbun)))
 681                (nnmail-expiry-wait (or expiry-wait nnmail-expiry-wait))
 682                (nnmail-expiry-wait-function (if expiry-wait
 683                                                 nil
 684                                               nnmail-expiry-wait-function))
 685                article end time)
 686           (save-excursion
 687             (set-buffer buffer)
 688             (while expirable
 689               (setq article (pop expirable))
 690               (when (and (nnheader-find-nov-line article)
 691                          (setq end (line-end-position))
 692                          (not (= (point-max) (1+ end))))
 693                 (setq time (and (search-forward "\t" end t)
 694                                 (search-forward "\t" end t)
 695                                 (search-forward "\t" end t)
 696                                 (parse-time-string
 697                                  (buffer-substring
 698                                   (point)
 699                                   (if (search-forward "\t" end t)
 700                                       (1- (point))
 701                                     end)))))
 702                 (when (cond ((setq time (condition-case nil
 703                                             (apply 'encode-time time)
 704                                           (error nil)))
 705                              (nnmail-expired-article-p name time nil))
 706                             (t
 707                              ;; Inhibit expiration if there's no parsable
 708                              ;; date and the following option is non-nil.
 709                              (not nnshimbun-keep-unparsable-dated-articles)))
 710                   (beginning-of-line)
 711                   (delete-region (point) (1+ end))
 712                   (setq articles (delq article articles)))))
 713             (when (buffer-modified-p)
 714               (nnmail-write-region 1 (point-max)
 715                                    nnshimbun-nov-buffer-file-name
 716                                    nil 'nomesg)
 717               (set-buffer-modified-p nil))
 718             articles))
 719       t)))
 720
 721
 722
 723 ;;; Server Initialize
 724
 725 (defun nnshimbun-possibly-change-group (group &optional server)
 726   (when server
 727     (unless (nnshimbun-server-opened server)
 728       (nnshimbun-open-server server)))
 729   (unless (gnus-buffer-live-p nnshimbun-buffer)
 730     (setq nnshimbun-buffer
 731           (save-excursion
 732             (nnheader-set-temp-buffer
 733              (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
 734   (if (not group)
 735       t
 736     (condition-case err
 737         (shimbun-open-group nnshimbun-shimbun group)
 738       (error (nnheader-report 'nnshimbun "%s" (error-message-string err))))
 739     (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
 740           (file-name-coding-system nnmail-pathname-coding-system)
 741           (pathname-coding-system nnmail-pathname-coding-system))
 742       (unless (equal pathname nnshimbun-current-directory)
 743         (setq nnshimbun-current-directory pathname
 744               nnshimbun-current-group group))
 745       (unless (file-exists-p nnshimbun-current-directory)
 746         (ignore-errors (make-directory nnshimbun-current-directory t)))
 747       (cond
 748        ((not (file-exists-p nnshimbun-current-directory))
 749         (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 750                          nnshimbun-current-directory))
 751        ((not (file-directory-p (file-truename nnshimbun-current-directory)))
 752         (nnheader-report 'nnshimbun "Not a directory: %s"
 753                          nnshimbun-current-directory))
 754        (t t)))))
 755
 756
 757
 758 ;;; shimbun-gnus-mua
 759 (luna-define-class shimbun-gnus-mua (shimbun-mua) ())
 760
 761 (luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id)
 762   (nnshimbun-search-id
 763    (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
 764    id))
 765
 766
 767
 768 ;;; Command to create nnshimbun group
 769
 770 (defvar nnshimbun-server-history nil)
 771
 772 ;;;###autoload
 773 (defun gnus-group-make-shimbun-group ()
 774   "Create a nnshimbun group."
 775   (interactive)
 776   (let* ((minibuffer-setup-hook
 777           (append minibuffer-setup-hook '(beginning-of-line)))
 778          (alist
 779           (apply 'nconc
 780                  (mapcar
 781                   (lambda (d)
 782                     (and (stringp d)
 783                          (file-directory-p d)
 784                          (delq nil
 785                                (mapcar
 786                                 (lambda (f)
 787                                   (and (string-match "^sb-\\(.*\\)\\.el$" f)
 788                                        (list (match-string 1 f))))
 789                                 (directory-files d)))))
 790                   load-path)))
 791          (server (completing-read
 792                   "Shimbun address: "
 793                   alist nil t
 794                   (or (car nnshimbun-server-history)
 795                       (caar alist))
 796                   'nnshimbun-server-history))
 797          (groups)
 798          (nnshimbun-pre-fetch-article))
 799     (if (setq groups (shimbun-groups (shimbun-open server)))
 800         (gnus-group-make-group
 801          (completing-read "Group name: " (mapcar 'list groups) nil t nil)
 802          (list 'nnshimbun server))
 803       (error "%s" "Can't find group"))))
 804
 805
 806 (provide 'nnshimbun)
 807
 808 ;;; nnshimbun.el ends here