1 ;;; nnshimbun.el --- interfacing with web newspapers
3 ;; Copyright (C) 2000,2001,2002 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
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>
11 ;; This file is a part of Semi-Gnus.
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)
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.
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.
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.
34 ;; http://emacs-w3m.namazu.org/
35 ;; http://ei5nazha.yz.yamagata-u.ac.jp/~aito/w3m/
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.
41 ;; (autoload 'gnus-group-make-shimbun-group "nnshimbun" nil t)
46 (eval-when-compile (require 'cl))
56 ;; Customize variables
57 (defgroup nnshimbun nil
58 "Reading Web Newspapers with Gnus."
61 (defvar nnshimbun-group-parameters-custom
64 (list :inline t :format "%v"
65 (const :format "" index-range)
66 (choice :tag "Index range"
70 (integer :tag "days")))
71 (list :inline t :format "%v"
72 (const :format "" prefetch-articles)
73 (choice :tag "Prefetch articles"
77 (list :inline t :format "%v"
78 (const :format "" encapsulate-images)
79 (choice :tag "Encapsulate article"
83 (list :inline t :format "%v"
84 (const :format "" expiry-wait)
85 (choice :tag "Expire wait"
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.")
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:
103 ;; '(index-range all prefetch-articles off encapsulate-images on
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."
111 (or (gnus-group-find-parameter name 'nnshimbun-group-parameters t)
113 (and (boundp 'nnshimbun-group-parameters-alist)
114 (symbol-value 'nnshimbun-group-parameters-alist))
115 (function string-match))))))
117 (gnus-define-group-parameter
118 nnshimbun-group-parameters
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:
130 '(\"^nnshimbun\\\\+asahi:\" index-range all prefetch-articles off
131 encapsulate-images on expiry-wait 6)
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.
138 `prefetch-articles' specifies whether to pre-fetch the unread articles
139 when scanning the group.
141 `encapsulate-images' specifies whether inline images in the shimbun
142 article are encapsulated.
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.
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.
159 `Prefetch articles' specifies whether to pre-fetch the unread articles
160 when scanning the group.
162 `Encapsulate article' specifies whether inline images in the shimbun
163 article are encapsulated.
165 `Expire wait' is similar to the generic group parameter `expiry-wait',
166 but it has a preference.")
168 (defcustom nnshimbun-keep-unparsable-dated-articles t
169 "*If non-nil, nnshimbun will never delete articles whose NOV date is unparsable."
175 (gnus-declare-backend "nnshimbun" 'address)
176 (nnoo-declare nnshimbun)
178 (defvoo nnshimbun-directory (nnheader-concat gnus-directory "shimbun/")
179 "Where nnshimbun will save its files.")
181 (defvoo nnshimbun-nov-is-evil nil
182 "*Non-nil means that nnshimbun will never retrieve NOV headers.")
184 (defvoo nnshimbun-nov-file-name ".overview")
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.")
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.")
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.")
203 ;; set by nnshimbun-possibly-change-group
204 (defvoo nnshimbun-buffer nil)
205 (defvoo nnshimbun-current-directory nil)
206 (defvoo nnshimbun-current-group nil)
208 ;; set by nnshimbun-open-server
209 (defvoo nnshimbun-shimbun nil)
210 (defvoo nnshimbun-server-directory nil)
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)
217 (defvoo nnshimbun-keep-backlog 300)
218 (defvoo nnshimbun-backlog-articles nil)
219 (defvoo nnshimbun-backlog-hashtb nil)
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))
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))
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
243 `(concat "nnshimbun+" (nnoo-current-server 'nnshimbun)
245 (cond ((eq 'index-range (eval symbol))
246 `(or (plist-get (nnshimbun-find-group-parameters ,name)
248 nnshimbun-index-range))
249 ((eq 'prefetch-articles (eval symbol))
250 `(let ((val (or (plist-get (nnshimbun-find-group-parameters ,name)
252 nnshimbun-pre-fetch-article)))
256 ((eq 'encapsulate-images (eval symbol))
257 `(let ((val (or (plist-get (nnshimbun-find-group-parameters ,name)
259 nnshimbun-encapsulate-images)))
263 ((eq 'expiry-wait (eval symbol))
265 `(or (plist-get (nnshimbun-find-group-parameters ,group)
267 (gnus-group-find-parameter ,group 'expiry-wait))
269 (or (plist-get (nnshimbun-find-group-parameters name)
271 (gnus-group-find-parameter name 'expiry-wait)))))
273 `(plist-get (nnshimbun-find-group-parameters ,name) ,symbol)))))
276 ;;; Interface Functions
277 (nnoo-define-basics nnshimbun)
279 (deffoo nnshimbun-open-server (server &optional defs)
280 (push (list 'nnshimbun-shimbun
282 (shimbun-open server (luna-make-entity 'shimbun-gnus-mua))
283 (error (nnheader-report 'nnshimbun "%s" (error-message-string
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)))
291 (nnoo-change-server 'nnshimbun server defs)
292 (nnshimbun-possibly-change-group nil server)
294 (unless (file-exists-p nnshimbun-directory)
295 (ignore-errors (make-directory nnshimbun-directory t)))
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))
305 (unless (file-exists-p nnshimbun-server-directory)
306 (ignore-errors (make-directory nnshimbun-server-directory t)))
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))
317 (nnheader-report 'nnshimbun "Opened server %s using directory %s"
318 server nnshimbun-server-directory)
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))
329 (nnoo-close-server 'nnshimbun server)
335 (let ((gnus (locate-library "gnus")))
337 ;; Gnus has mailcap.el in the same directory of gnus.el.
338 (file-exists-p (expand-file-name
340 (file-name-directory gnus))))))))
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)))))
352 (defun nnshimbun-make-shimbun-header (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))
369 (require 'gnus-sum));; For the macro `gnus-summary-article-header'.
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)))
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)))
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)))
392 (mail-header-set-date x (shimbun-header-date header))))
393 (nnshimbun-replace-nov-entry group article header original-id)
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)))))))
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))))
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)))))
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))
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))
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))
430 (nnheader-report 'nnshimbun "Group %s selected" group)
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))
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))))))
445 (deffoo nnshimbun-request-scan (&optional group server)
446 (nnshimbun-possibly-change-group group server)
447 (nnshimbun-generate-nov-database group))
449 (deffoo nnshimbun-close-group (group &optional server)
450 (nnshimbun-write-nov group)
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)
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))
464 (setq end (ignore-errors (read (current-buffer)))))
465 (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
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)
472 (with-current-buffer nntp-server-buffer
473 (delete-region (point-min) (point-max))
475 (dolist (art articles)
477 (setq art (nnshimbun-search-id group art)))
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
486 (nnshimbun-make-shimbun-header header))
488 (delete-region (point) (point-max))))))
491 (defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
492 (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
494 (let ((nov (expand-file-name nnshimbun-nov-file-name
495 nnshimbun-current-directory)))
496 (when (file-exists-p nov)
498 (set-buffer nntp-server-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))
506 (nth (1- (length articles)) articles))
511 ;;; Nov Database Operations
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.")
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
521 (cond ((null strings)
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))))
531 nnshimbun-tmp-string))
533 `(let ((strings (list ,@strings)))
535 (setq strings (if (zerop (length (setq nnshimbun-tmp-string
538 nnshimbun-tmp-string))))
540 (defsubst nnshimbun-insert-nov (number header &optional id)
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)))
550 (string-equal id header-id)
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))
559 (or header-id (nnmail-message-id)) "\t"
560 (or (shimbun-header-references header) "") "\t")
561 (princ (or (shimbun-header-chars header) 0))
563 (princ (or (shimbun-header-lines header) 0))
567 (insert "Xref: " xref "\t")
569 (insert "X-Nnshimbun-Id: " id "\t")))
571 (insert "\tX-Nnshimbun-Id: " id "\t")))
572 ;; Replace newlines with spaces in the current NOV line.
576 (backward-delete-char 1)
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))
585 (let* ((i (or (ignore-errors (read (current-buffer))) 0))
586 (name (concat "nnshimbun+" (nnoo-current-server 'nnshimbun)
588 (pre-fetch (nnshimbun-find-parameter name 'prefetch-articles t)))
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)
597 (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))
598 (nnshimbun-write-nov group)))
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))))
606 (defun nnshimbun-search-id (group id &optional nov)
607 (with-current-buffer (nnshimbun-open-nov group)
608 (goto-char (point-min))
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))))
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))
630 ;; We return the article number.
631 (ignore-errors (read (current-buffer))))))))
633 (defun nnshimbun-open-nov (group)
634 (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
635 (if (buffer-live-p buffer)
637 (setq buffer (gnus-get-buffer-create
638 (format " *nnshimbun overview %s %s*"
639 (nnoo-current-server 'nnshimbun) group)))
642 (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
644 nnshimbun-nov-file-name
645 (nnmail-group-pathname group nnshimbun-server-directory)))
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)
653 (defun nnshimbun-write-nov (group)
654 (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
655 (when (buffer-live-p buffer)
658 (and (> (buffer-size) 0)
660 (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
663 (defun nnshimbun-save-nov ()
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)
670 (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
672 (kill-buffer (current-buffer)))
673 (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
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))))
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
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
703 nnmail-expiry-wait-function))
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)
718 (if (search-forward "\t" end t)
721 (when (cond ((setq time (condition-case nil
722 (apply 'encode-time time)
724 (nnmail-expired-article-p name time nil))
726 ;; Inhibit expiration if there's no parsable
727 ;; date and the following option is non-nil.
728 (not nnshimbun-keep-unparsable-dated-articles)))
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
736 (set-buffer-modified-p nil))
742 ;;; Server Initialize
744 (defun nnshimbun-possibly-change-group (group &optional server)
746 (unless (nnshimbun-server-opened server)
747 (nnshimbun-open-server server)))
748 (unless (gnus-buffer-live-p nnshimbun-buffer)
749 (setq nnshimbun-buffer
751 (nnheader-set-temp-buffer
752 (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
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)))
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))
778 (luna-define-class shimbun-gnus-mua (shimbun-mua) ())
780 (luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id)
782 (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
787 ;;; Command to create nnshimbun group
789 (defvar nnshimbun-server-history nil)
792 (defun gnus-group-make-shimbun-group ()
793 "Create a nnshimbun group."
795 (let* ((minibuffer-setup-hook
796 (append minibuffer-setup-hook '(beginning-of-line)))
806 (and (string-match "^sb-\\(.*\\)\\.el$" f)
807 (list (match-string 1 f))))
808 (directory-files d)))))
810 (server (completing-read
813 (or (car nnshimbun-server-history)
815 'nnshimbun-server-history))
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"))))
827 ;;; nnshimbun.el ends here