-;;; nnshimbun.el --- interfacing with web newspapers -*- coding: junet; -*-
+;;; nnshimbun.el --- interfacing with web newspapers
+
+;; Copyright (C) 2000,2001,2002 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.org>,
;; Akihiro Arisawa <ari@atesoft.advantest.co.jp>,
;; Yuuichi Teranishi <teranisi@gohome.org>
;; Keywords: news
-;;; Copyright:
-
;; This file is a part of Semi-Gnus.
;; This program is free software; you can redistribute it and/or modify
;;; Commentary:
;; Gnus (or gnus) backend to read newspapers on the World Wide Web.
-;; This module requires the Emacs-W3M and the external command W3M.
+;; This module requires the emacs-w3m and the external command w3m.
;; Visit the following pages for more information.
;;
-;; http://namazu.org/~tsuchiya/emacs-w3m/
-;; http://ei5nazha.yz.yamagata-u.ac.jp/~aito/w3m/
+;; http://emacs-w3m.namazu.org/
+;; http://w3m.sourceforge.net/
;; If you would like to use this module in Gnus (not T-gnus), put this
-;; file into the lisp/ directory in the Gnus source tree and run
-;; `make install'. And then, copy the function definition of
-;; `gnus-group-make-shimbun-group' from the file gnus-group.el of
-;; T-gnus to somewhere else, for example .gnus file as follows:
+;; file into the lisp/ directory in the Gnus source tree and run `make
+;; install'. And then, put the following expression into your ~/.gnus.
;;
-;;(eval-after-load "gnus-group"
-;; '(if (not (fboundp 'gnus-group-make-shimbun-group))
-;; (defun gnus-group-make-shimbun-group ()
-;; "Create a nnshimbun group."
-;; [...a function definition...])))
+;; (autoload 'gnus-group-make-shimbun-group "nnshimbun" nil t)
-;;; Definitions:
-(gnus-declare-backend "nnshimbun" 'address)
+;;; Definitions:
(eval-when-compile (require 'cl))
-
+(require 'nnoo)
(require 'nnheader)
(require 'nnmail)
-(require 'nnoo)
(require 'gnus-bcklg)
(require 'shimbun)
+;; Customize variables
+(defgroup nnshimbun nil
+ "Reading Web Newspapers with Gnus."
+ :group 'gnus)
+
+(defvar nnshimbun-group-parameters-custom
+ '(list :format "%v"
+ (checklist :inline t
+ (list :inline t :format "%v"
+ (const :format "" index-range)
+ (choice :tag "Index range"
+ :value all
+ (const all)
+ (const last)
+ (integer :tag "days")))
+ (list :inline t :format "%v"
+ (const :format "" prefetch-articles)
+ (choice :tag "Prefetch articles"
+ :value off
+ (const on)
+ (const off)))
+ (list :inline t :format "%v"
+ (const :format "" encapsulate-images)
+ (choice :tag "Encapsulate article"
+ :value on
+ (const on)
+ (const off)))
+ (list :inline t :format "%v"
+ (const :format "" expiry-wait)
+ (choice :tag "Expire wait"
+ :value never
+ (const never)
+ (const immediate)
+ (number :tag "days"))))
+ (repeat :inline t :tag "Others"
+ (list :inline t :format "%v"
+ (symbol :tag "Keyword")
+ (sexp :tag "Value"))))
+ "A type definition for customizing the nnshimbun group parameters.")
+
+;; The following definition provides the group parameter
+;; `nnshimbun-group-parameters', the user option
+;; `nnshimbun-group-parameters-alist' and the function
+;; `nnshimbun-find-group-parameters'.
+;; The group parameter `nnshimbun-group-parameters' will have a
+;; property list like the following:
+;;
+;; '(index-range all prefetch-articles off encapsulate-images on
+;; expiry-wait 6)
+
+(unless (fboundp 'gnus-define-group-parameter)
+ (defmacro gnus-define-group-parameter (&rest args) nil)
+ (defun nnshimbun-find-group-parameters (name)
+ "Return a nnshimbun GROUP's group parameters."
+ (when name
+ (or (gnus-group-find-parameter name 'nnshimbun-group-parameters t)
+ (assoc-default name
+ (and (boundp 'nnshimbun-group-parameters-alist)
+ (symbol-value 'nnshimbun-group-parameters-alist))
+ (function string-match))))))
+
+(gnus-define-group-parameter
+ nnshimbun-group-parameters
+ :type list
+ :function nnshimbun-find-group-parameters
+ :function-document "\
+Return a nnshimbun GROUP's group parameters."
+ :variable nnshimbun-group-parameters-alist
+ :variable-default nil
+ :variable-document "\
+Alist of nnshimbun group parameters. Each element should be a cons of
+a group name regexp and a plist which consists of a keyword and a value
+pairs like the following:
+
+'(\"^nnshimbun\\\\+asahi:\" index-range all prefetch-articles off
+ encapsulate-images on expiry-wait 6)
+
+`index-range' specifies a range of header indices as described below:
+ all: Retrieve all header indices.
+ last: Retrieve the last header index.
+integer N: Retrieve N pages of header indices.
+
+`prefetch-articles' specifies whether to pre-fetch the unread articles
+when scanning the group.
+
+`encapsulate-images' specifies whether inline images in the shimbun
+article are encapsulated.
+
+`expiry-wait' is similar to the generic group parameter `expiry-wait',
+but it has a preference."
+ :variable-group nnshimbun
+ :variable-type `(repeat (cons :format "%v" (regexp :tag "Group name regexp"
+ :value "^nnshimbun\\+")
+ ,nnshimbun-group-parameters-custom))
+ :parameter-type nnshimbun-group-parameters-custom
+ :parameter-document "\
+Group parameters for the nnshimbun group.
+
+`Index range' specifies a range of header indices as described below:
+ all: Retrieve all header indices.
+ last: Retrieve the last header index.
+integer N: Retrieve N pages of header indices.
+
+`Prefetch articles' specifies whether to pre-fetch the unread articles
+when scanning the group.
+
+`Encapsulate article' specifies whether inline images in the shimbun
+article are encapsulated.
+
+`Expire wait' is similar to the generic group parameter `expiry-wait',
+but it has a preference.")
+
+(defcustom nnshimbun-keep-unparsable-dated-articles t "\
+*If non-nil, nnshimbun will never delete articles whose NOV date is unparsable."
+ :group 'nnshimbun
+ :type 'boolean)
+
+
+;; Define backend
+(gnus-declare-backend "nnshimbun" 'address)
(nnoo-declare nnshimbun)
(defvoo nnshimbun-directory (nnheader-concat gnus-directory "shimbun/")
(defvoo nnshimbun-nov-file-name ".overview")
-(defvoo nnshimbun-pre-fetch-article nil
- "*Non nil means that nnshimbun fetch unread articles when scanning groups.")
+(defvoo nnshimbun-pre-fetch-article 'off
+ "*If it is neither `off' nor nil, nnshimbun fetch unread articles when
+scanning groups. Note that this variable has just a default value for
+all the nnshimbun groups. You can specify the nnshimbun group
+parameter `prefecth-articles' for each nnshimbun group.")
+
+(defvoo nnshimbun-encapsulate-images shimbun-encapsulate-images
+ "*If it is neither `off' nor nil, inline images will be encapsulated in
+the articles. Note that this variable has just a default value for
+all the nnshimbun groups. You can specify the nnshimbun group
+parameter `encapsulate-images' for each nnshimbun group.")
-(defvoo nnshimbun-use-entire-index t
- "*Nil means that nnshimbun check the last index of articles.")
+(defvoo nnshimbun-index-range nil
+ "*Range of indices to detect new pages. Note that this variable has
+just a default value for all the nnshimbun groups. You can specify
+the nnshimbun group parameter `index-range' for each nnshimbun group.")
-;; set by nnshimbun-possibly-change-group
-(defvoo nnshimbun-buffer nil)
-(defvoo nnshimbun-current-directory nil)
-(defvoo nnshimbun-current-group nil)
;; set by nnshimbun-open-server
(defvoo nnshimbun-shimbun nil)
-(defvoo nnshimbun-server-directory nil)
(defvoo nnshimbun-status-string "")
-(defvoo nnshimbun-nov-last-check nil)
-(defvoo nnshimbun-nov-buffer-alist nil)
-(defvoo nnshimbun-nov-buffer-file-name nil)
-
(defvoo nnshimbun-keep-backlog 300)
(defvoo nnshimbun-backlog-articles nil)
(defvoo nnshimbun-backlog-hashtb nil)
+
;;; backlog
+(defmacro nnshimbun-current-server ()
+ '(nnoo-current-server 'nnshimbun))
+
+(defmacro nnshimbun-server-directory (&optional server)
+ `(nnmail-group-pathname ,(or server '(nnshimbun-current-server))
+ nnshimbun-directory))
+
+(defmacro nnshimbun-current-group ()
+ '(shimbun-current-group-internal nnshimbun-shimbun))
+
+(defmacro nnshimbun-current-directory (&optional group)
+ `(nnmail-group-pathname ,(or group '(nnshimbun-current-group))
+ (nnshimbun-server-directory)))
+
(defmacro nnshimbun-backlog (&rest form)
`(let ((gnus-keep-backlog nnshimbun-keep-backlog)
- (gnus-backlog-buffer (format " *nnshimbun backlog %s*" (nnoo-current-server 'nnshimbun)))
+ (gnus-backlog-buffer
+ (format " *nnshimbun backlog %s*" (nnshimbun-current-server)))
(gnus-backlog-articles nnshimbun-backlog-articles)
(gnus-backlog-hashtb nnshimbun-backlog-hashtb))
(unwind-protect
(setq nnshimbun-backlog-articles gnus-backlog-articles
nnshimbun-backlog-hashtb gnus-backlog-hashtb))))
(put 'nnshimbun-backlog 'lisp-indent-function 0)
-(put 'nnshimbun-backlog 'edebug-form-spec '(form body))
+(put 'nnshimbun-backlog 'edebug-form-spec t)
+
+
+;;; Group parameter
+(defmacro nnshimbun-find-parameter (group symbol &optional full-name-p)
+ "Return the value of a nnshimbun group parameter for GROUP which is
+associated with SYMBOL. If FULL-NAME-P is non-nil, it treats that
+GROUP has a full name."
+ (let ((name (if full-name-p
+ group
+ `(concat "nnshimbun+" (nnshimbun-current-server) ":" ,group))))
+ (cond ((eq 'index-range (eval symbol))
+ `(or (plist-get (nnshimbun-find-group-parameters ,name)
+ 'index-range)
+ nnshimbun-index-range))
+ ((eq 'prefetch-articles (eval symbol))
+ `(let ((val (or (plist-get (nnshimbun-find-group-parameters ,name)
+ 'prefetch-articles)
+ nnshimbun-pre-fetch-article)))
+ (if (eq 'off val)
+ nil
+ val)))
+ ((eq 'encapsulate-images (eval symbol))
+ `(let ((val (or (plist-get (nnshimbun-find-group-parameters ,name)
+ 'encapsulate-images)
+ nnshimbun-encapsulate-images)))
+ (if (eq 'off val)
+ nil
+ val)))
+ ((eq 'expiry-wait (eval symbol))
+ (if full-name-p
+ `(or (plist-get (nnshimbun-find-group-parameters ,group)
+ 'expiry-wait)
+ (gnus-group-find-parameter ,group 'expiry-wait))
+ `(let ((name ,name))
+ (or (plist-get (nnshimbun-find-group-parameters name)
+ 'expiry-wait)
+ (gnus-group-find-parameter name 'expiry-wait)))))
+ (t
+ `(plist-get (nnshimbun-find-group-parameters ,name) ,symbol)))))
;;; Interface Functions
(nnoo-define-basics nnshimbun)
+(defun nnshimbun-possibly-change-group (group &optional server)
+ (when (if server
+ (nnshimbun-open-server server)
+ nnshimbun-shimbun)
+ (or (not group)
+ (when (condition-case err
+ (shimbun-open-group nnshimbun-shimbun group)
+ (error
+ (nnheader-report 'nnshimbun "%s" (error-message-string err))))
+ (let ((file-name-coding-system nnmail-pathname-coding-system)
+ (pathname-coding-system nnmail-pathname-coding-system)
+ (dir (nnshimbun-current-directory group)))
+ (or (file-directory-p dir)
+ (ignore-errors
+ (make-directory dir)
+ (file-directory-p dir))
+ (nnheader-report 'nnshimbun
+ (if (file-exists-p dir)
+ "Not a directory: %s"
+ "Couldn't create directory: %s")
+ dir)))))))
+
(deffoo nnshimbun-open-server (server &optional defs)
- (push (list 'nnshimbun-shimbun
- (condition-case err
- (shimbun-open server (luna-make-entity 'shimbun-gnus-mua))
- (error (nnheader-report 'nnshimbun "%s" (error-message-string err)))))
- defs)
- ;; Set directory for server working files.
- (push (list 'nnshimbun-server-directory
- (file-name-as-directory
- (expand-file-name server nnshimbun-directory)))
- defs)
- (nnoo-change-server 'nnshimbun server defs)
- (nnshimbun-possibly-change-group nil server)
- ;; Make directories.
- (unless (file-exists-p nnshimbun-directory)
- (ignore-errors (make-directory nnshimbun-directory t)))
- (cond
- ((not (file-exists-p nnshimbun-directory))
- (nnshimbun-close-server)
- (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-directory))
- ((not (file-directory-p (file-truename nnshimbun-directory)))
- (nnshimbun-close-server)
- (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-directory))
- (t
- (unless (file-exists-p nnshimbun-server-directory)
- (ignore-errors (make-directory nnshimbun-server-directory t)))
- (cond
- ((not (file-exists-p nnshimbun-server-directory))
- (nnshimbun-close-server)
- (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-server-directory))
- ((not (file-directory-p (file-truename nnshimbun-server-directory)))
- (nnshimbun-close-server)
- (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-server-directory))
- (t
- (nnheader-report 'nnshimbun "Opened server %s using directory %s"
- server nnshimbun-server-directory)
- t)))))
+ (or (nnshimbun-server-opened server)
+ (let ((file-name-coding-system nnmail-pathname-coding-system)
+ (pathname-coding-system nnmail-pathname-coding-system)
+ (shimbun))
+ (when (condition-case err
+ (setq shimbun
+ (shimbun-open server
+ (luna-make-entity 'shimbun-gnus-mua)))
+ (error
+ (nnheader-report 'nnshimbun "%s" (error-message-string err))))
+ (nnoo-change-server 'nnshimbun server
+ (cons (list 'nnshimbun-shimbun shimbun) defs))
+ (when (or (file-directory-p nnshimbun-directory)
+ (ignore-errors
+ (make-directory nnshimbun-directory)
+ (file-directory-p nnshimbun-directory))
+ (progn
+ (nnshimbun-close-server)
+ (nnheader-report 'nnshimbun
+ (if (file-exists-p nnshimbun-directory)
+ "Not a directory: %s"
+ "Couldn't create directory: %s")
+ nnshimbun-directory)))
+ (let ((dir (nnshimbun-server-directory server)))
+ (when (or (file-directory-p dir)
+ (ignore-errors
+ (make-directory dir)
+ (file-directory-p dir))
+ (progn
+ (nnshimbun-close-server)
+ (nnheader-report 'nnshimbun
+ (if (file-exists-p dir)
+ "Not a directory: %s"
+ "Couldn't create directory: %s")
+ dir)))
+ (nnheader-report 'nnshimbun
+ "Opened server %s using directory %s"
+ server dir)
+ t)))))))
(deffoo nnshimbun-close-server (&optional server)
- (shimbun-close nnshimbun-shimbun)
- (and (nnshimbun-server-opened server)
- (gnus-buffer-live-p nnshimbun-buffer)
- (kill-buffer nnshimbun-buffer))
+ (when (nnshimbun-server-opened server)
+ (when nnshimbun-shimbun
+ (dolist (group (shimbun-groups nnshimbun-shimbun))
+ (nnshimbun-write-nov group t))
+ (shimbun-close nnshimbun-shimbun)))
(nnshimbun-backlog (gnus-backlog-shutdown))
- (nnshimbun-save-nov)
(nnoo-close-server 'nnshimbun server)
t)
-(eval-and-compile
- (let ((Gnus-p
- (eval-when-compile
- (let ((gnus (locate-library "gnus"))
- ;; Gnus has mailcap.el in the same directory of gnus.el.
- (mailcap (locate-library "mailcap")))
- (and gnus mailcap
- (string-equal (file-name-directory gnus)
- (file-name-directory mailcap)))))))
- (if Gnus-p
- (progn
- (defmacro nnshimbun-mail-header-subject (header)
- `(mail-header-subject ,header))
- (defmacro nnshimbun-mail-header-from (header)
- `(mail-header-from ,header)))
- (defmacro nnshimbun-mail-header-subject (header)
- `(mime-entity-fetch-field ,header 'Subject))
- (defmacro nnshimbun-mail-header-from (header)
- `(mime-entity-fetch-field ,header 'From)))))
-
-(defun nnshimbun-make-shimbun-header (header)
- (shimbun-make-header
- (mail-header-number header)
- (nnshimbun-mail-header-subject header)
- (nnshimbun-mail-header-from header)
- (mail-header-date header)
- (or (cdr (assq 'X-Nnshimbun-Id (mail-header-extra header)))
- (mail-header-id header))
- (mail-header-references header)
- (mail-header-chars header)
- (mail-header-lines header)
- (let ((xref (mail-header-xref header)))
- (if (and xref (string-match "^Xref: " xref))
- (substring xref 6)
- xref))))
+(eval-when-compile
+ (require 'gnus-sum)) ;; For the macro `gnus-summary-article-header'.
(defun nnshimbun-request-article-1 (article &optional group server to-buffer)
(if (nnshimbun-backlog
(cons group article)
(let* ((header (with-current-buffer (nnshimbun-open-nov group)
(and (nnheader-find-nov-line article)
- (nnshimbun-make-shimbun-header
- (nnheader-parse-nov)))))
+ (nnshimbun-parse-nov))))
(original-id (shimbun-header-id header)))
(when header
(with-current-buffer (or to-buffer nntp-server-buffer)
- (delete-region (point-min) (point-max))
- (shimbun-article nnshimbun-shimbun header)
+ (erase-buffer)
+ (let ((shimbun-encapsulate-images
+ (nnshimbun-find-parameter group 'encapsulate-images)))
+ (shimbun-article nnshimbun-shimbun header))
(when (> (buffer-size) 0)
+ ;; Kludge! replace a date string in `gnus-newsgroup-data'
+ ;; based on the newly retrieved article.
+ (let ((x (gnus-summary-article-header article)))
+ (when x
+ ;; Trick to suppress byte compile of mail-header-set-date(),
+ ;; in order to keep compatibility between T-gnus and Oort Gnus.
+ (eval
+ `(mail-header-set-date ,x ,(shimbun-header-date header)))))
(nnshimbun-replace-nov-entry group article header original-id)
(nnshimbun-backlog
(gnus-backlog-enter-article group article (current-buffer)))
(deffoo nnshimbun-request-article (article &optional group server to-buffer)
(when (nnshimbun-possibly-change-group group server)
- (when (stringp article)
- (setq article (nnshimbun-search-id group article)))
- (if (integerp article)
+ (if (or (integerp article)
+ (when (stringp article)
+ (setq article
+ (or (when (or group (setq group (nnshimbun-current-group)))
+ (nnshimbun-search-id group article))
+ (catch 'found
+ (dolist (x (shimbun-groups nnshimbun-shimbun))
+ (and (nnshimbun-possibly-change-group x)
+ (setq x (nnshimbun-search-id x article))
+ (throw 'found x))))))))
(nnshimbun-request-article-1 article group server to-buffer)
(nnheader-report 'nnshimbun "Couldn't retrieve article: %s"
- (prin1-to-string article))
- nil)))
+ (prin1-to-string article)))))
(deffoo nnshimbun-request-group (group &optional server dont-check)
- (let ((file-name-coding-system nnmail-pathname-coding-system)
- (pathname-coding-system nnmail-pathname-coding-system))
- (cond
- ((not (nnshimbun-possibly-change-group group server))
- (nnheader-report 'nnshimbun "Invalid group (no such directory)"))
- ((not (file-exists-p nnshimbun-current-directory))
- (nnheader-report 'nnshimbun "Directory %s does not exist"
- nnshimbun-current-directory))
- ((not (file-directory-p nnshimbun-current-directory))
- (nnheader-report 'nnshimbun "%s is not a directory" nnshimbun-current-directory))
- (dont-check
- (nnheader-report 'nnshimbun "Group %s selected" group)
- t)
- (t
- (let (beg end lines)
- (with-current-buffer (nnshimbun-open-nov group)
- (goto-char (point-min))
- (setq beg (ignore-errors (read (current-buffer))))
- (goto-char (point-max))
- (forward-line -1)
- (setq end (ignore-errors (read (current-buffer)))
- lines (count-lines (point-min) (point-max))))
- (nnheader-report 'nnshimbunw "Selected group %s" group)
- (nnheader-insert "211 %d %d %d %s\n"
- lines (or beg 0) (or end 0) group))))))
+ (if (not (nnshimbun-possibly-change-group group server))
+ (nnheader-report 'nnshimbun "Invalid group (no such directory)")
+ (let (beg end lines)
+ (with-current-buffer (nnshimbun-open-nov group)
+ (goto-char (point-min))
+ (setq beg (ignore-errors (read (current-buffer))))
+ (goto-char (point-max))
+ (forward-line -1)
+ (setq end (ignore-errors (read (current-buffer)))
+ lines (count-lines (point-min) (point-max))))
+ (nnheader-report 'nnshimbun "Selected group %s" group)
+ (nnheader-insert "211 %d %d %d %s\n"
+ lines (or beg 0) (or end 0) group))))
(deffoo nnshimbun-request-scan (&optional group server)
- (nnshimbun-possibly-change-group group server)
- (nnshimbun-generate-nov-database group))
+ (when (nnshimbun-possibly-change-group nil server)
+ (if group
+ (nnshimbun-generate-nov-database group)
+ (dolist (group (shimbun-groups nnshimbun-shimbun))
+ (nnshimbun-generate-nov-database group)))))
(deffoo nnshimbun-close-group (group &optional server)
(nnshimbun-write-nov group)
t)
(deffoo nnshimbun-request-list (&optional server)
- (with-current-buffer nntp-server-buffer
- (delete-region (point-min) (point-max))
- (dolist (group (shimbun-groups nnshimbun-shimbun))
- (when (nnshimbun-possibly-change-group group server)
- (let (beg end)
- (with-current-buffer (nnshimbun-open-nov group)
- (goto-char (point-min))
- (setq beg (ignore-errors (read (current-buffer))))
- (goto-char (point-max))
- (forward-line -1)
- (setq end (ignore-errors (read (current-buffer)))))
- (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
- t) ; return value
+ (when (nnshimbun-possibly-change-group nil server)
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (dolist (group (shimbun-groups nnshimbun-shimbun))
+ (when (nnshimbun-possibly-change-group group)
+ (let (beg end)
+ (with-current-buffer (nnshimbun-open-nov group)
+ (goto-char (point-min))
+ (setq beg (ignore-errors (read (current-buffer))))
+ (goto-char (point-max))
+ (forward-line -1)
+ (setq end (ignore-errors (read (current-buffer)))))
+ (insert (format "%s %d %d n\n" group (or end 0) (or beg 0)))))))
+ t)) ; return value
(deffoo nnshimbun-retrieve-headers (articles &optional group server fetch-old)
(when (nnshimbun-possibly-change-group group server)
- (if (nnshimbun-retrieve-headers-with-nov articles fetch-old)
+ (if (nnshimbun-retrieve-headers-with-nov articles group fetch-old)
'nov
(with-current-buffer nntp-server-buffer
- (delete-region (point-min) (point-max))
+ (erase-buffer)
(let (header)
(dolist (art articles)
- (if (stringp art)
- (setq art (nnshimbun-search-id group art)))
- (if (integerp art)
- (when (setq header
- (with-current-buffer (nnshimbun-open-nov group)
- (and (nnheader-find-nov-line art)
- (nnheader-parse-nov))))
- (insert (format "220 %d Article retrieved.\n" art))
- (shimbun-header-insert
- nnshimbun-shimbun
- (nnshimbun-make-shimbun-header header))
- (insert ".\n")
- (delete-region (point) (point-max))))))
+ (when (and (if (stringp art)
+ (setq art (nnshimbun-search-id group art))
+ (integerp art))
+ (setq header
+ (with-current-buffer (nnshimbun-open-nov group)
+ (and (nnheader-find-nov-line art)
+ (nnshimbun-parse-nov)))))
+ (insert (format "220 %d Article retrieved.\n" art))
+ (shimbun-header-insert nnshimbun-shimbun header)
+ (insert ".\n")
+ (delete-region (point) (point-max)))))
'header))))
-(defun nnshimbun-retrieve-headers-with-nov (articles &optional fetch-old)
- (if (or gnus-nov-is-evil nnshimbun-nov-is-evil)
- nil
- (let ((nov (expand-file-name nnshimbun-nov-file-name nnshimbun-current-directory)))
- (when (file-exists-p nov)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (erase-buffer)
- (nnheader-insert-file-contents nov)
- (if (and fetch-old (not (numberp fetch-old)))
- t ; Don't remove anything.
- (nnheader-nov-delete-outside-range
- (if fetch-old (max 1 (- (car articles) fetch-old))
- (car articles))
- (and articles (nth (1- (length articles)) articles)))
- t))))))
-
+(defun nnshimbun-retrieve-headers-with-nov (articles &optional group fetch-old)
+ (unless (or gnus-nov-is-evil nnshimbun-nov-is-evil)
+ (with-current-buffer nntp-server-buffer
+ (erase-buffer)
+ (insert-buffer (nnshimbun-open-nov group))
+ (unless (and fetch-old (not (numberp fetch-old)))
+ (nnheader-nov-delete-outside-range
+ (if fetch-old
+ (max 1 (- (car articles) fetch-old))
+ (car articles))
+ (nth (1- (length articles)) articles)))
+ t)))
;;; Nov Database Operations
+(defvar nnshimbun-tmp-string nil
+ "Internal variable used to just a rest for a temporary string. The
+macro `nnshimbun-string-or' uses it exclusively.")
+
+(defmacro nnshimbun-string-or (&rest strings)
+ "Return the first element of STRINGS that is a non-blank string. It
+should run fast, especially if two strings are given. Each string can
+also be nil."
+ (cond ((null strings)
+ nil)
+ ((= 1 (length strings))
+ ;; Return irregularly nil if one blank string is given.
+ `(unless (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
+ nnshimbun-tmp-string))
+ ((= 2 (length strings))
+ ;; Return the second string when the first string is blank.
+ `(if (zerop (length (setq nnshimbun-tmp-string ,(car strings))))
+ ,(cadr strings)
+ nnshimbun-tmp-string))
+ (t
+ `(let ((strings (list ,@strings)))
+ (while strings
+ (setq strings (if (zerop (length (setq nnshimbun-tmp-string
+ (car strings))))
+ (cdr strings))))
+ nnshimbun-tmp-string))))
+
+(autoload 'message-make-date "message")
(defsubst nnshimbun-insert-nov (number header &optional id)
- (unless (and (stringp id)
- (not (string= id (shimbun-header-id header))))
- (setq id nil))
- (princ number (current-buffer))
- (let ((p (point)))
+ (insert "\n")
+ (backward-char 1)
+ (let ((header-id (nnshimbun-string-or (shimbun-header-id header)))
+ ;; Force `princ' to work in the current buffer.
+ (standard-output (current-buffer))
+ (xref (nnshimbun-string-or (shimbun-header-xref header)))
+ (start (point)))
+ (and (stringp id)
+ header-id
+ (string-equal id header-id)
+ (setq id nil))
+ (princ number)
(insert
"\t"
- (or (shimbun-header-subject header) "(none)") "\t"
- (or (shimbun-header-from header) "(nobody)") "\t"
- (or (shimbun-header-date header) "") "\t"
- (or (shimbun-header-id header) (nnmail-message-id)) "\t"
+ (nnshimbun-string-or (shimbun-header-subject header) "(none)") "\t"
+ (nnshimbun-string-or (shimbun-header-from header) "(nobody)") "\t"
+ (nnshimbun-string-or (shimbun-header-date header) (message-make-date))
+ "\t"
+ (or header-id (nnmail-message-id)) "\t"
(or (shimbun-header-references header) "") "\t")
- (princ (or (shimbun-header-chars header) 0) (current-buffer))
+ (princ (or (shimbun-header-chars header) 0))
(insert "\t")
- (princ (or (shimbun-header-lines header) 0) (current-buffer))
+ (princ (or (shimbun-header-lines header) 0))
(insert "\t")
- (when (shimbun-header-xref header)
- (insert "Xref: " (shimbun-header-xref header)))
- (when (or (shimbun-header-xref header) id)
- (insert "\t"))
- (when id
- (insert "X-Nnshimbun-Id: " id "\t"))
- (insert "\n")
- (backward-char 1)
- (while (search-backward "\n" p t)
- (delete-char 1))
+ (if xref
+ (progn
+ (insert "Xref: " xref "\t")
+ (when id
+ (insert "X-Nnshimbun-Id: " id "\t")))
+ (when id
+ (insert "\tX-Nnshimbun-Id: " id "\t")))
+ ;; Replace newlines with spaces in the current NOV line.
+ (while (progn
+ (forward-line 0)
+ (> (point) start))
+ (backward-delete-char 1)
+ (insert " "))
(forward-line 1)))
(defun nnshimbun-generate-nov-database (group)
- (nnshimbun-possibly-change-group group)
- (with-current-buffer (nnshimbun-open-nov group)
- (goto-char (point-max))
- (forward-line -1)
- (let ((i (or (ignore-errors (read (current-buffer))) 0)))
- (dolist (header (shimbun-headers nnshimbun-shimbun))
- (unless (nnshimbun-search-id group (shimbun-header-id header))
- (goto-char (point-max))
- (nnshimbun-insert-nov (setq i (1+ i)) header)
- (when nnshimbun-pre-fetch-article
- (nnshimbun-request-article-1 i group nil nnshimbun-buffer)))))
- (nnshimbun-write-nov group)))
+ (when (nnshimbun-possibly-change-group group)
+ (with-current-buffer (nnshimbun-open-nov group)
+ (goto-char (point-max))
+ (forward-line -1)
+ (let* ((i (or (ignore-errors (read (current-buffer))) 0))
+ (name (concat "nnshimbun+" (nnshimbun-current-server) ":" group))
+ (pre-fetch (nnshimbun-find-parameter name 'prefetch-articles t)))
+ (dolist (header
+ (shimbun-headers nnshimbun-shimbun
+ (nnshimbun-find-parameter name
+ 'index-range t)))
+ (unless (nnshimbun-search-id group (shimbun-header-id header))
+ (goto-char (point-max))
+ (nnshimbun-insert-nov (setq i (1+ i)) header)
+ (when pre-fetch
+ (with-temp-buffer
+ (nnshimbun-request-article-1 i group nil (current-buffer)))))))
+ (nnshimbun-write-nov group))))
(defun nnshimbun-replace-nov-entry (group article header &optional id)
(with-current-buffer (nnshimbun-open-nov group)
(delete-region (point) (progn (forward-line 1) (point)))
(nnshimbun-insert-nov article header id))))
-(defun nnshimbun-search-id (group id &optional nov)
+(defun nnshimbun-search-id (group id)
(with-current-buffer (nnshimbun-open-nov group)
(goto-char (point-min))
(let (found)
(forward-line 1)
(forward-line 0)
(setq found t))))
- (if found
- (if nov
- (nnheader-parse-nov)
- ;; We return the article number.
- (ignore-errors (read (current-buffer))))))))
+ (when found
+ (ignore-errors (read (current-buffer)))))))
+
+;; This function is defined as an alternative of `nnheader-parse-nov',
+;; in order to keep compatibility between T-gnus and Oort Gnus.
+(defun nnshimbun-parse-nov ()
+ (let ((eol (gnus-point-at-eol)))
+ (let ((number (nnheader-nov-read-integer))
+ (subject (nnheader-nov-field))
+ (from (nnheader-nov-field))
+ (date (nnheader-nov-field))
+ (id (nnheader-nov-read-message-id))
+ (refs (nnheader-nov-field))
+ (chars (nnheader-nov-read-integer))
+ (lines (nnheader-nov-read-integer))
+ (xref (unless (eq (char-after) ?\n)
+ (when (looking-at "Xref: ")
+ (goto-char (match-end 0)))
+ (nnheader-nov-field)))
+ (extra (nnheader-nov-parse-extra)))
+ (shimbun-make-header number subject from date
+ (or (cdr (assq 'X-Nnshimbun-Id extra)) id)
+ refs chars lines xref))))
+
+(defsubst nnshimbun-nov-buffer-name (&optional group)
+ (format " *nnshimbun overview %s %s*"
+ (nnshimbun-current-server)
+ (or group (nnshimbun-current-group))))
+
+(defsubst nnshimbun-nov-file-name (&optional group)
+ (nnmail-group-pathname (or group (nnshimbun-current-group))
+ (nnshimbun-server-directory)
+ nnshimbun-nov-file-name))
(defun nnshimbun-open-nov (group)
- (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
- (if (buffer-live-p buffer)
- buffer
- (setq buffer (gnus-get-buffer-create
- (format " *nnshimbun overview %s %s*"
- (nnoo-current-server 'nnshimbun) group)))
- (save-excursion
- (set-buffer buffer)
- (set (make-local-variable 'nnshimbun-nov-buffer-file-name)
- (expand-file-name
- nnshimbun-nov-file-name
- (nnmail-group-pathname group nnshimbun-server-directory)))
+ (let ((buffer (nnshimbun-nov-buffer-name group)))
+ (unless (gnus-buffer-live-p buffer)
+ (with-current-buffer (gnus-get-buffer-create buffer)
(erase-buffer)
- (when (file-exists-p nnshimbun-nov-buffer-file-name)
- (nnheader-insert-file-contents nnshimbun-nov-buffer-file-name))
- (set-buffer-modified-p nil))
- (push (cons group buffer) nnshimbun-nov-buffer-alist)
- buffer)))
-
-(defun nnshimbun-write-nov (group)
- (let ((buffer (cdr (assoc group nnshimbun-nov-buffer-alist))))
- (when (buffer-live-p buffer)
- (save-excursion
- (set-buffer buffer)
- (buffer-modified-p)
- (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
- nil 'nomesg)))))
-
-(defun nnshimbun-save-nov ()
- (save-excursion
- (while nnshimbun-nov-buffer-alist
- (when (buffer-name (cdar nnshimbun-nov-buffer-alist))
- (set-buffer (cdar nnshimbun-nov-buffer-alist))
- (when (buffer-modified-p)
- (nnmail-write-region 1 (point-max) nnshimbun-nov-buffer-file-name
- nil 'nomesg))
- (set-buffer-modified-p nil)
- (kill-buffer (current-buffer)))
- (setq nnshimbun-nov-buffer-alist (cdr nnshimbun-nov-buffer-alist)))))
-
-
-
-;;; Server Initialize
-
-(defun nnshimbun-possibly-change-group (group &optional server)
- (when server
- (unless (nnshimbun-server-opened server)
- (nnshimbun-open-server server)))
- (unless (gnus-buffer-live-p nnshimbun-buffer)
- (setq nnshimbun-buffer
- (save-excursion
- (nnheader-set-temp-buffer
- (format " *nnshimbun %s*" (nnoo-current-server 'nnshimbun))))))
- (if (not group)
- t
- (condition-case err
- (shimbun-open-group nnshimbun-shimbun group)
- (error (nnheader-report 'nnshimbun "%s" (error-message-string err))))
- (let ((pathname (nnmail-group-pathname group nnshimbun-server-directory))
- (file-name-coding-system nnmail-pathname-coding-system)
- (pathname-coding-system nnmail-pathname-coding-system))
- (unless (equal pathname nnshimbun-current-directory)
- (setq nnshimbun-current-directory pathname
- nnshimbun-current-group group))
- (unless (file-exists-p nnshimbun-current-directory)
- (ignore-errors (make-directory nnshimbun-current-directory t)))
- (cond
- ((not (file-exists-p nnshimbun-current-directory))
- (nnheader-report 'nnshimbun "Couldn't create directory: %s" nnshimbun-current-directory))
- ((not (file-directory-p (file-truename nnshimbun-current-directory)))
- (nnheader-report 'nnshimbun "Not a directory: %s" nnshimbun-current-directory))
- (t t)))))
-
+ (let ((file-name-coding-system nnmail-pathname-coding-system)
+ (pathname-coding-system nnmail-pathname-coding-system)
+ (nov (nnshimbun-nov-file-name group)))
+ (when (file-exists-p nov)
+ (nnheader-insert-file-contents nov)))
+ (set-buffer-modified-p nil)))
+ buffer))
+
+(defun nnshimbun-write-nov (group &optional close)
+ (let ((buffer (nnshimbun-nov-buffer-name group)))
+ (when (gnus-buffer-live-p buffer)
+ (with-current-buffer buffer
+ (let ((file-name-coding-system nnmail-pathname-coding-system)
+ (pathname-coding-system nnmail-pathname-coding-system)
+ (nov (nnshimbun-nov-file-name group)))
+ (when (and (buffer-modified-p)
+ (or (> (buffer-size) 0)
+ (file-exists-p nov)))
+ (nnmail-write-region 1 (point-max) nov nil 'nomesg)
+ (set-buffer-modified-p nil))))
+ (when close
+ (kill-buffer buffer)))))
+
+(deffoo nnshimbun-request-expire-articles (articles group
+ &optional server force)
+ "Do expiration for the specified ARTICLES in the nnshimbun GROUP.
+Notice that nnshimbun does not actually delete any articles, it just
+delete the corresponding entries in the NOV database locally. The
+optional fourth argument FORCE is ignored."
+ (when (nnshimbun-possibly-change-group group server)
+ (let* ((expirable (copy-sequence articles))
+ (name (concat "nnshimbun+" (nnshimbun-current-server) ":" group))
+ ;; If the group's parameter `expiry-wait' is non-nil, the
+ ;; value of the option `nnmail-expiry-wait' will be bound
+ ;; to that value, and the value of the option
+ ;; `nnmail-expiry-wait-function' will be bound to nil. See
+ ;; the source code of `gnus-summary-expire-articles' how
+ ;; does it work. If the group's parameter is not specified
+ ;; by user, the shimbun's default value will be used.
+ (expiry-wait
+ (or (nnshimbun-find-parameter name 'expiry-wait t)
+ (shimbun-article-expiration-days nnshimbun-shimbun)))
+ (nnmail-expiry-wait (or expiry-wait nnmail-expiry-wait))
+ (nnmail-expiry-wait-function (if expiry-wait
+ nil
+ nnmail-expiry-wait-function))
+ article end time)
+ (with-current-buffer (nnshimbun-open-nov group)
+ (while expirable
+ (setq article (pop expirable))
+ (when (and (nnheader-find-nov-line article)
+ (setq end (gnus-point-at-eol))
+ (not (= (point-max) (1+ end))))
+ (setq time (and (search-forward "\t" end t)
+ (search-forward "\t" end t)
+ (search-forward "\t" end t)
+ (parse-time-string
+ (buffer-substring
+ (point)
+ (if (search-forward "\t" end t)
+ (1- (point))
+ end)))))
+ (when (if (setq time (condition-case nil
+ (apply 'encode-time time)
+ (error nil)))
+ (nnmail-expired-article-p name time nil)
+ ;; Inhibit expiration if there's no parsable date
+ ;; and the following option is non-nil.
+ (not nnshimbun-keep-unparsable-dated-articles))
+ (forward-line 0)
+ (delete-region (point) (1+ end))
+ (setq articles (delq article articles)))))
+ (nnshimbun-write-nov group))
+ articles)))
;;; shimbun-gnus-mua
(shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
id))
-(luna-define-method shimbun-mua-use-entire-index ((mua shimbun-gnus-mua))
- nnshimbun-use-entire-index)
+
+;;; Command to create nnshimbun group
+(defvar nnshimbun-server-history nil)
+
+;;;###autoload
+(defun gnus-group-make-shimbun-group ()
+ "Create a nnshimbun group."
+ (interactive)
+ (let* ((minibuffer-setup-hook
+ (append minibuffer-setup-hook '(beginning-of-line)))
+ (alist
+ (apply 'nconc
+ (mapcar
+ (lambda (d)
+ (and (stringp d)
+ (file-directory-p d)
+ (delq nil
+ (mapcar
+ (lambda (f)
+ (and (string-match "^sb-\\(.*\\)\\.el$" f)
+ (list (match-string 1 f))))
+ (directory-files d)))))
+ load-path)))
+ (server (completing-read
+ "Shimbun address: "
+ alist nil t
+ (or (car nnshimbun-server-history)
+ (caar alist))
+ 'nnshimbun-server-history))
+ (groups)
+ (nnshimbun-pre-fetch-article))
+ (if (setq groups (shimbun-groups (shimbun-open server)))
+ (gnus-group-make-group
+ (completing-read "Group name: " (mapcar 'list groups) nil t nil)
+ (list 'nnshimbun server))
+ (error "%s" "Can't find group"))))
(provide 'nnshimbun)
-;;; nnshimbun.el ends here.
+
+;;; nnshimbun.el ends here
projects / elisp / gnus.git- / blobdiff