+++ /dev/null
-;;; 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>,
-;; Katsumi Yamaoka <yamaoka@jpl.org>,
-;; Yuuichi Teranishi <teranisi@gohome.org>
-;; Keywords: news
-
-;; This file is a part of Semi-Gnus.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, you can either send email to this
-;; program's maintainer or write to: The Free Software Foundation,
-;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; Gnus (or gnus) backend to read newspapers on the World Wide Web.
-;; This module requires the emacs-w3m and the external command w3m.
-;; Visit the following pages for more information.
-;;
-;; 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, put the following expression into your ~/.gnus.
-;;
-;; (autoload 'gnus-group-make-shimbun-group "nnshimbun" nil t)
-
-
-;;; Definitions:
-
-(eval-when-compile (require 'cl))
-(require 'nnoo)
-(require 'nnheader)
-(require 'nnmail)
-(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/")
- "Where nnshimbun will save its files.")
-
-(defvoo nnshimbun-nov-is-evil nil
- "*Non-nil means that nnshimbun will never retrieve NOV headers.")
-
-(defvoo nnshimbun-nov-file-name ".overview")
-
-(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-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-open-server
-(defvoo nnshimbun-shimbun nil)
-
-(defvoo nnshimbun-status-string "")
-(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*" (nnshimbun-current-server)))
- (gnus-backlog-articles nnshimbun-backlog-articles)
- (gnus-backlog-hashtb nnshimbun-backlog-hashtb))
- (unwind-protect
- (progn ,@form)
- (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 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)
- (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)
- (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))
- (nnoo-close-server 'nnshimbun server)
- t)
-
-(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
- (gnus-backlog-request-article
- group article (or to-buffer nntp-server-buffer)))
- (cons group article)
- (let* ((header (with-current-buffer (nnshimbun-open-nov group)
- (and (nnheader-find-nov-line article)
- (nnshimbun-parse-nov))))
- (original-id (shimbun-header-id header)))
- (when header
- (with-current-buffer (or to-buffer nntp-server-buffer)
- (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)))
- (nnheader-report 'nnshimbun "Article %s retrieved"
- (shimbun-header-id header))
- (cons group article)))))))
-
-(deffoo nnshimbun-request-article (article &optional group server to-buffer)
- (when (nnshimbun-possibly-change-group group server)
- (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)))))
-
-(deffoo nnshimbun-request-group (group &optional server dont-check)
- (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)
- (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)
- (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 group fetch-old)
- 'nov
- (with-current-buffer nntp-server-buffer
- (erase-buffer)
- (let (header)
- (dolist (art articles)
- (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 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)
- (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"
- (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))
- (insert "\t")
- (princ (or (shimbun-header-lines header) 0))
- (insert "\t")
- (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)
- (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)
- (when (nnheader-find-nov-line article)
- (delete-region (point) (progn (forward-line 1) (point)))
- (nnshimbun-insert-nov article header id))))
-
-(defun nnshimbun-search-id (group id)
- (with-current-buffer (nnshimbun-open-nov group)
- (goto-char (point-min))
- (let (found)
- (while (and (not found)
- (search-forward id nil t)) ; We find the ID.
- ;; And the id is in the fourth field.
- (if (not (and (search-backward "\t" nil t 4)
- (not (search-backward "\t" (gnus-point-at-bol) t))))
- (forward-line 1)
- (forward-line 0)
- (setq found t)))
- (unless found
- (goto-char (point-min))
- (setq id (concat "X-Nnshimbun-Id: " id))
- (while (and (not found)
- (search-forward id nil t))
- (if (not (search-backward "\t" (gnus-point-at-bol) t 8))
- (forward-line 1)
- (forward-line 0)
- (setq found t))))
- (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 (nnshimbun-nov-buffer-name group)))
- (unless (gnus-buffer-live-p buffer)
- (with-current-buffer (gnus-get-buffer-create buffer)
- (erase-buffer)
- (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
-(luna-define-class shimbun-gnus-mua (shimbun-mua) ())
-
-(luna-define-method shimbun-mua-search-id ((mua shimbun-gnus-mua) id)
- (nnshimbun-search-id
- (shimbun-current-group-internal (shimbun-mua-shimbun-internal mua))
- id))
-
-
-;;; 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
projects / elisp / gnus.git- / commitdiff