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

   1 ;;; nnshimbun.el --- interfacing with web newspapers -*- coding: junet; -*-
   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-bcklg)
  51 (require 'shimbun)
  52 (require 'message)
  53
  54
  55 ;; Customize variables
  56 (defgroup nnshimbun nil
  57   "Reading Web Newspapers with Gnus."
  58   :group 'gnus)
  59
  60 (defcustom nnshimbun-keep-unparsable-dated-articles t
  61   "*If non-nil, nnshimbun will never delete articles whose NOV date is unparsable."
  62   :group 'nnshimbun
  63   :type 'boolean)
  64
  65
  66 ;; Define baekend
  67 (gnus-declare-backend "nnshimbun" 'address)
  68 (nnoo-declare nnshimbun)
  69
  70 (defvoo nnshimbun-directory (nnheader-concat gnus-directory "shimbun/")
  71   "Where nnshimbun will save its files.")
  72
  73 (defvoo nnshimbun-nov-is-evil nil
  74   "*Non-nil means that nnshimbun will never retrieve NOV headers.")
  75
  76 (defvoo nnshimbun-nov-file-name ".overview")
  77
  78 (defvoo nnshimbun-pre-fetch-article nil
  79   "*Non nil means that nnshimbun fetch unread articles when scanning groups.")
  80
  81 (defvoo nnshimbun-index-range nil
  82   "*Range of indecis to detect new pages.")
  83
  84 ;; set by nnshimbun-possibly-change-group
  85 (defvoo nnshimbun-buffer nil)
  86 (defvoo nnshimbun-current-directory nil)
  87 (defvoo nnshimbun-current-group nil)
  88
  89 ;; set by nnshimbun-open-server
  90 (defvoo nnshimbun-shimbun nil)
  91 (defvoo nnshimbun-server-directory nil)
  92
  93 (defvoo nnshimbun-status-string "")
  94 (defvoo nnshimbun-nov-last-check nil)
  95 (defvoo nnshimbun-nov-buffer-alist nil)
  96 (defvoo nnshimbun-nov-buffer-file-name nil)
  97
  98 (defvoo nnshimbun-keep-backlog 300)
  99 (defvoo nnshimbun-backlog-articles nil)
 100 (defvoo nnshimbun-backlog-hashtb nil)
 101
 102 ;;; backlog
 103 (defmacro nnshimbun-backlog (&rest form)
 104   `(let ((gnus-keep-backlog nnshimbun-keep-backlog)
 105          (gnus-backlog-buffer (format " *nnshimbun backlog %s*"
 106                                       (nnoo-current-server 'nnshimbun)))
 107          (gnus-backlog-articles nnshimbun-backlog-articles)
 108          (gnus-backlog-hashtb nnshimbun-backlog-hashtb))
 109      (unwind-protect
 110          (progn ,@form)
 111        (setq nnshimbun-backlog-articles gnus-backlog-articles
 112              nnshimbun-backlog-hashtb gnus-backlog-hashtb))))
 113 (put 'nnshimbun-backlog 'lisp-indent-function 0)
 114 (put 'nnshimbun-backlog 'edebug-form-spec '(form body))
 115
 116
 117 ;;; Interface Functions
 118 (nnoo-define-basics nnshimbun)
 119
 120 (deffoo nnshimbun-open-server (server &optional defs)
 121   (push (list 'nnshimbun-shimbun
 122               (condition-case err
 123                   (shimbun-open server (luna-make-entity 'shimbun-gnus-mua))
 124                 (error (nnheader-report 'nnshimbun "%s" (error-message-string
 125                                                          err)))))
 126         defs)
 127   ;; Set directory for server working files.
 128   (push (list 'nnshimbun-server-directory
 129               (file-name-as-directory
 130                (expand-file-name server nnshimbun-directory)))
 131         defs)
 132   (nnoo-change-server 'nnshimbun server defs)
 133   (nnshimbun-possibly-change-group nil server)
 134   ;; Make directories.
 135   (unless (file-exists-p nnshimbun-directory)
 136     (ignore-errors (make-directory nnshimbun-directory t)))
 137   (cond
 138    ((not (file-exists-p nnshimbun-directory))
 139     (nnshimbun-close-server)
 140     (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 141                      nnshimbun-directory))
 142    ((not (file-directory-p (file-truename nnshimbun-directory)))
 143     (nnshimbun-close-server)
 144     (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-directory))
 145    (t
 146     (unless (file-exists-p nnshimbun-server-directory)
 147       (ignore-errors (make-directory nnshimbun-server-directory t)))
 148     (cond
 149      ((not (file-exists-p nnshimbun-server-directory))
 150       (nnshimbun-close-server)
 151       (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 152                        nnshimbun-server-directory))
 153      ((not (file-directory-p (file-truename nnshimbun-server-directory)))
 154       (nnshimbun-close-server)
 155       (nnheader-report 'nnshimbun "Not a directory: %s"
 156                        nnshimbun-server-directory))
 157      (t
 158       (nnheader-report 'nnshimbun "Opened server %s using directory %s"
 159                        server nnshimbun-server-directory)
 160       t)))))
 161
 162 (deffoo nnshimbun-close-server (&optional server)
 163   (when (nnshimbun-server-opened server)
 164     (when nnshimbun-shimbun
 165       (shimbun-close nnshimbun-shimbun))
 166     (when (gnus-buffer-live-p nnshimbun-buffer)
 167       (kill-buffer nnshimbun-buffer)))
 168   (nnshimbun-backlog (gnus-backlog-shutdown))
 169   (nnshimbun-save-nov)
 170   (nnoo-close-server 'nnshimbun server)
 171   t)
 172
 173 (eval-and-compile
 174   (let ((Gnus-p
 175          (eval-when-compile
 176            (let ((gnus (locate-library "gnus"))
 177                  ;; Gnus has mailcap.el in the same directory of gnus.el.
 178                  (mailcap (locate-library "mailcap")))
 179              (and gnus mailcap
 180                   (string-equal (file-name-directory gnus)
 181                                 (file-name-directory mailcap)))))))
 182     (if Gnus-p
 183         (progn
 184           (defmacro nnshimbun-mail-header-subject (header)
 185             `(mail-header-subject ,header))
 186           (defmacro nnshimbun-mail-header-from (header)
 187             `(mail-header-from ,header)))
 188       (defmacro nnshimbun-mail-header-subject (header)
 189         `(mime-entity-fetch-field ,header 'Subject))
 190       (defmacro nnshimbun-mail-header-from (header)
 191         `(mime-entity-fetch-field ,header 'From)))))
 192
 193 (defun nnshimbun-make-shimbun-header (header)
 194   (shimbun-make-header
 195    (mail-header-number header)
 196    (nnshimbun-mail-header-subject header)
 197    (nnshimbun-mail-header-from header)
 198    (mail-header-date header)
 199    (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header)))
 200        (mail-header-id header))
 201    (mail-header-references header)
 202    (mail-header-chars header)
 203    (mail-header-lines header)
 204    (let ((xref (mail-header-xref header)))
 205      (if (and xref (string-match "^Xref: " xref))
 206          (substring xref 6)
 207        xref))))
 208
 209 (eval-when-compile
 210   (require 'gnus-sum));; For the macro `gnus-summary-article-header'.
 211
 212 (defun nnshimbun-request-article-1 (article &optional group server to-buffer)
 213   (if (nnshimbun-backlog
 214         (gnus-backlog-request-article
 215          group article (or to-buffer nntp-server-buffer)))
 216       (cons group article)
 217     (let* ((header (with-current-buffer (nnshimbun-open-nov group)
 218                      (and (nnheader-find-nov-line article)
 219                           (nnshimbun-make-shimbun-header
 220                            (nnheader-parse-nov)))))
 221            (original-id (shimbun-header-id header)))
 222       (when header
 223         (with-current-buffer (or to-buffer nntp-server-buffer)
 224           (delete-region (point-min) (point-max))
 225           (shimbun-article nnshimbun-shimbun header)
 226           (when (> (buffer-size) 0)
 227             ;; Kludge! replace a date string in `gnus-newsgroup-data'
 228             ;; based on the newly retrieved article.
 229             (let ((x (gnus-summary-article-header article)))
 230               (when x
 231                 (mail-header-set-date x (shimbun-header-date header))))
 232             (nnshimbun-replace-nov-entry group article header original-id)
 233             (nnshimbun-backlog
 234               (gnus-backlog-enter-article group article (current-buffer)))
 235             (nnheader-report 'nnshimbun "Article %s retrieved"
 236                              (shimbun-header-id header))
 237             (cons group article)))))))
 238
 239 (deffoo nnshimbun-request-article (article &optional group server to-buffer)
 240   (when (nnshimbun-possibly-change-group group server)
 241     (when (stringp article)
 242       (setq article (nnshimbun-search-id group article)))
 243     (if (integerp article)
 244         (nnshimbun-request-article-1 article group server to-buffer)
 245       (nnheader-report 'nnshimbun "Couldn't retrieve article: %s"
 246                        (prin1-to-string article))
 247       nil)))
 248
 249 (deffoo nnshimbun-request-group (group &optional server dont-check)
 250   (let ((file-name-coding-system nnmail-pathname-coding-system)
 251         (pathname-coding-system nnmail-pathname-coding-system))
 252     (cond
 253      ((not (nnshimbun-possibly-change-group group server))
 254       (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
 255      ((not (file-exists-p nnshimbun-current-directory))
 256       (nnheader-report 'nnshimbun "Directory %s does not exist"
 257                        nnshimbun-current-directory))
 258      ((not (file-directory-p nnshimbun-current-directory))
 259       (nnheader-report 'nnshimbun "%s is not a directory"
 260                        nnshimbun-current-directory))
 261      (dont-check
 262       (nnheader-report 'nnshimbun "Group %s selected" group)
 263       t)
 264      (t
 265       (let (beg end lines)
 266         (with-current-buffer (nnshimbun-open-nov group)
 267           (goto-char (point-min))
 268           (setq beg (ignore-errors (read (current-buffer))))
 269           (goto-char (point-max))
 270           (forward-line -1)
 271           (setq end (ignore-errors (read (current-buffer)))
 272                 lines (count-lines (point-min) (point-max))))
 273         (nnheader-report 'nnshimbun "Selected group %s" group)
 274         (nnheader-insert "211 %d %d %d %s\n"
 275                          lines (or beg 0) (or end 0) group))))))
 276
 277 (deffoo nnshimbun-request-scan (&optional group server)
 278   (nnshimbun-possibly-change-group group server)
 279   (nnshimbun-generate-nov-database group))
 280
 281 (deffoo nnshimbun-close-group (group &optional server)
 282   (nnshimbun-write-nov group)
 283   t)
 284
 285 (deffoo nnshimbun-request-list (&optional server)
 286   (with-current-buffer nntp-server-buffer
 287     (delete-region (point-min) (point-max))
 288     (dolist (group (shimbun-groups nnshimbun-shimbun))
 289       (when (nnshimbun-possibly-change-group group server)
 290         (let (beg end)
 291           (with-current-buffer (nnshimbun-open-nov group)
 292             (goto-char (point-min))
 293             (setq beg (ignore-errors (read (current-buffer))))
 294             (goto-char (point-max))
 295             (forward-line -1)
 296             (setq end (ignore-errors (read (current-buffer)))))
 297           (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
 298   t) ; return value
 299
 300 (deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
 301   (when (nnshimbun-possibly-change-group group server)
 302     (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
 303         'nov
 304       (with-current-buffer nntp-server-buffer
 305         (delete-region (point-min) (point-max))
 306         (let (header)
 307           (dolist (art articles)
 308             (if (stringp art)
 309                 (setq art (nnshimbun-search-id group art)))
 310             (if (integerp art)
 311                 (when (setq header
 312                             (with-current-buffer (nnshimbun-open-nov group)
 313                               (and (nnheader-find-nov-line art)
 314                                    (nnheader-parse-nov))))
 315                   (insert (format "220 %d Article retrieved.\n" art))
 316                   (shimbun-header-insert
 317                    nnshimbun-shimbun
 318                    (nnshimbun-make-shimbun-header header))
 319                   (insert ".\n")
 320                   (delete-region (point) (point-max))))))
 321         'header))))
 322
 323 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
 324   (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
 325       nil
 326     (let ((nov (expand-file-name nnshimbun-nov-file-name
 327                                  nnshimbun-current-directory)))
 328       (when (file-exists-p nov)
 329         (save-excursion
 330           (set-buffer nntp-server-buffer)
 331           (erase-buffer)
 332           (nnheader-insert-file-contents nov)
 333           (if (and fetch-old (not (numberp fetch-old)))
 334               t                         ; Don't remove anything.
 335             (nnheader-nov-delete-outside-range
 336              (if fetch-old (max 1 (- (car articles) fetch-old))
 337                (car articles))
 338              (and articles (nth (1- (length articles)) articles)))
 339             t))))))
 340
 341
 342
 343 ;;; Nov Database Operations
 344
 345 (defvar nnshimbun-tmp-string nil
 346   "Internal variable used to just a rest for a temporary string.  The
 347 macro `nnshimbun-string-or' uses it exclusively.")
 348
 349 (defmacro nnshimbun-string-or (&rest strings)
 350   "Return the first element of STRINGS that is a non-blank string.  It
 351 should run fast, especially if two strings are given.  Each string can
 352 also be nil."
 353   (cond ((null strings)
 354          nil)
 355         ((= 1 (length strings))
 356          ;; Return irregularly nil if one blank string is given.
 357          `(unless (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 358             nnshimbun-tmp-string))
 359         ((= 2 (length strings))
 360          ;; Return the second string when the first string is blank.
 361          `(if (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
 362               ,(cadr strings)
 363             nnshimbun-tmp-string))
 364         (t
 365          `(let ((strings (list ,@strings)))
 366             (while strings
 367               (setq strings (if (zerop (length (setq nnshimbun-tmp-string
 368                                                      (car strings))))
 369                                 (cdr strings))))
 370             nnshimbun-tmp-string))))
 371
 372 (defsubst nnshimbun-insert-nov (number header &optional id)
 373   (insert "\n")
 374   (backward-char 1)
 375   (let ((header-id (nnshimbun-string-or (shimbun-header-id header)))
 376         ;; Force `princ' to work in the current buffer.
 377         (standard-output (current-buffer))
 378         (xref (nnshimbun-string-or (shimbun-header-xref header)))
 379         (start (point)))
 380     (and (stringp id)
 381          header-id
 382          (string-equal id header-id)
 383          (setq id nil))
 384     (princ number)
 385     (insert
 386      "\t"
 387      (nnshimbun-string-or (shimbun-header-subject header) "(none)") "\t"
 388      (nnshimbun-string-or (shimbun-header-from header) "(nobody)") "\t"
 389      (nnshimbun-string-or (shimbun-header-date header) (message-make-date))
 390      "\t"
 391      (or header-id (nnmail-message-id)) "\t"
 392      (or (shimbun-header-references header) "") "\t")
 393     (princ (or (shimbun-header-chars header) 0))
 394     (insert "\t")
 395     (princ (or (shimbun-header-lines header) 0))
 396     (insert "\t")
 397     (if xref
 398         (progn
 399           (insert "Xref: " xref "\t")
 400           (when id
 401             (insert "X-Nnshimbun-Id: " id "\t")))
 402       (when id
 403         (insert "\tX-Nnshimbun-Id: " id "\t")))
 404     ;; Replace newlines with spaces in the current NOV line.
 405     (while (progn
 406              (forward-line 0)
 407              (> (point) start))
 408       (backward-delete-char 1)
 409       (insert " "))
 410     (forward-line 1)))
 411
 412 (defun nnshimbun-generate-nov-database (group)
 413   (nnshimbun-possibly-change-group group)
 414   (with-current-buffer (nnshimbun-open-nov group)
 415     (goto-char (point-max))
 416     (forward-line -1)
 417     (let ((i (or (ignore-errors (read (current-buffer))) 0)))
 418       (dolist (header (shimbun-headers
 419                        nnshimbun-shimbun
 420                        (or (gnus-group-find-parameter
 421                             (concat "nnshimbun+"
 422                                     (nnoo-current-server 'nnshimbun)
 423                                     ":" group)
 424                             'nnshimbun-index-range)
 425                            nnshimbun-index-range)))
 426         (unless (nnshimbun-search-id group (shimbun-header-id header))
 427           (goto-char (point-max))
 428           (nnshimbun-insert-nov (setq i (1+ i)) header)
 429           (when nnshimbun-pre-fetch-article
 430             (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))
 431   (nnshimbun-write-nov group)))
 432
 433 (defun nnshimbun-replace-nov-entry (group article header &optional id)
 434   (with-current-buffer (nnshimbun-open-nov group)
 435     (when (nnheader-find-nov-line article)
 436       (delete-region (point) (progn (forward-line 1) (point)))
 437       (nnshimbun-insert-nov article header id))))
 438
 439 (defun nnshimbun-search-id (group id &optional nov)
 440   (with-current-buffer (nnshimbun-open-nov group)
 441     (goto-char (point-min))
 442     (let (found)
 443       (while (and (not found)
 444                   (search-forward id nil t)) ; We find the ID.
 445         ;; And the id is in the fourth field.
 446         (if (not (and (search-backward "\t" nil t 4)
 447                       (not (search-backward "\t" (gnus-point-at-bol) t))))
 448             (forward-line 1)
 449           (forward-line 0)
 450           (setq found t)))
 451       (unless found
 452         (goto-char (point-min))
 453         (setq id (concat "X-Nnshimbun-Id: " id))
 454         (while (and (not found)
 455                     (search-forward id nil t))
 456           (if (not (search-backward "\t" (gnus-point-at-bol) t 8))
 457               (forward-line 1)
 458             (forward-line 0)
 459             (setq found t))))
 460       (when found
 461         (if nov
 462             (nnheader-parse-nov)
 463           ;; We return the article number.
 464           (ignore-errors (read (current-buffer))))))))
 465
 466 (defun nnshimbun-open-nov (group)
 467   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 468     (if (buffer-live-p buffer)
 469         buffer
 470       (setq buffer (gnus-get-buffer-create
 471                     (format " *nnshimbun overview %s %s*"
 472                             (nnoo-current-server 'nnshimbun) group)))
 473       (save-excursion
 474         (set-buffer buffer)
 475         (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
 476              (expand-file-name
 477               nnshimbun-nov-file-name
 478               (nnmail-group-pathname group nnshimbun-server-directory)))
 479         (erase-buffer)
 480         (when (file-exists-p nnshimbun-nov-buffer-file-name)
 481           (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
 482         (set-buffer-modified-p nil))
 483       (push (cons group buffer) nnshimbun-nov-buffer-alist)
 484       buffer)))
 485
 486 (defun nnshimbun-write-nov (group)
 487   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 488     (when (buffer-live-p buffer)
 489       (save-excursion
 490         (set-buffer buffer)
 491         (buffer-modified-p)
 492         (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 493                              nil 'nomesg)))))
 494
 495 (defun nnshimbun-save-nov ()
 496   (save-excursion
 497     (while nnshimbun-nov-buffer-alist
 498       (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
 499         (set-buffer (cdar nnshimbun-nov-buffer-alist))
 500         (when (buffer-modified-p)
 501           (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
 502                                nil 'nomesg))
 503         (set-buffer-modified-p nil)
 504         (kill-buffer (current-buffer)))
 505       (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
 506
 507 (deffoo nnshimbun-request-expire-articles (articles group
 508                                                     &optional server force)
 509   "Do expiration for the specified ARTICLES in the nnshimbun GROUP.
 510 Notice that nnshimbun does not actually delete any articles, it just
 511 delete the corresponding entries in the NOV database locally.  The
 512 expiration will be performed only when the current SERVER is specified
 513 and the NOV is open.  The optional fourth argument FORCE is ignored."
 514   (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
 515     (if (and server
 516              ;; Don't use 'string-equal' in the following.
 517              (equal server (nnoo-current-server 'nnshimbun))
 518              (buffer-live-p buffer))
 519         (let* ((expirable (copy-sequence articles))
 520                (name (concat "nnshimbun+" server ":" group))
 521                ;; If the group's parameter `expiry-wait' is non-nil,
 522                ;; `nnmail-expiry-wait' is bound to that value, and
 523                ;; `nnmail-expiry-wait-function' is bound to nil.
 524                ;; See the source code of `gnus-summary-expire-articles'.
 525                ;; Prefer the shimbun's default to `nnmail-expiry-wait'
 526                ;; only when the group's parameter is nil.
 527                (nnmail-expiry-wait
 528                 (if (gnus-group-find-parameter name 'expiry-wait)
 529                     nnmail-expiry-wait
 530                   (or (shimbun-article-expiration-days nnshimbun-shimbun)
 531                       nnmail-expiry-wait)))
 532                article end time)
 533           (save-excursion
 534             (set-buffer buffer)
 535             (while expirable
 536               (setq article (pop expirable))
 537               (when (and (nnheader-find-nov-line article)
 538                          (setq end (line-end-position))
 539                          (not (= (point-max) (1+ end))))
 540                 (setq time (and (search-forward "\t" end t)
 541                                 (search-forward "\t" end t)
 542                                 (search-forward "\t" end t)
 543                                 (parse-time-string
 544                                  (buffer-substring
 545                                   (point)
 546                                   (if (search-forward "\t" end t)
 547                                       (1- (point))
 548                                     end)))))
 549                 (when (and (or (setq time (condition-case nil
 550                                               (apply 'encode-time time)
 551                                             (error nil)))
 552                                ;; Inhibit expiration if there's no parsable
 553                                ;; date and the following option is non-nil.
 554                                (not nnshimbun-keep-unparsable-dated-articles))
 555                            (nnmail-expired-article-p name time nil))
 556                   (beginning-of-line)
 557                   (delete-region (point) (1+ end))
 558                   (setq articles (delq article articles)))))
 559             (when (buffer-modified-p)
 560               (nnmail-write-region 1 (point-max)
 561                                    nnshimbun-nov-buffer-file-name
 562                                    nil 'nomesg)
 563               (set-buffer-modified-p nil))
 564             articles))
 565       t)))
 566
 567
 568
 569 ;;; Server Initialize
 570
 571 (defun nnshimbun-possibly-change-group (group &optional server)
 572   (when server
 573     (unless (nnshimbun-server-opened server)
 574       (nnshimbun-open-server server)))
 575   (unless (gnus-buffer-live-p nnshimbun-buffer)
 576     (setq nnshimbun-buffer
 577           (save-excursion
 578             (nnheader-set-temp-buffer
 579              (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
 580   (if (not group)
 581       t
 582     (condition-case err
 583         (shimbun-open-group nnshimbun-shimbun group)
 584       (error (nnheader-report 'nnshimbun "%s" (error-message-string err))))
 585     (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
 586           (file-name-coding-system nnmail-pathname-coding-system)
 587           (pathname-coding-system nnmail-pathname-coding-system))
 588       (unless (equal pathname nnshimbun-current-directory)
 589         (setq nnshimbun-current-directory pathname
 590               nnshimbun-current-group group))
 591       (unless (file-exists-p nnshimbun-current-directory)
 592         (ignore-errors (make-directory nnshimbun-current-directory t)))
 593       (cond
 594        ((not (file-exists-p nnshimbun-current-directory))
 595         (nnheader-report 'nnshimbun "Couldn't create directory: %s"
 596                          nnshimbun-current-directory))
 597        ((not (file-directory-p (file-truename nnshimbun-current-directory)))
 598         (nnheader-report 'nnshimbun "Not a directory: %s"
 599                          nnshimbun-current-directory))
 600        (t t)))))
 601
 602
 603
 604 ;;; shimbun-gnus-mua
 605 (luna-define-class shimbun-gnus-mua (shimbun-mua) ())
 606
 607 (luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id)
 608   (nnshimbun-search-id
 609    (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
 610    id))
 611
 612
 613
 614 ;;; Command to create nnshimbun group
 615
 616 (defvar nnshimbun-server-history nil)
 617
 618 ;;;###autoload
 619 (defun gnus-group-make-shimbun-group ()
 620   "Create a nnshimbun group."
 621   (interactive)
 622   (let* ((minibuffer-setup-hook
 623           (append minibuffer-setup-hook '(beginning-of-line)))
 624          (alist
 625           (apply 'nconc
 626                  (mapcar
 627                   (lambda (d)
 628                     (and (stringp d)
 629                          (file-directory-p d)
 630                          (delq nil
 631                                (mapcar
 632                                 (lambda (f)
 633                                   (and (string-match "^sb-\\(.*\\)\\.el$" f)
 634                                        (list (match-string 1 f))))
 635                                 (directory-files d)))))
 636                   load-path)))
 637          (server (completing-read
 638                   "Shimbun address: "
 639                   alist nil t
 640                   (or (car nnshimbun-server-history)
 641                       (caar alist))
 642                   'nnshimbun-server-history))
 643          (groups)
 644          (nnshimbun-pre-fetch-article))
 645     (require (intern (concat "sb-" server)))
 646     (when (setq groups (intern-soft (concat "shimbun-" server "-groups")))
 647       (gnus-group-make-group
 648        (completing-read "Group name: "
 649                         (mapcar 'list (symbol-value groups))
 650                         nil t nil)
 651        (list 'nnshimbun server)))))
 652
 653
 654 (provide 'nnshimbun)
 655 ;;; nnshimbun.el ends here.