From: tsuchiya Date: Sun, 11 Jan 2004 08:45:24 +0000 (+0000) Subject: Accidentaly revivaled. Remove again. X-Git-Tag: t-gnus-6_17_2-00~3 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=986f449ff354bdcefbc56c61abb42ac20d6d9c72;p=elisp%2Fgnus.git- Accidentaly revivaled. Remove again. --- diff --git a/ChangeLog b/ChangeLog index d2134ad..2194890 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +2004-01-11 TSUCHIYA Masatoshi + + * lisp/nnshimbun.el: Accidentaly revivaled. Remove again. + 2004-01-05 Katsumi Yamaoka * lisp/gnus-vers.el: T-gnus 6.17.1 revision 00. diff --git a/lisp/nnshimbun.el b/lisp/nnshimbun.el deleted file mode 100644 index 87675c9..0000000 --- a/lisp/nnshimbun.el +++ /dev/null @@ -1,762 +0,0 @@ -;;; nnshimbun.el --- interfacing with web newspapers - -;; Copyright (C) 2000,2001,2002 TSUCHIYA Masatoshi - -;; Authors: TSUCHIYA Masatoshi , -;; Akihiro Arisawa , -;; Katsumi Yamaoka , -;; Yuuichi Teranishi -;; 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