From 9b0aa593cc4277d6b965dd42d669dc303be6d6b4 Mon Sep 17 00:00:00 2001 From: yamaoka Date: Mon, 3 Mar 2003 04:58:36 +0000 Subject: [PATCH] Synch to Oort Gnus. --- lisp/ChangeLog | 133 +++++- lisp/gnus-agent.el | 1264 ++++++++++++++++++++++++++++++++-------------------- lisp/gnus-art.el | 4 +- lisp/gnus-cus.el | 315 +++++++++++-- lisp/gnus-int.el | 14 +- lisp/gnus-start.el | 132 ++++-- lisp/gnus-util.el | 26 ++ lisp/gnus.el | 9 +- lisp/nnkiboze.el | 2 +- lisp/nntp.el | 22 +- 10 files changed, 1341 insertions(+), 580 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 0c0cc3c..70a87aa 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,104 @@ +2003-03-02 Kevin Greiner + + * nntp.el (nntp-possibly-change-group): Avoid calling + process-buffer on nil (Which happened when you lost your + connection while fetching); instead signal a "Server Closed + Connection" error. + +2003-03-02 Kevin Greiner + + * gnus-agent.el (gnus-agent-enable-expiration): New + variable. Either ENABLE or DISABLE. Sets default behavior for + selecting which groups are expired. + (gnus-agent-cat-set-property, gnus-agent-cat-defaccessor, + gnus-agent-set-cat-groups): Provides abstract interface for + accessing agent category. Category now implemented by an alist. + (gnus-agent-add-group, gnus-agent-remove-group, + gnus-category-insert-line, gnus-category-edit-predicate, + gnus-category-edit-score, gnus-category-edit-groups, + gnus-category-copy, gnus-category-add, gnus-group-category): Use + new agent category abstraction. + (gnus-agent-find-parameter): New function. Search for agent + configuration parameter first in the group's parameters, then its + topics (if any), and then the group's category. If not found + anywhere, use the original defined constants. + (gnus-agent-fetch-headers, gnus-agent-fetch-group-1): Use new + gnus-agent-find-parameter. + (gnus-agent-fetch-headers, gnus-agent-uncached-articles): Clearing + gnus-agent-cache now blocks retrieving headers and articles from + the local cache. Fetched content is still added to the cache + before being returned. + (gnus-agent-fetch-session): Use error-message-string to generate + displayed error message. + (gnus-agent-customize-category): New Command. 'e' in category + buffer opens category customization buffer. + (gnus-category-read): Reads either positional or alist format; + returns alist format. + (gnus-category-write): Writes category file compatible with + current, and previous, versions of gnus-agent. + (gnus-category-make-function, gnus-category-make-function-1): + Corrected documentation; parameter is predicate NOT category. + (gnus-predicate-implies-unread): Now works in more cases per the + todo comment. + (gnus-function-implies-unread-1): New function. Supports + gnus-predicate-implies-unread. + (gnus-agent-expire-group): Command now provides default of group + under point. + (gnus-agent-expire-group-1): Obeys new agent-enable-expiration and + agent-days-until-old parameters. No longer supports + gnus-agent-expire-days being set to an alist. + (gnus-agent-request-article): Now performs its own checks of + gnus-agent, gnus-agent-cache, and gnus-plugged rather than + assuming that the caller will do them correctly. + (): Added one-time hook to gnus-group-prepare-hook. Detects when + gnus-agent-expire-days is set to an alist. Converts said alist + into group parameter so that gnus-agent-expire-days will not be + needed. + * gnus-art.el (gnus-request-article-this-buffer): Conditional + checks surrounding gnus-agent-request-article removed; now + performed by gnus-agent-request-article. + * gnus-cus.el (gnus-agent-parameters): New variable. List of + customizable group/topic parameters that regulate the agent. + (gnus-group-customize): Uses gnus-agent-parameters. Replaced + kill-buffer with gnus-kill-buffer to remove the killed buffer from + the list of gnus buffers. + (gnus-trim-whitespace): Removes leading and trailing whitespace + from multiline strings. + (gnus-agent-cat-prepare-category-field, + gnus-agent-customize-category): Constructs a category + customization buffer. + * gnus-int.el (gnus-retrieve-headers, + gnus-request-expire-articles): No longer checks gnus-agent-cache + as it is handled internally by the agent. + (gnus-request-head, gnus-request-body): Conditional checks + surrounding gnus-agent-request-article removed; now performed by + gnus-agent-request-article. + + * gnus-start.el (): Added defvar statements to resolve compilation + warnings. + (gnus-long-file-names): New function. Isolates platform dependent + msdos-long-file-names. + (gnus-save-startup-file-via-temp-buffer): New variable. Provides + option of writing directly to file. Avoids memory exhausted + errors when .newsrc.eld is huge. + (gnus-save-newsrc-file): Uses new + gnus-save-startup-file-via-temp-buffer. + (gnus-gnus-to-quick-newsrc-format): Rewritten to write to + standard-output. + (gnus-display-time-event-handler): Changed to alias from a defun + to avoid a compile-time warning when display-time-event-handler is + not defined. + * gnus-util.el (gnus-with-output-to-file): New macro. Binds + standard-output such that prin1 and princ will write directly to a + file. + + * gnus.el (gnus-agent-cache): Expanded documentation. + (gnus-summary-high-undownloaded-face): Removed second bold keyword + so that this face is actually bold. + + * nnkiboze.el (nnkiboze-request-article): Only use the cache when + gnus-use-cache has been set. + 2003-03-02 Jesper Harder * nnvirtual.el (nnvirtual-update-xref-header): Simplify. @@ -103,12 +204,12 @@ spam-stat-register-ham-routine): remove spam-stat-save (spam-stat hook): add spam-stat-save to the gnus-save-newsrc-hook -2002-02-24 Kevin Greiner +2003-02-24 Kevin Greiner * gnus-group.el (gnus-topic-mode-p): Fixed free variable reference. -2002-02-24 Kevin Greiner +2003-02-24 Kevin Greiner * nnheader.el (nnheader-find-nov-line): Changed midpoint calculation to avoid integer overflow. @@ -149,7 +250,7 @@ * gnus-registry.el (puthash): Alias to cl-puthash for Emacs 20. -2002-02-23 Kevin Greiner +2003-02-23 Kevin Greiner * gnus-start.el (gnus-activate-group): Re-enabled the catch error clause of the condition-case statement. Errors connecting to a @@ -465,7 +566,7 @@ * nnmail.el: Autoload gnus-kill-buffer. -2002-02-11 Kevin Greiner +2003-02-11 Kevin Greiner * gnus-agent.el (gnus-summary-set-agent-mark): Added call to gnus-summary-goto-subject as gnus-summary-update-mark operates on @@ -495,7 +596,7 @@ * mm-util.el (mm-mule-charset-to-mime-charset): Use sort-coding-systems to prefer utf-8 over utf-16. -2002-02-09 Kevin Greiner +2003-02-09 Kevin Greiner * gnus-agent.el (gnus-agent-expire-days): gnus-request-move-article depends on gnus-agent-expire to clean up @@ -913,7 +1014,7 @@ * gnus-sum.el (gnus-data-find-list): Remove *. -2002-01-23 Kevin Greiner +2003-01-23 Kevin Greiner * gnus-sum.el (gnus-summary-first-subject): Fixed bug that I introduced on 2002-01-22. @@ -929,7 +1030,7 @@ * gnus-sum.el (gnus-spam-mark): set to `$' -2002-01-22 Kevin Greiner +2003-01-22 Kevin Greiner * gnus-agent.el (gnus-agent-get-undownloaded-list): Now computes gnus-newsgroup-unfetched, the list of articles whose headers have @@ -1017,7 +1118,7 @@ * mailcap.el (mailcap-print-command): lpr-command might be unbound in XEmacs. -2002-01-18 Kevin Greiner +2003-01-18 Kevin Greiner * gnus-agent.el (gnus-agent-regenerate-group): Added interactive form. @@ -1158,7 +1259,7 @@ * nnimap.el (nnimap-split-download-body): New variable. (nnimap-split-articles): Use it. -2002-01-14 Kevin Greiner +2003-01-14 Kevin Greiner * gnus-agent.el (gnus-agent-check-overview-buffer): This data integrity checker was incorrectly flagging, and removing, articles @@ -1185,7 +1286,7 @@ * gnus-msg.el (gnus-inews-add-send-actions): Allow a list of articles to be marked as well. -2002-01-14 Kevin Greiner +2003-01-14 Kevin Greiner * gnus-agent.el (gnus-agent-get-undownloaded-list): Include the fictious headers generated by nnagent (ie. Undownloaded Article ####) in the list of articles that have not been downloaded. @@ -1314,7 +1415,7 @@ * gnus-msg.el (gnus-inews-do-gcc): Don't try to mark GCC's as read if Gnus isn't alive. -2002-01-11 Kevin Greiner +2003-01-11 Kevin Greiner * gnus-agent.el (gnus-agent-fetch-group-1): Remove downloadable marks from articles that are already stored in the agent. @@ -1370,7 +1471,7 @@ * message.el (message-check-news-header-syntax): Compute the header length correctly. -2002-01-10 Kevin Greiner +2003-01-10 Kevin Greiner * gnus-agent.el (gnus-agent-expire): Do not remove article from alist when keeping fetched article file. @@ -1452,7 +1553,7 @@ (spam-stat-reset): Set spam-stat-ngood and spam-stat-nbad to 0. Changed copyright statement to FSF. -2002-01-09 Kevin Greiner +2003-01-09 Kevin Greiner * gnus-agent.el (gnus-agent-catchup): Do not mark cached nor processable articles as read. @@ -1608,7 +1709,7 @@ * gnus-sum.el (gnus-summary-make-menu-bar): Added gnus-summary-refer-thread to thread menu. -2002-01-07 Kevin Greiner +2003-01-07 Kevin Greiner * gnus-agent.el (gnus-agent-fetch-group-1): When fetching within a summary buffer, articles that cannot be fetched are marked as @@ -1659,7 +1760,7 @@ gnus-sieve-crosspost. One-line patch from Steinar Bang . -2002-01-06 Kevin Greiner +2003-01-06 Kevin Greiner * gnus.el: Renamed gnus-summary-*-uncached-face as gnus-summary-*-undownloaded-face to avoid confusing the agent with @@ -1667,7 +1768,7 @@ * gnus-sum.el: Ditto. -2002-01-06 Kevin Greiner +2003-01-06 Kevin Greiner * gnus-agent.el (gnus-agent-fetch-group): Modified to permit execution in either the group or summary buffer. diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 1f03fb2..f344d73 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -41,7 +41,9 @@ (require 'gnus-group)) (eval-and-compile - (autoload 'gnus-server-update-server "gnus-srvr")) + (autoload 'gnus-server-update-server "gnus-srvr") + (autoload 'gnus-agent-customize-category "gnus-cus") +) (defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/") "Where the Gnus agent will store its files." @@ -161,6 +163,17 @@ this limit." :group 'gnus-agent :type 'integer) +(defcustom gnus-agent-enable-expiration 'ENABLE + "The default expiration state for each group. +When set to ENABLE, the default, gnus-agent-expire will expire old +contents from a group's local storage. This value may be overridden +to disable expiration in specific categories, topics, and groups. Of +course, you could change gnus-agent-enable-expiration to nil then +enable expiration per categories, topics, and groups." + :group 'gnus-agent + :type '(radio (const :format "Enable " ENABLE) + (const :format "Disable " DISABLE))) + ;;; Internal variables (defvar gnus-agent-history-buffers nil) @@ -258,6 +271,107 @@ node `(gnus)Server Buffer'.") (file-name-as-directory (expand-file-name "agent.lib" (gnus-agent-directory))))) +(defun gnus-agent-cat-set-property (category property value) + (if value + (setcdr (or (assq property category) + (let ((cell (cons property nil))) + (setcdr category (cons cell (cdr category))) + cell)) value) + (let ((category category)) + (while (cond ((eq property (caadr category)) + (setcdr category (cddr category)) + nil) + (t + (setq category (cdr category))))))) + category) + +(defmacro gnus-agent-cat-defaccessor (name prop-name) + "Define accessor and setter methods for manipulating a list of the form +(NAME (PROPERTY1 VALUE1) ... (PROPERTY_N VALUE_N)). +Given the call (gnus-agent-cat-defaccessor func PROPERTY1), the list may be +manipulated as follows: + (func LIST): Returns VALUE1 + (setf (func LIST) NEW_VALUE1): Replaces VALUE1 with NEW_VALUE1." + `(progn (defmacro ,name (category) + (list (quote cdr) (list (quote assq) + (quote (quote ,prop-name)) category))) + + (define-setf-method ,name (category) + (let* ((--category--temp-- (gensym "--category--")) + (--value--temp-- (gensym "--value--"))) + (list (list --category--temp--) ; temporary-variables + (list category) ; value-forms + (list --value--temp--) ; store-variables + (let* ((category --category--temp--) ; store-form + (value --value--temp--)) + (list (quote gnus-agent-cat-set-property) + category + (quote (quote ,prop-name)) + value)) + (list (quote ,name) --category--temp--) ; access-form + ))))) + +(defmacro gnus-agent-cat-name (category) + `(car ,category)) + +(gnus-agent-cat-defaccessor + gnus-agent-cat-days-until-old agent-days-until-old) +(gnus-agent-cat-defaccessor + gnus-agent-cat-enable-expiration agent-enable-expiration) +(gnus-agent-cat-defaccessor + gnus-agent-cat-groups agent-groups) +(gnus-agent-cat-defaccessor + gnus-agent-cat-high-score agent-high-score) +(gnus-agent-cat-defaccessor + gnus-agent-cat-length-when-long agent-length-when-long) +(gnus-agent-cat-defaccessor + gnus-agent-cat-length-when-short agent-length-when-short) +(gnus-agent-cat-defaccessor + gnus-agent-cat-low-score agent-low-score) +(gnus-agent-cat-defaccessor + gnus-agent-cat-predicate agent-predicate) +(gnus-agent-cat-defaccessor + gnus-agent-cat-score-file agent-score-file) + +(defsetf gnus-agent-cat-groups (category) (groups) + (list 'gnus-agent-set-cat-groups category groups)) + +(defun gnus-agent-set-cat-groups (category groups) + (unless (eq groups 'ignore) + (let ((new-g groups) + (old-g (gnus-agent-cat-groups category))) + (cond ((eq new-g old-g) + ;; gnus-agent-add-group is fiddling with the group + ;; list. Still, Im done. + nil + ) + ((eq new-g (cdr old-g)) + ;; gnus-agent-add-group is fiddling with the group list + (setcdr (or (assq 'agent-groups category) + (let ((cell (cons 'agent-groups nil))) + (setcdr category (cons cell (cdr category))) + cell)) new-g)) + (t + (let ((groups groups)) + (while groups + (let* ((group (pop groups)) + (old-category (gnus-group-category group))) + (if (eq category old-category) + nil + (setf (gnus-agent-cat-groups old-category) + (delete group (gnus-agent-cat-groups + old-category)))))) + ;; Purge cache as preceeding loop invalidated it. + (setq gnus-category-group-cache nil)) + + (setcdr (or (assq 'agent-groups category) + (let ((cell (cons 'agent-groups nil))) + (setcdr category (cons cell (cdr category))) + cell)) groups)))))) + +(defsubst gnus-agent-cat-make (name) + (list name '(agent-predicate . false))) + ;;; Fetching setup functions. (defun gnus-agent-start-fetch () @@ -593,10 +707,12 @@ be a select method." c groups) (gnus-group-iterate arg (lambda (group) - (when (cadddr (setq c (gnus-group-category group))) - (setf (cadddr c) (delete group (cadddr c)))) + (when (gnus-agent-cat-groups (setq c (gnus-group-category group))) + (setf (gnus-agent-cat-groups c) + (delete group (gnus-agent-cat-groups c)))) (push group groups))) - (setf (cadddr cat) (nconc (cadddr cat) groups)) + (setf (gnus-agent-cat-groups cat) + (nconc (gnus-agent-cat-groups cat) groups)) (gnus-category-write))) (defun gnus-agent-remove-group (arg) @@ -605,8 +721,9 @@ be a select method." (let (c) (gnus-group-iterate arg (lambda (group) - (when (cadddr (setq c (gnus-group-category group))) - (setf (cadddr c) (delete group (cadddr c)))))) + (when (gnus-agent-cat-groups (setq c (gnus-group-category group))) + (setf (gnus-agent-cat-groups c) + (delete group (gnus-agent-cat-groups c)))))) (gnus-category-write))) (defun gnus-agent-synchronize-flags () @@ -775,9 +892,12 @@ article's mark is toggled." (defun gnus-agent-get-undownloaded-list () "Construct list of articles that have not been downloaded." (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) - (when (set (make-local-variable 'gnus-newsgroup-agentized) (gnus-agent-method-p gnus-command-method)) + (when (set (make-local-variable 'gnus-newsgroup-agentized) + (gnus-agent-method-p gnus-command-method)) (let* ((alist (gnus-agent-load-alist gnus-newsgroup-name)) - (headers (sort (mapcar (lambda (h) (mail-header-number h)) gnus-newsgroup-headers) '<)) + (headers (sort (mapcar (lambda (h) + (mail-header-number h)) + gnus-newsgroup-headers) '<)) (undownloaded (list nil)) (tail-undownloaded undownloaded) (unfetched (list nil)) @@ -825,7 +945,7 @@ downloadable." gnus-newsgroup-cached) (setq articles (gnus-sorted-ndifference (gnus-sorted-ndifference - (copy-sequence articles) + (gnus-copy-sequence articles) gnus-newsgroup-downloadable) gnus-newsgroup-cached))) @@ -840,7 +960,7 @@ downloadable." (setq gnus-newsgroup-downloadable (let* ((dl gnus-newsgroup-downloadable) (gnus-newsgroup-downloadable - (sort (copy-sequence gnus-newsgroup-processable) '<)) + (sort (gnus-copy-sequence gnus-newsgroup-processable) '<)) (fetched-articles (gnus-agent-summary-fetch-group))) ;; The preceeding call to (gnus-agent-summary-fetch-group) ;; updated gnus-newsgroup-downloadable to remove each @@ -1071,9 +1191,16 @@ This can be added to `gnus-select-article-hook' or (setq current-set-size (+ current-set-size (if (= header-number article) - (let ((char-size (mail-header-chars (car headers)))) + (let ((char-size (mail-header-chars + (car headers)))) (if (<= char-size 0) - (max (* 65 (mail-header-lines (car headers))) + ;; The char size was missing/invalid, + ;; assume a worst-case situation of + ;; 65 char/line. If the line count + ;; is missing, arbitrarily assume a + ;; size of 1000 characters. + (max (* 65 (mail-header-lines + (car headers))) 1000) char-size)) 0)))) @@ -1096,7 +1223,7 @@ This can be added to `gnus-select-article-hook' or (gnus-make-directory dir) (gnus-message 7 "Fetching articles for %s..." group) - + (unwind-protect (while (setq articles (pop selected-sets)) ;; Fetch the articles from the backend. @@ -1265,6 +1392,23 @@ and that there are no duplicates." (insert "\n")) (pop gnus-agent-group-alist)))) +(defun gnus-agent-find-parameter (group symbol) + "Search for GROUPs SYMBOL in the group's parameters, the group's +topic parameters, the group's category, or the customizable +variables. Returns the first non-nil value found." + (or (gnus-group-find-parameter group symbol t) + (gnus-group-parameter-value (cdr (gnus-group-category group)) symbol t) + (symbol-value + (cdr + (assq symbol + '((agent-short-article . gnus-agent-short-article) + (agent-long-article . gnus-agent-long-article) + (agent-low-score . gnus-agent-low-score) + (agent-high-score . gnus-agent-high-score) + (agent-days-until-old . gnus-agent-expire-days) + (agent-enable-expiration + . gnus-agent-enable-expiration))))))) + (defun gnus-agent-fetch-headers (group &optional force) "Fetch interesting headers into the agent. The group's overview file will be updated to include the headers while a list of available @@ -1273,15 +1417,13 @@ article numbers will be returned." ;; Do not fetch all headers if the predicate ;; implies that we only consider unread articles. (not (gnus-predicate-implies-unread - (or (gnus-group-find-parameter - group 'agent-predicate t) - (cadr (gnus-group-category group))))))) + (gnus-agent-find-parameter group + 'agent-predicate))))) (articles (if fetch-all (gnus-uncompress-range (gnus-active group)) (gnus-list-of-unread-articles group))) (gnus-decode-encoded-word-function 'identity) - (file (gnus-agent-article-name ".overview" group)) - gnus-agent-cache) + (file (gnus-agent-article-name ".overview" group))) ;; Check whether the number of articles is not too large. (when (and (integerp gnus-agent-large-newsgroup) (> gnus-agent-large-newsgroup 0)) @@ -1308,7 +1450,9 @@ article numbers will be returned." ;; be fetched. (let ((articles articles)) ;; Remove known articles. - (when (gnus-agent-load-alist group) + (when (and (or gnus-agent-cache + (not gnus-plugged)) + (gnus-agent-load-alist group)) ;; Remove articles marked as downloaded. (if fetch-all ;; I want to fetch all headers in the active range. @@ -1367,8 +1511,7 @@ article numbers will be returned." articles) (ignore-errors (erase-buffer) - (nnheader-insert-file-contents file)))) - ) + (nnheader-insert-file-contents file))))) articles)) (defsubst gnus-agent-copy-nov-line (article) @@ -1430,7 +1573,7 @@ FILE and places the combined headers into `nntp-server-buffer'." (t (beginning-of-line) nil)))) - + (gnus-agent-copy-nov-line (pop articles))))) ;; Copy the rest lines @@ -1599,25 +1742,30 @@ FILE and places the combined headers into `nntp-server-buffer'." (save-excursion (while methods (condition-case err - (progn - (setq gnus-command-method (car methods)) - (when (and (or (gnus-server-opened gnus-command-method) - (gnus-open-server gnus-command-method)) - (gnus-online gnus-command-method)) - (setq groups (gnus-groups-from-server (car methods))) - (gnus-agent-with-fetch - (while (setq group (pop groups)) - (when (<= (gnus-group-level group) gnus-agent-handle-level) - (gnus-agent-fetch-group-1 group gnus-command-method)))))) - (error - (unless (funcall gnus-agent-confirmation-function - (format "Error %s. Continue? " (cdr err))) - (error "Cannot fetch articles into the Gnus agent"))) - (quit - (unless (funcall gnus-agent-confirmation-function - (format "Quit fetching session %s. Continue? " - (cdr err))) - (signal 'quit "Cannot fetch articles into the Gnus agent")))) + (progn + (setq gnus-command-method (car methods)) + (when (and (or (gnus-server-opened gnus-command-method) + (gnus-open-server gnus-command-method)) + (gnus-online gnus-command-method)) + (setq groups (gnus-groups-from-server (car methods))) + (gnus-agent-with-fetch + (while (setq group (pop groups)) + (when (<= (gnus-group-level group) + gnus-agent-handle-level) + (gnus-agent-fetch-group-1 + group gnus-command-method)))))) + (error + (unless (funcall gnus-agent-confirmation-function + (format "Error %s. Continue? " + (error-message-string err))) + (error "Cannot fetch articles into the Gnus agent"))) + (quit + (unless (funcall gnus-agent-confirmation-function + (format + "Quit fetching session %s. Continue? " + (error-message-string err))) + (signal 'quit + "Cannot fetch articles into the Gnus agent")))) (pop methods)) (run-hooks 'gnus-agent-fetch-hook) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) @@ -1687,14 +1835,12 @@ FILE and places the combined headers into `nntp-server-buffer'." (setq predicate (gnus-get-predicate - (or (gnus-group-find-parameter group 'agent-predicate t) - (cadr category)))) + (gnus-agent-find-parameter group 'agent-predicate))) ;; If the selection predicate requires scoring, score each header (unless (memq predicate '(gnus-agent-true gnus-agent-false)) (let ((score-param - (or (gnus-group-get-parameter group 'agent-score t) - (caddr category)))) + (gnus-agent-find-parameter group 'agent-score))) ;; Translate score-param into real one (cond ((not score-param)) @@ -1735,7 +1881,19 @@ FILE and places the combined headers into `nntp-server-buffer'." (let ((gnus-score (or (cdr (assq num gnus-newsgroup-scored)) - gnus-summary-default-score))) + gnus-summary-default-score)) + (gnus-agent-long-article + (gnus-agent-find-parameter + group 'agent-long-article)) + (gnus-agent-low-score + (gnus-agent-find-parameter + group 'agent-low-score)) + (gnus-agent-high-score + (gnus-agent-find-parameter + group 'agent-high-score)) + (gnus-agent-expire-days + (gnus-agent-find-parameter + group 'agent-days-until-old))) (funcall predicate))) (gnus-agent-append-to-list arts-tail num)))))) @@ -1854,6 +2012,7 @@ General format specifiers can also be used. See Info node "k" gnus-category-kill "c" gnus-category-copy "a" gnus-category-add + "e" gnus-agent-customize-category "p" gnus-category-edit-predicate "g" gnus-category-edit-groups "s" gnus-category-edit-score @@ -1874,6 +2033,7 @@ General format specifiers can also be used. See Info node ["Add" gnus-category-add t] ["Kill" gnus-category-kill t] ["Copy" gnus-category-copy t] + ["Edit category" gnus-agent-customize-category t] ["Edit predicate" gnus-category-edit-predicate t] ["Edit score" gnus-category-edit-score t] ["Edit groups" gnus-category-edit-groups t] @@ -1911,7 +2071,7 @@ The following commands are available: (defun gnus-category-insert-line (category) (let* ((gnus-tmp-name (format "%s" (car category))) - (gnus-tmp-groups (length (cadddr category)))) + (gnus-tmp-groups (length (gnus-agent-cat-groups category)))) (beginning-of-line) (gnus-add-text-properties (point) @@ -1950,10 +2110,34 @@ The following commands are available: (defun gnus-category-read () "Read the category alist." - (setq gnus-category-alist - (or (gnus-agent-read-file - (nnheader-concat gnus-agent-directory "lib/categories")) - (list (list 'default 'short nil nil))))) + (setq gnus-category-alist + (or + (with-temp-buffer + (ignore-errors + (nnheader-insert-file-contents (nnheader-concat gnus-agent-directory "lib/categories")) + (goto-char (point-min)) + ;; This code isn't temp, it will be needed so long as + ;; anyone may be migrating from an older version. + + ;; Once we're certain that people will not revert to an + ;; earlier version, we can take out the old-list code in + ;; gnus-category-write. + (let* ((old-list (read (current-buffer))) + (new-list (ignore-errors (read (current-buffer))))) + (if new-list + new-list + ;; Convert from a positional list to an alist. + (mapcar + (lambda (c) + (setcdr c + (mapcar* + (lambda (valu symb) + (cons symb valu)) + (cdr c) + '(agent-predicate agent-score-file agent-groups))) + c) + old-list))))) + (list (gnus-agent-cat-make 'default))))) (defun gnus-category-write () "Write the category alist." @@ -1961,6 +2145,16 @@ The following commands are available: gnus-category-group-cache nil) (gnus-make-directory (nnheader-concat gnus-agent-directory "lib")) (with-temp-file (nnheader-concat gnus-agent-directory "lib/categories") + ;; This prin1 is temporary. It exists so that people can revert + ;; to an earlier version of gnus-agent. + (prin1 (mapcar (lambda (c) + (list (car c) + (cdr (assoc 'agent-predicate c)) + (cdr (assoc 'agent-score-file c)) + (cdr (assoc 'agent-groups c)))) + gnus-category-alist) + (current-buffer)) + (newline) (prin1 gnus-category-alist (current-buffer)))) (defun gnus-category-edit-predicate (category) @@ -1968,9 +2162,16 @@ The following commands are available: (interactive (list (gnus-category-name))) (let ((info (assq category gnus-category-alist))) (gnus-edit-form - (cadr info) (format "Editing the predicate for category %s" category) + (gnus-agent-cat-predicate info) + (format "Editing the select predicate for category %s" category) `(lambda (predicate) - (setcar (cdr (assq ',category gnus-category-alist)) predicate) + ;; Avoid run-time execution of setf form + ;; (setf (gnus-agent-cat-predicate (assq ',category gnus-category-alist)) + ;; predicate) + ;; use its expansion instead: + (gnus-agent-cat-set-property (assq ',category gnus-category-alist) + 'agent-predicate predicate) + (gnus-category-write) (gnus-category-list))))) @@ -1979,10 +2180,16 @@ The following commands are available: (interactive (list (gnus-category-name))) (let ((info (assq category gnus-category-alist))) (gnus-edit-form - (caddr info) + (gnus-agent-cat-score-file info) (format "Editing the score expression for category %s" category) - `(lambda (groups) - (setcar (nthcdr 2 (assq ',category gnus-category-alist)) groups) + `(lambda (score-file) + ;; Avoid run-time execution of setf form + ;; (setf (gnus-agent-cat-score-file (assq ',category gnus-category-alist)) + ;; score-file) + ;; use its expansion instead: + (gnus-agent-cat-set-property (assq ',category gnus-category-alist) + 'agent-score-file score-file) + (gnus-category-write) (gnus-category-list))))) @@ -1991,9 +2198,16 @@ The following commands are available: (interactive (list (gnus-category-name))) (let ((info (assq category gnus-category-alist))) (gnus-edit-form - (cadddr info) (format "Editing the group list for category %s" category) + (gnus-agent-cat-groups info) + (format "Editing the group list for category %s" category) `(lambda (groups) - (setcar (nthcdr 3 (assq ',category gnus-category-alist)) groups) + ;; Avoid run-time execution of setf form + ;; (setf (gnus-agent-cat-groups (assq ',category gnus-category-alist)) + ;; groups) + ;; use its expansion instead: + (gnus-agent-set-cat-groups (assq ',category gnus-category-alist) + groups) + (gnus-category-write) (gnus-category-list))))) @@ -2010,8 +2224,10 @@ The following commands are available: "Copy the current category." (interactive (list (gnus-category-name) (intern (read-string "New name: ")))) (let ((info (assq category gnus-category-alist))) - (push (list to (gnus-copy-sequence (cadr info)) - (gnus-copy-sequence (caddr info)) nil) + (push (let ((newcat (gnus-copy-sequence info))) + (setf (gnus-agent-cat-name newcat) to) + (setf (gnus-agent-cat-groups newcat) nil) + newcat) gnus-category-alist) (gnus-category-write) (gnus-category-list))) @@ -2021,7 +2237,7 @@ The following commands are available: (interactive "SCategory name: ") (when (assq category gnus-category-alist) (error "Category %s already exists" category)) - (push (list category 'false nil nil) + (push (gnus-agent-cat-make category) gnus-category-alist) (gnus-category-write) (gnus-category-list)) @@ -2083,9 +2299,9 @@ The following commands are available: (gnus-member-of-range (mail-header-number gnus-headers) (gnus-info-read (gnus-get-info gnus-newsgroup-name)))) -(defun gnus-category-make-function (cat) - "Make a function from category CAT." - (let ((func (gnus-category-make-function-1 cat))) +(defun gnus-category-make-function (predicate) + "Make a function from PREDICATE." + (let ((func (gnus-category-make-function-1 predicate))) (if (and (= (length func) 1) (symbolp (car func))) (car func) @@ -2099,26 +2315,26 @@ The following commands are available: "Return nil." nil) -(defun gnus-category-make-function-1 (cat) - "Make a function from category CAT." +(defun gnus-category-make-function-1 (predicate) + "Make a function from PREDICATE." (cond ;; Functions are just returned as is. - ((or (symbolp cat) - (gnus-functionp cat)) - `(,(or (cdr (assq cat gnus-category-predicate-alist)) - cat))) - ;; More complex category. - ((consp cat) + ((or (symbolp predicate) + (gnus-functionp predicate)) + `(,(or (cdr (assq predicate gnus-category-predicate-alist)) + predicate))) + ;; More complex predicate. + ((consp predicate) `(,(cond - ((memq (car cat) '(& and)) + ((memq (car predicate) '(& and)) 'and) - ((memq (car cat) '(| or)) + ((memq (car predicate) '(| or)) 'or) - ((memq (car cat) gnus-category-not) + ((memq (car predicate) gnus-category-not) 'not)) - ,@(mapcar 'gnus-category-make-function-1 (cdr cat)))) + ,@(mapcar 'gnus-category-make-function-1 (cdr predicate)))) (t - (error "Unknown category type: %s" cat)))) + (error "Unknown predicate type: %s" predicate)))) (defun gnus-get-predicate (predicate) "Return the function implementing PREDICATE." @@ -2134,8 +2350,20 @@ The following commands are available: It is okay to miss some cases, but there must be no false positives. That is, if this function returns true, then indeed the predicate must return only unread articles." - ;; Todo: make this work in more cases. - (equal predicate '(not read))) + (gnus-function-implies-unread-1 (gnus-category-make-function predicate))) + +(defun gnus-function-implies-unread-1 (function) + (cond ((eq function (symbol-function 'gnus-agent-read-p)) + nil) + ((not function) + nil) + ((symbolp function) + 'ignore) + ((memq (car function) '(or and not)) + (apply (car function) + (mapcar 'gnus-function-implies-unread-1 (cdr function)))) + (t + (error "Unknown function: %s" function)))) (defun gnus-group-category (group) "Return the category GROUP belongs to." @@ -2144,7 +2372,7 @@ return only unread articles." (let ((cs gnus-category-alist) groups cat) (while (setq cat (pop cs)) - (setq groups (cadddr cat)) + (setq groups (gnus-agent-cat-groups cat)) (while groups (gnus-sethash (pop groups) cat gnus-category-group-cache))))) (or (gnus-gethash group gnus-category-group-cache) @@ -2160,13 +2388,23 @@ The articles on which the expiration process runs are selected as follows: if ARTICLES is t, all articles. if ARTICLES is a list, just those articles. FORCE is equivalent to setting the expiration predicates to true." - (interactive) + (interactive + (list (let ((def (or (gnus-group-group-name) + gnus-newsgroup-name))) + (let ((select (read-string (if def + (concat "Group Name (" + def "): ") + "Group Name: ")))) + (if (and (equal "" select) + def) + def + select))))) (if (not group) (gnus-agent-expire articles group force) (if (or (not (eq articles t)) - (yes-or-no-p - (concat "Are you sure that you want to " + (yes-or-no-p + (concat "Are you sure that you want to " "expire all articles in " group "."))) (let ((gnus-command-method (gnus-find-method-for-group group)) (overview (gnus-get-buffer-create " *expire overview*")) @@ -2193,315 +2431,307 @@ FORCE is equivalent to setting the expiration predicates to true." ;; provided a non-nil active (interactive) - (gnus-message 5 "Expiring articles in %s" group) - (gnus-agent-load-alist group) - (let* ((info (gnus-get-info group)) - (alist gnus-agent-article-alist) - (dir (concat - (gnus-agent-directory) - (gnus-agent-group-path group) - "/")) - (day (if (numberp gnus-agent-expire-days) - (- (time-to-days (current-time)) gnus-agent-expire-days) - (let ((days gnus-agent-expire-days)) - (catch 'found - (while days - (when (eq 0 (string-match - (caar days) - group)) - (throw 'found (- (time-to-days - (current-time)) - (cadar days)))) - (pop days)) - ;; No regexp matched so set - ;; a limit that will block - ;; expiration in this group. - 0)))) - (specials (if (and alist - (not force)) - ;; This could be a bit of a problem. I need to - ;; keep the last article to avoid refetching - ;; headers when using nntp in the backend. At - ;; the same time, if someone uses a backend - ;; that supports article moving then I may have - ;; to remove the last article to complete the - ;; move. Right now, I'm going to assume that - ;; FORCE overrides specials. - (list (caar (last alist))))) - (unreads ;; Articles that are excluded from the - ;; expiration process - (cond (gnus-agent-expire-all - ;; All articles are marked read by global decree - nil) - ((eq articles t) - ;; All articles are marked read by function - ;; parameter - nil) - ((not articles) - ;; Unread articles are marked protected from - ;; expiration Don't call - ;; gnus-list-of-unread-articles as it returns - ;; articles that have not been fetched into the - ;; agent. - (ignore-errors - (gnus-agent-unread-articles group))) - (t - ;; All articles EXCEPT those named by the caller - ;; are protected from expiration - (gnus-sorted-difference - (gnus-uncompress-range - (cons (caar alist) - (caar (last alist)))) - (sort articles '<))))) - (marked ;; More articles that are exluded from the - ;; expiration process - (cond (gnus-agent-expire-all - ;; All articles are unmarked by global decree - nil) - ((eq articles t) - ;; All articles are unmarked by function - ;; parameter - nil) - (articles - ;; All articles may as well be unmarked as the - ;; unreads list already names the articles we are - ;; going to keep - nil) - (t - ;; Ticked and/or dormant articles are excluded - ;; from expiration - (nconc - (gnus-uncompress-range - (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range - (cdr (assq 'dormant - (gnus-info-marks info)))))))) - (nov-file (concat dir ".overview")) - (cnt 0) - (completed -1) - dlist - type) - - ;; The normal article alist contains elements that look like - ;; (article# . fetch_date) I need to combine other - ;; information with this list. For example, a flag indicating - ;; that a particular article MUST BE KEPT. To do this, I'm - ;; going to transform the elements to look like (article# - ;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse - ;; the process to generate the expired article alist. - - ;; Convert the alist elements to (article# fetch_date nil - ;; nil). - (setq dlist (mapcar (lambda (e) - (list (car e) (cdr e) nil nil)) alist)) - - ;; Convert the keep lists to elements that look like (article# - ;; nil keep_flag nil) then append it to the expanded dlist - ;; These statements are sorted by ascending precidence of the - ;; keep_flag. - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'unread nil)) - unreads))) - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'marked nil)) - marked))) - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'special nil)) - specials))) - - (set-buffer overview) - (erase-buffer) - (when (file-exists-p nov-file) - (gnus-message 7 "gnus-agent-expire: Loading overview...") - (nnheader-insert-file-contents nov-file) - (goto-char (point-min)) - - (let (p) - (while (< (setq p (point)) (point-max)) - (condition-case nil - ;; If I successfully read an integer (the plus zero - ;; ensures a numeric type), prepend a marker entry - ;; to the list - (push (list (+ 0 (read (current-buffer))) nil nil - (set-marker (make-marker) p)) - dlist) - (error - (gnus-message 1 "gnus-agent-expire: read error \ + (if (eq 'DISABLE (gnus-agent-find-parameter group 'agent-enable-expiration)) + (gnus-message 5 "Expiry skipping over %s" group) + (gnus-message 5 "Expiring articles in %s" group) + (gnus-agent-load-alist group) + (let* ((info (gnus-get-info group)) + (alist gnus-agent-article-alist) + (dir (concat + (gnus-agent-directory) + (gnus-agent-group-path group) + "/")) + (day (- (time-to-days (current-time)) + (gnus-agent-find-parameter group 'agent-days-until-old))) + (specials (if (and alist + (not force)) + ;; This could be a bit of a problem. I need to + ;; keep the last article to avoid refetching + ;; headers when using nntp in the backend. At + ;; the same time, if someone uses a backend + ;; that supports article moving then I may have + ;; to remove the last article to complete the + ;; move. Right now, I'm going to assume that + ;; FORCE overrides specials. + (list (caar (last alist))))) + (unreads ;; Articles that are excluded from the + ;; expiration process + (cond (gnus-agent-expire-all + ;; All articles are marked read by global decree + nil) + ((eq articles t) + ;; All articles are marked read by function + ;; parameter + nil) + ((not articles) + ;; Unread articles are marked protected from + ;; expiration Don't call + ;; gnus-list-of-unread-articles as it returns + ;; articles that have not been fetched into the + ;; agent. + (ignore-errors + (gnus-agent-unread-articles group))) + (t + ;; All articles EXCEPT those named by the caller + ;; are protected from expiration + (gnus-sorted-difference + (gnus-uncompress-range + (cons (caar alist) + (caar (last alist)))) + (sort articles '<))))) + (marked ;; More articles that are exluded from the + ;; expiration process + (cond (gnus-agent-expire-all + ;; All articles are unmarked by global decree + nil) + ((eq articles t) + ;; All articles are unmarked by function + ;; parameter + nil) + (articles + ;; All articles may as well be unmarked as the + ;; unreads list already names the articles we are + ;; going to keep + nil) + (t + ;; Ticked and/or dormant articles are excluded + ;; from expiration + (nconc + (gnus-uncompress-range + (cdr (assq 'tick (gnus-info-marks info)))) + (gnus-uncompress-range + (cdr (assq 'dormant + (gnus-info-marks info)))))))) + (nov-file (concat dir ".overview")) + (cnt 0) + (completed -1) + dlist + type) + + ;; The normal article alist contains elements that look like + ;; (article# . fetch_date) I need to combine other + ;; information with this list. For example, a flag indicating + ;; that a particular article MUST BE KEPT. To do this, I'm + ;; going to transform the elements to look like (article# + ;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse + ;; the process to generate the expired article alist. + + ;; Convert the alist elements to (article# fetch_date nil + ;; nil). + (setq dlist (mapcar (lambda (e) + (list (car e) (cdr e) nil nil)) alist)) + + ;; Convert the keep lists to elements that look like (article# + ;; nil keep_flag nil) then append it to the expanded dlist + ;; These statements are sorted by ascending precidence of the + ;; keep_flag. + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'unread nil)) + unreads))) + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'marked nil)) + marked))) + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'special nil)) + specials))) + + (set-buffer overview) + (erase-buffer) + (when (file-exists-p nov-file) + (gnus-message 7 "gnus-agent-expire: Loading overview...") + (nnheader-insert-file-contents nov-file) + (goto-char (point-min)) + + (let (p) + (while (< (setq p (point)) (point-max)) + (condition-case nil + ;; If I successfully read an integer (the plus zero + ;; ensures a numeric type), prepend a marker entry + ;; to the list + (push (list (+ 0 (read (current-buffer))) nil nil + (set-marker (make-marker) p)) + dlist) + (error + (gnus-message 1 "gnus-agent-expire: read error \ occurred when reading expression at %s in %s. Skipping to next \ line." (point) nov-file))) - ;; Whether I succeeded, or failed, it doesn't matter. - ;; Move to the next line then try again. - (forward-line 1))) - (gnus-message - 7 "gnus-agent-expire: Loading overview... Done")) - (set-buffer-modified-p nil) - - ;; At this point, all of the information is in dlist. The - ;; only problem is that much of it is spread across multiple - ;; entries. Sort then MERGE!! - (gnus-message 7 "gnus-agent-expire: Sorting entries... ") - ;; If two entries have the same article-number then sort by - ;; ascending keep_flag. - (let ((special 0) - (marked 1) - (unread 2)) - (setq dlist - (sort dlist - (lambda (a b) - (cond ((< (nth 0 a) (nth 0 b)) - t) - ((> (nth 0 a) (nth 0 b)) - nil) - (t - (let ((a (or (symbol-value (nth 2 a)) - 3)) - (b (or (symbol-value (nth 2 b)) - 3))) - (<= a b)))))))) - (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") - (gnus-message 7 "gnus-agent-expire: Merging entries... ") - (let ((dlist dlist)) - (while (cdr dlist) ; I'm not at the end-of-list - (if (eq (caar dlist) (caadr dlist)) - (let ((first (cdr (car dlist))) - (secnd (cdr (cadr dlist)))) - (setcar first (or (car first) - (car secnd))) ; fetch_date - (setq first (cdr first) - secnd (cdr secnd)) - (setcar first (or (car first) - (car secnd))) ; Keep_flag - (setq first (cdr first) - secnd (cdr secnd)) - (setcar first (or (car first) - (car secnd))) ; NOV_entry_marker - - (setcdr dlist (cddr dlist))) - (setq dlist (cdr dlist))))) - (gnus-message 7 "gnus-agent-expire: Merging entries... Done") - - (let* ((len (float (length dlist))) - (alist (list nil)) - (tail-alist alist)) - (while dlist - (let ((new-completed (truncate (* 100.0 - (/ (setq cnt (1+ cnt)) - len))))) - (when (> new-completed completed) - (setq completed new-completed) - (gnus-message 9 "%3d%% completed..." completed))) - (let* ((entry (car dlist)) - (article-number (nth 0 entry)) - (fetch-date (nth 1 entry)) - (keep (nth 2 entry)) - (marker (nth 3 entry))) - - (cond - ;; Kept articles are unread, marked, or special. - (keep - (gnus-message 10 "gnus-agent-expire: Article %d: Kept %s article." article-number keep) - (when fetch-date - (unless (file-exists-p - (concat dir (number-to-string - article-number))) - (setf (nth 1 entry) nil) - (gnus-message 3 "gnus-agent-expire cleared \ + ;; Whether I succeeded, or failed, it doesn't matter. + ;; Move to the next line then try again. + (forward-line 1))) + (gnus-message + 7 "gnus-agent-expire: Loading overview... Done")) + (set-buffer-modified-p nil) + + ;; At this point, all of the information is in dlist. The + ;; only problem is that much of it is spread across multiple + ;; entries. Sort then MERGE!! + (gnus-message 7 "gnus-agent-expire: Sorting entries... ") + ;; If two entries have the same article-number then sort by + ;; ascending keep_flag. + (let ((special 0) + (marked 1) + (unread 2)) + (setq dlist + (sort dlist + (lambda (a b) + (cond ((< (nth 0 a) (nth 0 b)) + t) + ((> (nth 0 a) (nth 0 b)) + nil) + (t + (let ((a (or (symbol-value (nth 2 a)) + 3)) + (b (or (symbol-value (nth 2 b)) + 3))) + (<= a b)))))))) + (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") + (gnus-message 7 "gnus-agent-expire: Merging entries... ") + (let ((dlist dlist)) + (while (cdr dlist) ; I'm not at the end-of-list + (if (eq (caar dlist) (caadr dlist)) + (let ((first (cdr (car dlist))) + (secnd (cdr (cadr dlist)))) + (setcar first (or (car first) + (car secnd))) ; fetch_date + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) + (car secnd))) ; Keep_flag + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) + (car secnd))) ; NOV_entry_marker + + (setcdr dlist (cddr dlist))) + (setq dlist (cdr dlist))))) + (gnus-message 7 "gnus-agent-expire: Merging entries... Done") + + (let* ((len (float (length dlist))) + (alist (list nil)) + (tail-alist alist)) + (while dlist + (let ((new-completed (truncate (* 100.0 + (/ (setq cnt (1+ cnt)) + len))))) + (when (> new-completed completed) + (setq completed new-completed) + (gnus-message 9 "%3d%% completed..." completed))) + (let* ((entry (car dlist)) + (article-number (nth 0 entry)) + (fetch-date (nth 1 entry)) + (keep (nth 2 entry)) + (marker (nth 3 entry))) + + (cond + ;; Kept articles are unread, marked, or special. + (keep + (gnus-message 10 + "gnus-agent-expire: Article %d: Kept %s article." + article-number keep) + (when fetch-date + (unless (file-exists-p + (concat dir (number-to-string + article-number))) + (setf (nth 1 entry) nil) + (gnus-message 3 "gnus-agent-expire cleared \ download flag on article %d as the cached article file is missing." - (caar dlist))) - (unless marker - (gnus-message 1 "gnus-agent-expire detected a \ + (caar dlist))) + (unless marker + (gnus-message 1 "gnus-agent-expire detected a \ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) - (gnus-agent-append-to-list - tail-alist - (cons article-number fetch-date))) - - ;; The following articles are READ, UNMARKED, and - ;; ORDINARY. See if they can be EXPIRED!!! - ((setq type - (cond - ((not (integerp fetch-date)) - 'read) ;; never fetched article (may expire - ;; right now) - ((not (file-exists-p - (concat dir (number-to-string - article-number)))) - (setf (nth 1 entry) nil) - 'externally-expired) ;; Can't find the cached - ;; article. Handle case - ;; as though this article - ;; was never fetched. - - ;; We now have the arrival day, so we see - ;; whether it's old enough to be expired. - ((< fetch-date day) - 'expired) - (force - 'forced))) - - ;; I found some reason to expire this entry. - - (let ((actions nil)) - (when (memq type '(forced expired)) - (ignore-errors ; Just being paranoid. - (delete-file (concat dir (number-to-string - article-number))) - (push "expired cached article" actions)) - (setf (nth 1 entry) nil) - ) - - (when marker - (push "NOV entry removed" actions) - (goto-char marker) - (gnus-delete-line)) - - ;; If considering all articles is set, I can only - ;; expire article IDs that are no longer in the - ;; active range. - (if (and gnus-agent-consider-all-articles - (>= article-number (car active))) - ;; I have to keep this ID in the alist - (gnus-agent-append-to-list - tail-alist (cons article-number fetch-date)) - (push (format "Removed %s article number from \ + (gnus-agent-append-to-list + tail-alist + (cons article-number fetch-date))) + + ;; The following articles are READ, UNMARKED, and + ;; ORDINARY. See if they can be EXPIRED!!! + ((setq type + (cond + ((not (integerp fetch-date)) + 'read) ;; never fetched article (may expire + ;; right now) + ((not (file-exists-p + (concat dir (number-to-string + article-number)))) + (setf (nth 1 entry) nil) + 'externally-expired) ;; Can't find the cached + ;; article. Handle case + ;; as though this article + ;; was never fetched. + + ;; We now have the arrival day, so we see + ;; whether it's old enough to be expired. + ((< fetch-date day) + 'expired) + (force + 'forced))) + + ;; I found some reason to expire this entry. + + (let ((actions nil)) + (when (memq type '(forced expired)) + (ignore-errors ; Just being paranoid. + (delete-file (concat dir (number-to-string + article-number))) + (push "expired cached article" actions)) + (setf (nth 1 entry) nil) + ) + + (when marker + (push "NOV entry removed" actions) + (goto-char marker) + (gnus-delete-line)) + + ;; If considering all articles is set, I can only + ;; expire article IDs that are no longer in the + ;; active range. + (if (and gnus-agent-consider-all-articles + (>= article-number (car active))) + ;; I have to keep this ID in the alist + (gnus-agent-append-to-list + tail-alist (cons article-number fetch-date)) + (push (format "Removed %s article number from \ article alist" type) actions)) - (gnus-message 7 "gnus-agent-expire: Article %d: %s" - article-number - (mapconcat 'identity actions ", ")))) - (t - (gnus-message 10 "gnus-agent-expire: Article %d: Article kept as expiration tests failed." article-number) - (gnus-agent-append-to-list - tail-alist (cons article-number fetch-date))) - ) - - ;; Clean up markers as I want to recycle this buffer - ;; over several groups. - (when marker - (set-marker marker nil)) - - (setq dlist (cdr dlist)))) - - (setq alist (cdr alist)) - - (let ((inhibit-quit t)) - (unless (equal alist gnus-agent-article-alist) - (setq gnus-agent-article-alist alist) - (gnus-agent-save-alist group)) - - (when (buffer-modified-p) - (gnus-make-directory dir) - (write-region-as-coding-system gnus-agent-file-coding-system - (point-min) (point-max) nov-file - nil 'silent) - ;; clear the modified flag as that I'm not confused by its - ;; status on the next pass through this routine. - (set-buffer-modified-p nil)) - - (when (eq articles t) - (gnus-summary-update-info)))))) + (gnus-message 7 "gnus-agent-expire: Article %d: %s" + article-number + (mapconcat 'identity actions ", ")))) + (t + (gnus-message + 10 "gnus-agent-expire: Article %d: Article kept as \ +expiration tests failed." article-number) + (gnus-agent-append-to-list + tail-alist (cons article-number fetch-date))) + ) + + ;; Clean up markers as I want to recycle this buffer + ;; over several groups. + (when marker + (set-marker marker nil)) + + (setq dlist (cdr dlist)))) + + (setq alist (cdr alist)) + + (let ((inhibit-quit t)) + (unless (equal alist gnus-agent-article-alist) + (setq gnus-agent-article-alist alist) + (gnus-agent-save-alist group)) + + (when (buffer-modified-p) + (gnus-make-directory dir) + (write-region-as-coding-system gnus-agent-file-coding-system + (point-min) (point-max) nov-file + nil 'silent) + ;; clear the modified flag as that I'm not confused by + ;; its status on the next pass through this routine. + (set-buffer-modified-p nil)) + + (when (eq articles t) + (gnus-summary-update-info))))))) (defun gnus-agent-expire (&optional articles group force) "Expire all old articles. @@ -2589,7 +2819,8 @@ has been fetched." ;; Functionally, I don't need to construct a temp list using mapcar. - (if (gnus-agent-load-alist group) + (if (and (or gnus-agent-cache (not gnus-plugged)) + (gnus-agent-load-alist group)) (let* ((ref gnus-agent-article-alist) (arts articles) (uncached (list nil)) @@ -2597,15 +2828,15 @@ has been fetched." (while (and ref arts) (let ((v1 (car arts)) (v2 (caar ref))) - (cond ((< v1 v2) ; the article (v1) does not appear in the reference list + (cond ((< v1 v2) ; v1 does not appear in the reference list (gnus-agent-append-to-list tail-uncached v1) (pop arts)) ((= v1 v2) - (unless (or cached-header (cdar ref)) ; the article (v1) is already cached + (unless (or cached-header (cdar ref)) ; v1 is already cached (gnus-agent-append-to-list tail-uncached v1)) (pop arts) (pop ref)) - (t ; the reference article (v2) preceeds the list being filtered + (t ; reference article (v2) preceeds the list being filtered (pop ref))))) (while arts (gnus-agent-append-to-list tail-uncached (pop arts))) @@ -2630,70 +2861,77 @@ has been fetched." gnus-agent-file-coding-system)) (nnheader-insert-nov-file file (car articles))))) - (if (setq uncached-articles (gnus-agent-uncached-articles articles group t)) + (if (setq uncached-articles (gnus-agent-uncached-articles articles group + t)) (progn ;; Populate nntp-server-buffer with uncached headers (set-buffer nntp-server-buffer) (erase-buffer) - (let (gnus-agent-cache) ; Turn off agent cache - (cond ((not (eq 'nov (gnus-retrieve-headers - uncached-articles group fetch-old))) - (nnvirtual-convert-headers)) - ((eq 'nntp (car gnus-current-select-method)) - ;; The author of gnus-get-newsgroup-headers-xover - ;; reports that the XOVER command is commonly - ;; unreliable. The problem is that recently - ;; posted articles may not be entered into the - ;; NOV database in time to respond to my XOVER - ;; query. - ;; - ;; I'm going to use his assumption that the NOV - ;; database is updated in order of ascending - ;; article ID. Therefore, a response containing - ;; article ID N implies that all articles from 1 - ;; to N-1 are up-to-date. Therefore, missing - ;; articles in that range have expired. - - (set-buffer nntp-server-buffer) - (let* ((fetched-articles (list nil)) - (tail-fetched-articles fetched-articles) - (min (cond ((numberp fetch-old) - (max 1 (- (car articles) fetch-old))) - (fetch-old - 1) - (t - (car articles)))) - (max (car (last articles)))) - - ;; Get the list of articles that were fetched - (goto-char (point-min)) - (let ((pm (point-max))) - (while (< (point) pm) - (when (looking-at "[0-9]+\t") - (gnus-agent-append-to-list tail-fetched-articles (read (current-buffer)))) - (forward-line 1))) - - ;; Clip this list to the headers that will - ;; actually be returned - (setq fetched-articles (gnus-list-range-intersection - (cdr fetched-articles) - (cons min max))) - - ;; Clip the uncached articles list to exclude - ;; IDs after the last FETCHED header. The - ;; excluded IDs may be fetchable using HEAD. - (if (car tail-fetched-articles) - (setq uncached-articles (gnus-list-range-intersection - uncached-articles - (cons (car uncached-articles) (car tail-fetched-articles))))) - - ;; Create the list of articles that were - ;; "successfully" fetched. Success, in this - ;; case, means that the ID should not be - ;; fetched again. In the case of an expired - ;; article, the header will not be fetched. - (setq uncached-articles (gnus-sorted-nunion fetched-articles uncached-articles)) - )))) + (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent + (gnus-retrieve-headers + uncached-articles group fetch-old)))) + (nnvirtual-convert-headers)) + ((eq 'nntp (car gnus-current-select-method)) + ;; The author of gnus-get-newsgroup-headers-xover + ;; reports that the XOVER command is commonly + ;; unreliable. The problem is that recently + ;; posted articles may not be entered into the + ;; NOV database in time to respond to my XOVER + ;; query. + ;; + ;; I'm going to use his assumption that the NOV + ;; database is updated in order of ascending + ;; article ID. Therefore, a response containing + ;; article ID N implies that all articles from 1 + ;; to N-1 are up-to-date. Therefore, missing + ;; articles in that range have expired. + + (set-buffer nntp-server-buffer) + (let* ((fetched-articles (list nil)) + (tail-fetched-articles fetched-articles) + (min (cond ((numberp fetch-old) + (max 1 (- (car articles) fetch-old))) + (fetch-old + 1) + (t + (car articles)))) + (max (car (last articles)))) + + ;; Get the list of articles that were fetched + (goto-char (point-min)) + (let ((pm (point-max))) + (while (< (point) pm) + (when (looking-at "[0-9]+\t") + (gnus-agent-append-to-list + tail-fetched-articles + (read (current-buffer)))) + (forward-line 1))) + + ;; Clip this list to the headers that will + ;; actually be returned + (setq fetched-articles (gnus-list-range-intersection + (cdr fetched-articles) + (cons min max))) + + ;; Clip the uncached articles list to exclude + ;; IDs after the last FETCHED header. The + ;; excluded IDs may be fetchable using HEAD. + (if (car tail-fetched-articles) + (setq uncached-articles + (gnus-list-range-intersection + uncached-articles + (cons (car uncached-articles) + (car tail-fetched-articles))))) + + ;; Create the list of articles that were + ;; "successfully" fetched. Success, in this + ;; case, means that the ID should not be + ;; fetched again. In the case of an expired + ;; article, the header will not be fetched. + (setq uncached-articles + (gnus-sorted-nunion fetched-articles + uncached-articles)) + ))) ;; Erase the temp buffer (set-buffer gnus-agent-overview-buffer) @@ -2714,13 +2952,13 @@ has been fetched." (write-region-as-coding-system gnus-agent-file-coding-system (point-min) (point-max) file nil 'silent) - + ;; Update the group's article alist to include the newly ;; fetched articles. (gnus-agent-load-alist group) (gnus-agent-save-alist group uncached-articles nil) ) - + ;; Copy the temp buffer to the nntp-server-buffer (set-buffer nntp-server-buffer) (erase-buffer) @@ -2739,32 +2977,41 @@ has been fetched." (defun gnus-agent-request-article (article group) "Retrieve ARTICLE in GROUP from the agent cache." - (let* ((gnus-command-method (gnus-find-method-for-group group)) - (file (concat + (when (and gnus-agent + (or gnus-agent-cache + (not gnus-plugged)) + (numberp article)) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (file (concat (gnus-agent-directory) (gnus-agent-group-path group) "/" (number-to-string article))) - (buffer-read-only nil)) - (when (and (file-exists-p file) - (> (nth 7 (file-attributes file)) 0)) - (erase-buffer) - (gnus-kill-all-overlays) - (insert-file-contents-as-coding-system gnus-cache-coding-system file) - t))) + (buffer-read-only nil)) + (when (and (file-exists-p file) + (> (nth 7 (file-attributes file)) 0)) + (erase-buffer) + (gnus-kill-all-overlays) + (insert-file-contents-as-coding-system gnus-cache-coding-system file) + t)))) (defun gnus-agent-regenerate-group (group &optional reread) "Regenerate GROUP. If REREAD is t, all articles in the .overview are marked as unread. If REREAD is not nil, downloaded articles are marked as unread." - (interactive (list (let ((def (or (gnus-group-group-name) - gnus-newsgroup-name))) - (let ((select (read-string (if def (concat "Group Name (" def "): ") - "Group Name: ")))) - (if (and (equal "" select) - def) - def - select))) - (intern-soft (read-string "Reread (nil)? (t=>all, nil=>none, some=>all downloaded): ")))) + (interactive + (list (let ((def (or (gnus-group-group-name) + gnus-newsgroup-name))) + (let ((select (read-string (if def + (concat "Group Name (" + def "): ") + "Group Name: ")))) + (if (and (equal "" select) + def) + def + select))) + (intern-soft + (read-string + "Reread (nil)? (t=>all, nil=>none, some=>all downloaded): ")))) (gnus-message 5 "Regenerating in %s" group) (let* ((gnus-command-method (or gnus-command-method (gnus-find-method-for-group group))) @@ -2803,21 +3050,26 @@ If REREAD is not nil, downloaded articles are marked as unread." (cond ((not l2) nil) ((< l1 l2) - (gnus-message 3 "gnus-agent-regenerate-group: NOV entries are NOT in ascending order.") + (gnus-message 3 "gnus-agent-regenerate-group: NOV\ + entries are NOT in ascending order.") ;; Don't sort now as I haven't verified ;; that every line begins with a number (setq load t)) ((= l1 l2) (forward-line -1) - (gnus-message 4 "gnus-agent-regenerate-group: NOV entries contained duplicate of article %s. Duplicate deleted." l1) + (gnus-message 4 "gnus-agent-regenerate-group: NOV\ + entries contained duplicate of article %s. Duplicate deleted." l1) (gnus-delete-line) (pop nov-arts))))) (t - (gnus-message 1 "gnus-agent-regenerate-group: NOV entries contained line that did not begin with an article number. Deleted line.") + (gnus-message 1 "gnus-agent-regenerate-group: NOV\ + entries contained line that did not begin with an article number. Deleted\ + line.") (gnus-delete-line)))) (if load (progn - (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV entries into ascending order.") + (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\ + entries into ascending order.") (sort-numeric-fields 1 (point-min) (point-max)) (setq nov-arts nil))))) (gnus-agent-check-overview-buffer) @@ -2826,11 +3078,12 @@ If REREAD is not nil, downloaded articles are marked as unread." ;; in the .overview file. As a side-effect, missing headers are ;; reconstructed from the downloaded article file. (while (or downloaded nov-arts) - (cond ((and downloaded + (cond ((and downloaded (or (not nov-arts) (> (car downloaded) (car nov-arts)))) ;; This entry is missing from the overview file - (gnus-message 3 "Regenerating NOV %s %d..." group (car downloaded)) + (gnus-message 3 "Regenerating NOV %s %d..." group + (car downloaded)) (let ((file (concat dir (number-to-string (car downloaded))))) (mm-with-unibyte-buffer (nnheader-insert-file-contents file) @@ -2838,7 +3091,8 @@ If REREAD is not nil, downloaded articles are marked as unread." (setq header (nnheader-parse-naked-head))) (mail-header-set-number header (car downloaded)) (if nov-arts - (let ((key (concat "^" (int-to-string (car nov-arts)) "\t"))) + (let ((key (concat "^" (int-to-string (car nov-arts)) + "\t"))) (or (re-search-backward key nil t) (re-search-forward key)) (forward-line 1)) @@ -2847,7 +3101,11 @@ If REREAD is not nil, downloaded articles are marked as unread." (setq nov-arts (cons (car downloaded) nov-arts))) ((eq (car downloaded) (car nov-arts)) ;; This entry in the overview has been downloaded - (push (cons (car downloaded) (time-to-days (nth 5 (file-attributes (concat dir (number-to-string (car downloaded))))))) alist) + (push (cons (car downloaded) + (time-to-days + (nth 5 (file-attributes + (concat dir (number-to-string + (car downloaded))))))) alist) (pop downloaded) (pop nov-arts)) (t @@ -2896,7 +3154,7 @@ If REREAD is not nil, downloaded articles are marked as unread." (push (cons (caar o) nil) alist)) ((< (caar n) (caar o)) (setcdr n (list (car o))))))) - + (let ((inhibit-quit t)) (if (setq regenerated (buffer-modified-p)) (write-region-as-coding-system @@ -2909,7 +3167,7 @@ If REREAD is not nil, downloaded articles are marked as unread." ) (setq gnus-agent-article-alist alist) - + (when regenerated (gnus-agent-save-alist group))) ) @@ -2978,7 +3236,8 @@ If CLEAN, don't read existing active files." (when active-changed (setq regenerated t) (gnus-message 4 "Regenerate %s" active-file) - (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system)) + (let ((nnmail-active-file-coding-system + gnus-agent-file-coding-system)) (gnus-write-active-file active-file active-hashtb))))) (gnus-message 4 "Regenerating Gnus agent files...done") regenerated)) @@ -3012,6 +3271,49 @@ If CLEAN, don't read existing active files." (member (gnus-group-method group) gnus-agent-covered-methods)) +(add-hook 'gnus-group-prepare-hook + (lambda () + 'gnus-agent-do-once + + (when (listp gnus-agent-expire-days) + (beep) + (beep) + (gnus-message 1 "WARNING: gnus-agent-expire-days no longer\ + supports being set to a list.")(sleep-for 3) + (gnus-message 1 "Change your configuration to set it to an\ + integer.")(sleep-for 3) + (gnus-message 1 "I am now setting group parameters on each\ + group to match the configuration that the list offered.") + + (save-excursion + (let ((groups (gnus-group-listed-groups))) + (while groups + (let* ((group (pop groups)) + (days gnus-agent-expire-days) + (day (catch 'found + (while days + (when (eq 0 (string-match + (caar days) + group)) + (throw 'found (cadar days))) + (pop days)) + nil))) + (when day + (gnus-group-set-parameter group 'agent-days-until-old + day)))))) + + (let ((h gnus-group-prepare-hook)) + (while h + (let ((func (pop h))) + (when (and (listp func) + (eq (cadr (caddr func)) 'gnus-agent-do-once)) + (remove-hook 'gnus-group-prepare-hook func) + (setq h nil))))) + + (gnus-message 1 "I have finished setting group parameters on\ + each group. You may now customize your groups and/or topics to control the\ + agent.")))) + (provide 'gnus-agent) ;;; gnus-agent.el ends here diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 87ea9ce..6be9b98 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -5522,9 +5522,7 @@ If given a prefix, show the hidden text instead." (gnus-cache-request-article article group)) 'article) ;; Check the agent cache. - ((and gnus-agent gnus-agent-cache gnus-plugged - (numberp article) - (gnus-agent-request-article article group)) + ((gnus-agent-request-article article group) 'article) ;; Get the article and put into the article buffer. ((or (stringp article) diff --git a/lisp/gnus-cus.el b/lisp/gnus-cus.el index 715007d..cc1006b 100644 --- a/lisp/gnus-cus.el +++ b/lisp/gnus-cus.el @@ -29,6 +29,7 @@ (require 'wid-edit) (require 'gnus) +(require 'gnus-agent) (require 'gnus-score) (require 'gnus-topic) (require 'gnus-art) @@ -264,6 +265,62 @@ Server-assigned value attached to IMAP groups, used to maintain consistency.")) Each entry has the form (NAME TYPE DOC), where NAME is the parameter itself (a symbol), TYPE is the parameters type (a sexp widget), and DOC is a documentation string for the parameter.") + +(eval-and-compile + (defconst gnus-agent-parameters + '((agent-predicate + (sexp :tag "Selection Predicate" :value false) + "Predicate used to automatically select articles for downloading." + gnus-agent-cat-predicate) + (agent-score + (choice :tag "Score File" :value nil + (const file :tag "Use group's score files") + (repeat (list (string :format "%v" :tag "File name")))) + "Which score files to use when using score to select articles to fetch. + + `nil' + All articles will be scored to zero (0). + + `file' + The group's score files will be used to score the articles. + + `List' + A list of score file names." + gnus-agent-cat-score-file) + (agent-short-article + (integer :tag "Max Length of Short Article" :value "") + "The SHORT predicate will evaluate to true when the article is +shorter than this length." gnus-agent-cat-length-when-short) + (agent-long-article + (integer :tag "Min Length of Long Article" :value "") + "The LONG predicate will evaluate to true when the article is +longer than this length." gnus-agent-cat-length-when-long) + (agent-low-score + (integer :tag "Low Score Limit" :value "") + "The LOW predicate will evaluate to true when the article scores +lower than this limit." gnus-agent-cat-low-score) + (agent-high-score + (integer :tag "High Score Limit" :value "") + "The HIGH predicate will evaluate to true when the article scores +higher than this limit." gnus-agent-cat-high-score) + (agent-days-until-old + (integer :tag "Days Until Old" :value "") + "The OLD predicate will evaluate to true when the fetched article +has been stored locally for at least this many days." + gnus-agent-cat-days-until-old) + (agent-enable-expiration + (radio :tag "Expire in this Group or Topic" :value nil +; (const :format "Inherit " nil) + (const :format "Enable " ENABLE) + (const :format "Disable " DISABLE)) + "\nEnable, or disable, agent expiration in this group or topic." + gnus-agent-cat-enable-expiration) ) + "Alist of group parameters that are not also topic parameters. + +Each entry has the form (NAME TYPE DOC), where NAME is the parameter +itself (a symbol), TYPE is the parameters type (a sexp widget), and +DOC is a documentation string for the parameter.")) + (defvar gnus-custom-params) (defvar gnus-custom-method) (defvar gnus-custom-group) @@ -282,7 +339,25 @@ DOC is a documentation string for the parameter.") gnus-group-parameters (if group gnus-extra-group-parameters - gnus-extra-topic-parameters))))) + gnus-extra-topic-parameters)))) + (agent (mapcar (lambda (entry) + (let ((type (nth 1 entry)) + vcons) + (if (listp type) + (setq type (copy-sequence type))) + + (setq vcons (cdr (memq :value type))) + + (if (symbolp (car vcons)) + (condition-case nil + (setcar vcons (symbol-value (car vcons))) + (error))) + `(cons :format "%v%h\n" + :doc ,(nth 2 entry) + (const :format "" ,(nth 0 entry)) + ,type))) + (if gnus-agent + gnus-agent-parameters)))) (unless (or group topic) (error "No group on current line")) (when (and group topic) @@ -290,7 +365,7 @@ DOC is a documentation string for the parameter.") (unless (or topic (setq info (gnus-get-info group))) (error "Killed group; can't be edited")) ;; Ready. - (kill-buffer (gnus-get-buffer-create "*Gnus Customize*")) + (gnus-kill-buffer (gnus-get-buffer-create "*Gnus Customize*")) (switch-to-buffer (gnus-get-buffer-create "*Gnus Customize*")) (gnus-custom-mode) (make-local-variable 'gnus-custom-group) @@ -317,24 +392,57 @@ DOC is a documentation string for the parameter.") :action 'gnus-group-customize-done) (widget-insert ".\n\n") (make-local-variable 'gnus-custom-params) - (setq gnus-custom-params - (widget-create 'group - :value (if group - (gnus-info-params info) - (gnus-topic-parameters topic)) - `(set :inline t - :greedy t - :tag "Parameters" - :format "%t:\n%h%v" - :doc "\ + + (let* ((values (if group + (gnus-info-params info) + (gnus-topic-parameters topic)))) + + ;; The parameters in values may contain duplicates. This is + ;; normally OK as assq returns the first. However, right here + ;; every duplicate ends up being displayed. So, rather than + ;; display them, remove them from the list. + + (let (tmp) + (setq values (gnus-copy-sequence values) + tmp values) + + (while tmp + (setcdr tmp (delete-if (lambda (testing) (eq (caar tmp) + (car testing))) + (cdr tmp))) + (setq tmp (cdr tmp)))) + + (setq gnus-custom-params + (apply 'widget-create 'group + :value values + (delq nil + (list `(set :inline t + :greedy t + :tag "Parameters" + :format "%t:\n%h%v" + :doc "\ These special parameters are recognized by Gnus. Check the [ ] for the parameters you want to apply to this group or to the groups in this topic, then edit the value to suit your taste." - ,@types) - '(repeat :inline t - :tag "Variables" - :format "%t:\n%h%v%i\n\n" - :doc "\ + ,@types) + (when gnus-agent + `(set :inline t + :greedy t + :tag "Agent Parameters" + :format "%t:\n%h%v" + :doc "\ These agent parameters are +recognized by Gnus. They control article selection and expiration for +use in the unplugged cache. Check the [ ] for the parameters you want +to apply to this group or to the groups in this topic, then edit the +value to suit your taste. + +For those interested, group parameters override topic parameters while +topic parameters override agent category parameters. Underlying +category parameters are the customizable variables." ,@agent)) + '(repeat :inline t + :tag "Variables" + :format "%t:\n%h%v%i\n\n" + :doc "\ Set variables local to the group you are entering. If you want to turn threading off in `news.answers', you could put @@ -347,14 +455,14 @@ like. If you want to hear a beep when you enter a group, you could put something like `(dummy-variable (ding))' in the parameters of that group. `dummy-variable' will be set to the result of the `(ding)' form, but who cares?" - (list :format "%v" :value (nil nil) - (symbol :tag "Variable") - (sexp :tag - "Value"))) - - '(repeat :inline t - :tag "Unknown entries" - sexp))) + (list :format "%v" :value (nil nil) + (symbol :tag "Variable") + (sexp :tag + "Value"))) + + '(repeat :inline t + :tag "Unknown entries" + sexp)))))) (when group (widget-insert "\n\nYou can also edit the ") (widget-create 'info-link @@ -772,6 +880,163 @@ articles in the thread. (gnus-score-set 'touched '(t) alist)) (bury-buffer)) +(eval-when-compile + (defvar category-fields nil) + (defvar gnus-agent-cat-predicate nil) + (defvar gnus-agent-cat-score-file nil) + (defvar gnus-agent-cat-length-when-short nil) + (defvar gnus-agent-cat-length-when-long nil) + (defvar gnus-agent-cat-low-score nil) + (defvar gnus-agent-cat-high-score nil) + (defvar gnus-agent-cat-groups nil) + (defvar gnus-agent-cat-enable-expiration nil) + (defvar gnus-agent-cat-days-until-old nil) + (defvar gnus-agent-cat-name nil) +) + +(defun gnus-trim-whitespace (s) + (when (string-match "\\`[ \n\t]+" s) + (setq s (substring s (match-end 0)))) + (when (string-match "[ \n\t]+\\'" s) + (setq s (substring s 0 (match-beginning 0)))) + s) + +(defmacro gnus-agent-cat-prepare-category-field (parameter) + (let* ((entry (assq parameter gnus-agent-parameters)) + (field (nth 3 entry))) + `(let* ((type (copy-sequence + (nth 1 (assq ',parameter gnus-agent-parameters)))) + (val (,field info)) + (deflt (if (,field defaults) + (concat " [" (gnus-trim-whitespace + (pp-to-string (,field defaults))) "]")))) + + (if (eq (car type) 'radio) + (let* ((rtype (nreverse type)) + (rt rtype)) + (while (listp (or (cadr rt) 'not-list)) + (setq rt (cdr rt))) + + (setcdr rt (cons '(const :format "Inherit " nil) (cdr rt))) + (setq type (nreverse rtype)))) + + (if deflt + (let ((tag (cdr (memq :tag type)))) + (if (string-match "\n" deflt) + (progn (while (progn (setq deflt (replace-match "\n " t t + deflt)) + (string-match "\n" deflt (match-end 0)))) + (setq deflt (concat "\n" deflt)))) + + (setcar tag (concat (car tag) deflt)))) + + (widget-insert "\n") + + (set (make-local-variable ',field) + (if val + (widget-create type :value val) + (widget-create type))) + (widget-put ,field :default val) + (widget-put ,field :accessor ',field) + (push ,field category-fields)))) + +(defun gnus-agent-customize-category (category) + "Edit the CATEGORY." + (interactive (list (gnus-category-name))) + (let ((info (assq category gnus-category-alist)) + (defaults (list nil '(agent-predicate . false) + (cons 'agent-enable-expiration + gnus-agent-enable-expiration) + '(agent-days-until-old . 7) + (cons 'agent-length-when-short + gnus-agent-short-article) + (cons 'agent-length-when-long gnus-agent-long-article) + (cons 'agent-low-score gnus-agent-low-score) + (cons 'agent-high-score gnus-agent-high-score)))) + + (let ((old (get-buffer "*Gnus Agent Category Customize*"))) + (when old + (gnus-kill-buffer old))) + (switch-to-buffer (gnus-get-buffer-create + "*Gnus Agent Category Customize*")) + + (let ((inhibit-read-only t)) + (gnus-custom-mode) + (buffer-disable-undo) + + (let* ((name (gnus-agent-cat-name info))) + (widget-insert "Customize the Agent Category '") + (widget-insert (symbol-name name)) + (widget-insert "' and press ") + (widget-create + 'push-button + :notify + '(lambda (&rest ignore) + (let* ((info (assq gnus-agent-cat-name gnus-category-alist)) + (widgets category-fields)) + (while widgets + (let* ((widget (pop widgets)) + (value (ignore-errors (widget-value widget)))) + (eval `(setf (,(widget-get widget :accessor) ',info) + ',value))))) + (gnus-category-write) + (gnus-kill-buffer (current-buffer)) + (when (get-buffer gnus-category-buffer) + (switch-to-buffer (get-buffer gnus-category-buffer)) + (gnus-category-list))) + "Done") + (widget-insert + "\n Note: Empty fields default to the customizable global\ + variables.\n\n") + + (set (make-local-variable 'gnus-agent-cat-name) + name)) + + (set (make-local-variable 'category-fields) nil) + (gnus-agent-cat-prepare-category-field agent-predicate) + + (gnus-agent-cat-prepare-category-field agent-score) + (gnus-agent-cat-prepare-category-field agent-short-article) + (gnus-agent-cat-prepare-category-field agent-long-article) + (gnus-agent-cat-prepare-category-field agent-low-score) + (gnus-agent-cat-prepare-category-field agent-high-score) + + ;; The group list is NOT handled with + ;; gnus-agent-cat-prepare-category-field as I don't want the + ;; group list to appear when customizing a topic. + (widget-insert "\n") + (set (make-local-variable 'gnus-agent-cat-groups) + (widget-create + `(choice + :format "%[Select Member Groups%]\n%v" :value ignore + (const :menu-tag "do not change" :tag "" :value ignore) + (checklist :entry-format "%b %v" + :menu-tag "display group selectors" + :greedy t + :value ,(delq nil + (mapcar + (lambda (newsrc) + (car (member + (gnus-info-group newsrc) + (gnus-agent-cat-groups info)))) + (cdr gnus-newsrc-alist))) + ,@(mapcar (lambda (newsrc) + `(const ,(gnus-info-group newsrc))) + (cdr gnus-newsrc-alist)))))) + + (widget-put gnus-agent-cat-groups :default (gnus-agent-cat-groups info)) + (widget-put gnus-agent-cat-groups :accessor 'gnus-agent-cat-groups) + (push gnus-agent-cat-groups category-fields) + + (widget-insert "\nExpiration Settings ") + + (gnus-agent-cat-prepare-category-field agent-enable-expiration) + (gnus-agent-cat-prepare-category-field agent-days-until-old) + + (use-local-map widget-keymap) + (widget-setup) + (buffer-enable-undo)))) + ;;; The End: (provide 'gnus-cus) diff --git a/lisp/gnus-int.el b/lisp/gnus-int.el index aa90e6a..b9afda8 100644 --- a/lisp/gnus-int.el +++ b/lisp/gnus-int.el @@ -348,7 +348,7 @@ If FETCH-OLD, retrieve all headers (or some subset thereof) in the group." (cond ((and gnus-use-cache (numberp (car articles))) (gnus-cache-retrieve-headers articles group fetch-old)) - ((and gnus-agent gnus-agent-cache (gnus-online gnus-command-method) + ((and gnus-agent (gnus-online gnus-command-method) (gnus-agent-method-p gnus-command-method)) (gnus-agent-retrieve-headers articles group fetch-old)) (t @@ -420,9 +420,7 @@ If BUFFER, insert the article in that group." (setq res (cons group article) clean-up t)) ;; Check the agent cache. - ((and gnus-agent gnus-agent-cache gnus-plugged - (numberp article) - (gnus-agent-request-article article group)) + ((gnus-agent-request-article article group) (setq res (cons group article) clean-up t)) ;; Use `head' function. @@ -455,9 +453,7 @@ If BUFFER, insert the article in that group." (setq res (cons group article) clean-up t)) ;; Check the agent cache. - ((and gnus-agent gnus-agent-cache gnus-plugged - (numberp article) - (gnus-agent-request-article article group)) + ((gnus-agent-request-article article group) (setq res (cons group article) clean-up t)) ;; Use `head' function. @@ -527,7 +523,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." (gnus-get-function gnus-command-method 'request-expire-articles) articles (gnus-group-real-name group) (nth 1 gnus-command-method) force))) - (when (and gnus-agent gnus-agent-cache + (when (and gnus-agent (gnus-agent-method-p gnus-command-method)) (let ((expired-articles (gnus-sorted-difference articles not-deleted))) (when expired-articles @@ -541,7 +537,7 @@ If GROUP is nil, all groups on GNUS-COMMAND-METHOD are scanned." 'request-move-article) article (gnus-group-real-name group) (nth 1 gnus-command-method) accept-function last))) - (when (and result gnus-agent gnus-agent-cache + (when (and result gnus-agent (gnus-agent-method-p gnus-command-method)) (gnus-agent-expire (list article) group 'force)) result)) diff --git a/lisp/gnus-start.el b/lisp/gnus-start.el index 1105790..60039cd 100644 --- a/lisp/gnus-start.el +++ b/lisp/gnus-start.el @@ -58,6 +58,15 @@ variable." (const :tag "If existing" nil) (other :tag "Always" t))) +(defcustom gnus-save-startup-file-via-temp-buffer t + "Whether to write the startup file contents to a buffer then save +the buffer or write directly to the file. The buffer is faster +because all of the contents are written at once. The direct write +uses considerably less memory." + :group 'gnus-start + :type '(choice (const :tag "Write via buffer" t) + (const :tag "Write directly to file" nil))) + (defcustom gnus-init-file (nnheader-concat gnus-home-directory ".gnus") "Your Gnus Emacs-Lisp startup file name. If a file with the `.el' or `.elc' suffixes exists, it will be read instead." @@ -613,16 +622,21 @@ the first newsgroup." ;;; General various misc type functions. ;; Silence byte-compiler. -(defvar gnus-current-headers) -(defvar gnus-thread-indent-array) -(defvar gnus-newsgroup-name) -(defvar gnus-newsgroup-headers) -(defvar gnus-group-list-mode) -(defvar gnus-group-mark-positions) -(defvar gnus-newsgroup-data) -(defvar gnus-newsgroup-unreads) -(defvar nnoo-state-alist) -(defvar gnus-current-select-method) +(eval-when-compile + (defvar gnus-current-headers) + (defvar gnus-thread-indent-array) + (defvar gnus-newsgroup-name) + (defvar gnus-newsgroup-headers) + (defvar gnus-group-list-mode) + (defvar gnus-group-mark-positions) + (defvar gnus-newsgroup-data) + (defvar gnus-newsgroup-unreads) + (defvar nnoo-state-alist) + (defvar gnus-current-select-method) + (defvar mail-sources) + (defvar nnmail-scan-directory-mail-source-once) + (defvar nnmail-split-history) + (defvar nnmail-spool-file)) (defun gnus-clear-quick-file-variables () "Clear all variables in quick startup files." @@ -1486,7 +1500,7 @@ newsgroup." t) (if (or debug-on-error debug-on-quit) (inline (gnus-request-group group dont-check method)) - (condition-case () + (condition-case nil (inline (gnus-request-group group dont-check method)) ;;(error nil) (quit @@ -2595,6 +2609,12 @@ If FORCE is non-nil, the .newsrc file is read." (setq gnus-newsrc-options-n out)))) +(eval-and-compile + (defalias 'gnus-long-file-names + (if (fboundp 'msdos-long-file-names) + 'msdos-long-file-names + (lambda () t)))) + (defun gnus-save-newsrc-file (&optional force) "Save .newsrc file." ;; Note: We cannot save .newsrc file if all newsgroups are removed @@ -2627,10 +2647,58 @@ If FORCE is non-nil, the .newsrc file is read." (setq default-directory (file-name-directory buffer-file-name)) (buffer-disable-undo) (erase-buffer) - (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) - (gnus-gnus-to-quick-newsrc-format) - (gnus-run-hooks 'gnus-save-quick-newsrc-hook) - (save-buffer-as-coding-system gnus-ding-file-coding-system) + (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file) + + (if gnus-save-startup-file-via-temp-buffer + (let ((coding-system-for-write gnus-ding-file-coding-system) + (output-coding-system gnus-ding-file-coding-system) + (standard-output (current-buffer))) + (gnus-gnus-to-quick-newsrc-format) + (gnus-run-hooks 'gnus-save-quick-newsrc-hook) + (save-buffer)) + (let ((coding-system-for-write gnus-ding-file-coding-system) + (output-coding-system gnus-ding-file-coding-system) + (version-control gnus-backup-startup-file) + (startup-file (concat gnus-current-startup-file ".eld")) + (working-dir (file-name-directory gnus-current-startup-file)) + working-file + (i -1)) + ;; Generate the name of a non-existent file. + (while (progn (setq working-file + (format + (if (and (eq system-type 'ms-dos) + (not (gnus-long-file-names))) + "%s#%d.tm#" ; MSDOS limits files to 8+3 + (if (memq system-type '(vax-vms axp-vms)) + "%s$tmp$%d" + "%s#tmp#%d")) + working-dir (setq i (1+ i)))) + (file-exists-p working-file))) + + (unwind-protect + (progn + (gnus-with-output-to-file + working-file + (gnus-gnus-to-quick-newsrc-format) + (gnus-run-hooks 'gnus-save-quick-newsrc-hook)) + + ;; These bindings will mislead the current buffer + ;; into thinking that it is visiting the startup + ;; file. + (let ((buffer-backed-up nil) + (buffer-file-name startup-file) + (file-precious-flag t) + (setmodes (file-modes startup-file))) + ;; Backup the current version of the startup file. + (backup-buffer) + + ;; Replace the existing startup file with the temp file. + (rename-file working-file startup-file t) + (set-file-modes startup-file setmodes))) + (condition-case nil + (delete-file working-file) + (file-error nil))))) + (gnus-kill-buffer (current-buffer)) (gnus-message 5 "Saving %s.eld...done" gnus-current-startup-file)) @@ -2649,17 +2717,15 @@ If FORCE is non-nil, the .newsrc file is read." (gnus-save-newsrc-file))) (defun gnus-gnus-to-quick-newsrc-format () - "Insert Gnus variables such as gnus-newsrc-alist in lisp format." - (let ((print-quoted t) - (print-escape-newlines t)) - - (insert ";; -*- emacs-lisp -*-\n") - (insert ";; Gnus startup file.\n") - (insert "\ + "Print Gnus variables such as gnus-newsrc-alist in lisp format." + (princ ";; -*- emacs-lisp -*-\n") + (princ ";; Gnus startup file.\n") + (princ "\ ;; Never delete this file -- if you want to force Gnus to read the ;; .newsrc file (if you have one), touch .newsrc instead.\n") - (insert "(setq gnus-newsrc-file-version " - (gnus-prin1-to-string gnus-version) ")\n") + (princ "(setq gnus-newsrc-file-version ") + (princ (gnus-prin1-to-string gnus-version)) + (princ ")\n") (let* ((gnus-killed-list (if (and gnus-save-killed-list (stringp gnus-save-killed-list)) @@ -2677,9 +2743,11 @@ If FORCE is non-nil, the .newsrc file is read." (while variables (when (and (boundp (setq variable (pop variables))) (symbol-value variable)) - (insert "(setq " (symbol-name variable) " '") - (gnus-prin1 (symbol-value variable)) - (insert ")\n")))))) + (princ "(setq ") + (princ (symbol-name variable)) + (princ " '") + (prin1 (symbol-value variable)) + (princ ")\n"))))) (defun gnus-product-variable-touch (&rest variables) (while variables @@ -3001,10 +3069,12 @@ If this variable is nil, don't do anything." (file-name-as-directory (expand-file-name gnus-default-directory)) default-directory))) -(defun gnus-display-time-event-handler () - "Like `display-time-event-handler', but test `display-time-timer'." - (when (gnus-boundp 'display-time-timer) - (display-time-event-handler))) +(eval-and-compile +(defalias 'gnus-display-time-event-handler + (if (gnus-boundp 'display-time-timer) + 'display-time-event-handler + (lambda () "Does nothing as `display-time-timer' is not bound. +Would otherwise be an alias for `display-time-event-handler'." nil)))) ;;;###autoload (defun gnus-fixup-nnimap-unread-after-getting-new-news () diff --git a/lisp/gnus-util.el b/lisp/gnus-util.el index dd785d9..3c93af5 100644 --- a/lisp/gnus-util.el +++ b/lisp/gnus-util.el @@ -1078,6 +1078,32 @@ Return the modified alist." (while (search-backward "\\." nil t) (delete-char 1))))) +(defmacro gnus-with-output-to-file (file &rest body) + (let ((buffer (make-symbol "output-buffer")) + (size (make-symbol "output-buffer-size")) + (leng (make-symbol "output-buffer-length"))) + `(let* ((print-quoted t) + (print-readably t) + (print-escape-multibyte nil) + print-level + print-length + (,size 131072) + (,buffer (make-string ,size 0)) + (,leng 0) + (append nil) + (standard-output (lambda (c) + (aset ,buffer ,leng c) + (if (= ,size (setq ,leng (1+ ,leng))) + (progn (write-region ,buffer nil ,file append 'no-msg) + (setq ,leng 0 + append t)))))) + ,@body + (if (> ,leng 0) + (write-region (substring ,buffer 0 ,leng) nil ,file append 'no-msg))))) + +(put 'gnus-with-output-to-file 'lisp-indent-function 1) +(put 'gnus-with-output-to-file 'edebug-form-spec '(form body)) + (if (fboundp 'union) (defalias 'gnus-union 'union) (defun gnus-union (l1 l2) diff --git a/lisp/gnus.el b/lisp/gnus.el index 3ceb041..2030ffb 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -674,9 +674,9 @@ be set in `.emacs' instead." (defface gnus-summary-high-undownloaded-face '((((class color) (background light)) - (:bold t :foreground "cyan4" :bold nil)) + (:bold t :foreground "cyan4")) (((class color) (background dark)) - (:bold t :foreground "LightGray" :bold nil)) + (:bold t :foreground "LightGray")) (t (:inverse-video t :bold t))) "Face used for high interest uncached articles.") @@ -2109,8 +2109,9 @@ face." "Whether Gnus is plugged or not.") (defcustom gnus-agent-cache t - "Whether Gnus use agent cache. -You also need to enable `gnus-agent'." + "Controls use of the agent cache while plugged. When set, Gnus will prefer +using the locally stored content rather than re-fetching it from the server. +You also need to enable `gnus-agent' for this to have any affect." :version "21.3" :group 'gnus-agent :type 'boolean) diff --git a/lisp/nnkiboze.el b/lisp/nnkiboze.el index eb524c7..928165b 100644 --- a/lisp/nnkiboze.el +++ b/lisp/nnkiboze.el @@ -110,7 +110,7 @@ (setq num (string-to-int (match-string 2 xref)) group (match-string 1 xref)) (or (with-current-buffer buffer - (or (gnus-cache-request-article num group) + (or (and gnus-use-cache (gnus-cache-request-article num group)) (gnus-agent-request-article num group))) (gnus-request-article num group buffer))))) diff --git a/lisp/nntp.el b/lisp/nntp.el index 6fabd71..fb1bca6 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -1395,16 +1395,18 @@ password contained in '~/.nntp-authinfo'." (when group (let ((entry (nntp-find-connection-entry nntp-server-buffer))) - (when (not (equal group (caddr entry))) - (save-excursion - (set-buffer (process-buffer (car entry))) - (erase-buffer) - (nntp-send-command "^[245].*\n" "GROUP" group) - (setcar (cddr entry) group) - (erase-buffer) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer))))))) + (cond ((not entry) + (nntp-report "Server closed connection")) + ((not (equal group (caddr entry))) + (save-excursion + (set-buffer (process-buffer (car entry))) + (erase-buffer) + (nntp-send-command "^[245].*\n" "GROUP" group) + (setcar (cddr entry) group) + (erase-buffer) + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer)))))))) (defun nntp-decode-text (&optional cr-only) "Decode the text in the current buffer." -- 1.7.10.4