X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=1c54c9e82986d8bc0be3a7e82e443d60835ca8d7;hb=38a0bc6bb8859d74138a40245566b7e8753ebfc9;hp=18397bcd0131a1b95ee17ddd2261bcba5c36ac1e;hpb=390628388e3244a659321e45ec7ac66d83f3c01a;p=gnus diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 18397bcd0..1c54c9e82 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -26,6 +26,7 @@ (require 'gnus) (require 'gnus-cache) +(require 'nnmail) (require 'nnvirtual) (require 'gnus-sum) (require 'gnus-score) @@ -69,11 +70,9 @@ (defcustom gnus-agent-expire-days 7 "Read articles older than this will be expired. -This can also be a list of regexp/day pairs. The regexps will be -matched against group names." +If you wish to disable Agent expiring, see `gnus-agent-enable-expiration'." :group 'gnus-agent - :type '(choice (number :tag "days") - (sexp :tag "List" nil))) + :type '(number :tag "days")) (defcustom gnus-agent-expire-all nil "If non-nil, also expire unread, ticked and dormant articles. @@ -145,7 +144,13 @@ If this is `ask' the hook will query the user." :group 'gnus-agent) (defcustom gnus-agent-consider-all-articles nil - "If non-nil, consider also the read articles for downloading." + "When non-`nil', the agent will let the agent predicate decide +whether articles need to be downloaded or not, for all articles. When +`nil', the default, the agent will only let the predicate decide +whether unread articles are downloaded or not. If you enable this, +groups with large active ranges may open slower and you may also want +to look into the agent expiry settings to block the expiration of +read articles as they would just be downloaded again." :version "21.4" :type 'boolean :group 'gnus-agent) @@ -168,6 +173,36 @@ enable expiration per categories, topics, and groups." :type '(radio (const :format "Enable " ENABLE) (const :format "Disable " DISABLE))) +(defcustom gnus-agent-expire-unagentized-dirs t + "*Whether expiration should expire in unagentized directories. +Have gnus-agent-expire scan the directories under +\(gnus-agent-directory) for groups that are no longer agentized. +When found, offer to remove them." + :type 'boolean + :group 'gnus-agent) + +(defcustom gnus-agent-auto-agentize-methods '(nntp nnimap) + "Initially, all servers from these methods are agentized. +The user may remove or add servers using the Server buffer. +See Info node `(gnus)Server Buffer'." + :type '(repeat symbol) + :group 'gnus-agent) + +(defcustom gnus-agent-queue-mail t + "Whether and when outgoing mail should be queued by the agent. When +`always', always queue outgoing mail. When `nil', never queue. +Otherwise, queue if and only if unplugged." + :group 'gnus-agent + :type '(radio (const :format "Always" always) + (const :format "Never" nil) + (const :format "When plugged" t))) + +(defcustom gnus-agent-prompt-send-queue nil + "If non-nil, `gnus-group-send-queue' will prompt if called when +unplugged." + :group 'gnus-agent + :type 'boolean) + ;;; Internal variables (defvar gnus-agent-history-buffers nil) @@ -196,11 +231,6 @@ NOTES: (defvar gnus-agent-file-loading-cache nil) (defvar gnus-agent-file-header-cache nil) -(defvar gnus-agent-auto-agentize-methods '(nntp nnimap) - "Initially, all servers from these methods are agentized. -The user may remove or add servers using the Server buffer. See Info -node `(gnus)Server Buffer'.") - ;; Dynamic variables (defvar gnus-headers) (defvar gnus-score) @@ -278,56 +308,61 @@ node `(gnus)Server Buffer'.") (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 +(eval-when-compile + (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 - ))))) + `(progn (defmacro ,name (category) + (list (quote cdr) (list (quote assq) + (quote (quote ,prop-name)) category))) + + (define-setf-method ,name (category) + (let* ((--category--temp-- (make-symbol "--category--")) + (--value--temp-- (make-symbol "--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-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-enable-expiration agent-enable-expiration) + gnus-agent-cat-groups agent-groups) (gnus-agent-cat-defaccessor - gnus-agent-cat-groups agent-groups) + gnus-agent-cat-high-score agent-high-score) (gnus-agent-cat-defaccessor - gnus-agent-cat-high-score agent-high-score) + gnus-agent-cat-length-when-long agent-length-when-long) (gnus-agent-cat-defaccessor - gnus-agent-cat-length-when-long agent-length-when-long) + gnus-agent-cat-length-when-short agent-length-when-short) (gnus-agent-cat-defaccessor - gnus-agent-cat-length-when-short agent-length-when-short) + gnus-agent-cat-low-score agent-low-score) (gnus-agent-cat-defaccessor - gnus-agent-cat-low-score agent-low-score) + gnus-agent-cat-predicate agent-predicate) (gnus-agent-cat-defaccessor - gnus-agent-cat-predicate agent-predicate) + gnus-agent-cat-score-file agent-score-file) (gnus-agent-cat-defaccessor - gnus-agent-cat-score-file agent-score-file) + gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) -(defsetf gnus-agent-cat-groups (category) (groups) - (list 'gnus-agent-set-cat-groups category groups)) +(eval-and-compile + (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) @@ -362,8 +397,8 @@ manipulated as follows: (setcdr category (cons cell (cdr category))) cell)) groups)))))) -(defsubst gnus-agent-cat-make (name) - (list name '(agent-predicate . false))) +(defsubst gnus-agent-cat-make (name &optional default-agent-predicate) + (list name `(agent-predicate . ,(or default-agent-predicate 'false)))) ;;; Fetching setup functions. @@ -392,6 +427,10 @@ manipulated as follows: (defmacro gnus-agent-append-to-list (tail value) `(setq ,tail (setcdr ,tail (cons ,value nil)))) +(defmacro gnus-agent-message (level &rest args) + `(if (<= ,level gnus-verbose) + (message ,@args))) + ;;; ;;; Mode infestation ;;; @@ -421,7 +460,8 @@ manipulated as follows: buffer)))) minor-mode-map-alist)) (when (eq major-mode 'gnus-group-mode) - (let ((init-plugged gnus-plugged)) + (let ((init-plugged gnus-plugged) + (gnus-agent-go-online nil)) ;; g-a-t-p does nothing when gnus-plugged isn't changed. ;; Therefore, make certain that the current value does not ;; match the desired initial value. @@ -540,7 +580,7 @@ manipulated as follows: (defun gnus-agent-close-connections () "Close all methods covered by the Gnus agent." - (let ((methods gnus-agent-covered-methods)) + (let ((methods (gnus-agent-covered-methods))) (while methods (gnus-close-server (pop methods))))) @@ -568,10 +608,10 @@ manipulated as follows: ;;;###autoload (defun gnus-agentize () "Allow Gnus to be an offline newsreader. -The normal usage of this command is to put the following as the -last form in your `.gnus.el' file: -\(gnus-agentize) +The gnus-agentize function is now called internally by gnus when +gnus-agent is set. If you wish to avoid calling gnus-agentize, +customize gnus-agent to nil. This will modify the `gnus-setup-news-hook', and `message-send-mail-real-function' variables, and install the Gnus agent @@ -582,30 +622,41 @@ minor mode in all Gnus buffers." (unless gnus-agent-send-mail-function (setq gnus-agent-send-mail-function (or message-send-mail-real-function - message-send-mail-function) + message-send-mail-function) message-send-mail-real-function 'gnus-agent-send-mail)) - (unless gnus-agent-covered-methods - (mapcar - (lambda (server) - (if (memq (car (gnus-server-to-method server)) - gnus-agent-auto-agentize-methods) - (setq gnus-agent-covered-methods - (cons (gnus-server-to-method server) - gnus-agent-covered-methods )))) - (append (list gnus-select-method) gnus-secondary-select-methods)))) - -(defun gnus-agent-queue-setup () - "Make sure the queue group exists." - (unless (gnus-gethash "nndraft:queue" gnus-newsrc-hashtb) - (gnus-request-create-group "queue" '(nndraft "")) + ;; If the servers file doesn't exist, auto-agentize some servers and + ;; save the servers file so this auto-agentizing isn't invoked + ;; again. + (unless (file-exists-p (nnheader-concat gnus-agent-directory "lib/servers")) + (gnus-message 3 "First time agent user, agentizing remote groups...") + (mapc + (lambda (server-or-method) + (let ((method (gnus-server-to-method server-or-method))) + (when (memq (car method) + gnus-agent-auto-agentize-methods) + (push (gnus-method-to-server method) + gnus-agent-covered-methods) + (setq gnus-agent-method-p-cache nil)))) + (cons gnus-select-method gnus-secondary-select-methods)) + (gnus-agent-write-servers))) + +(defun gnus-agent-queue-setup (&optional group-name) + "Make sure the queue group exists. +Optional arg GROUP-NAME allows to specify another group." + (unless (gnus-gethash (format "nndraft:%s" (or group-name "queue")) + gnus-newsrc-hashtb) + (gnus-request-create-group (or group-name "queue") '(nndraft "")) (let ((gnus-level-default-subscribed 1)) - (gnus-subscribe-group "nndraft:queue" nil '(nndraft ""))) + (gnus-subscribe-group (format "nndraft:%s" (or group-name "queue")) + nil '(nndraft ""))) (gnus-group-set-parameter - "nndraft:queue" 'gnus-dummy '((gnus-draft-mode))))) + (format "nndraft:%s" (or group-name "queue")) + 'gnus-dummy '((gnus-draft-mode))))) (defun gnus-agent-send-mail () - (if gnus-plugged + (if (or (not gnus-agent-queue-mail) + (and gnus-plugged (not (eq gnus-agent-queue-mail 'always)))) (funcall gnus-agent-send-mail-function) (goto-char (point-min)) (re-search-forward @@ -727,7 +778,7 @@ be a select method." "Synchronize unplugged flags with servers." (interactive) (save-excursion - (dolist (gnus-command-method gnus-agent-covered-methods) + (dolist (gnus-command-method (gnus-agent-covered-methods)) (when (file-exists-p (gnus-agent-lib-file "flags")) (gnus-agent-synchronize-flags-server gnus-command-method))))) @@ -735,7 +786,7 @@ be a select method." "Synchronize flags according to `gnus-agent-synchronize-flags'." (interactive) (save-excursion - (dolist (gnus-command-method gnus-agent-covered-methods) + (dolist (gnus-command-method (gnus-agent-covered-methods)) (when (file-exists-p (gnus-agent-lib-file "flags")) (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) @@ -770,46 +821,80 @@ be a select method." ;;; Server mode commands ;;; -(defun gnus-agent-add-server (server) +(defun gnus-agent-add-server () "Enroll SERVER in the agent program." - (interactive (list (gnus-server-server-name))) - (unless server - (error "No server on the current line")) - (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) + (interactive) + (let* ((server (gnus-server-server-name)) + (named-server (gnus-server-named-server)) + (method (and server + (gnus-server-get-method nil server)))) + (unless server + (error "No server on the current line")) + (when (gnus-agent-method-p method) (error "Server already in the agent program")) - (push method gnus-agent-covered-methods) + + (push named-server gnus-agent-covered-methods) + + (setq gnus-agent-method-p-cache nil) (gnus-server-update-server server) (gnus-agent-write-servers) (gnus-message 1 "Entered %s into the Agent" server))) -(defun gnus-agent-remove-server (server) +(defun gnus-agent-remove-server () "Remove SERVER from the agent program." - (interactive (list (gnus-server-server-name))) - (unless server - (error "No server on the current line")) - (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) - (unless (gnus-agent-method-p method) + (interactive) + (let* ((server (gnus-server-server-name)) + (named-server (gnus-server-named-server))) + (unless server + (error "No server on the current line")) + + (unless (member named-server gnus-agent-covered-methods) (error "Server not in the agent program")) - (setq gnus-agent-covered-methods - (delete method gnus-agent-covered-methods)) + + (setq gnus-agent-covered-methods + (delete named-server gnus-agent-covered-methods) + gnus-agent-method-p-cache nil) + (gnus-server-update-server server) (gnus-agent-write-servers) (gnus-message 1 "Removed %s from the agent" server))) (defun gnus-agent-read-servers () "Read the alist of covered servers." - (mapcar (lambda (m) - (let ((method (gnus-server-get-method - nil - (or m "native")))) - (if method - (unless (member method gnus-agent-covered-methods) - (push method gnus-agent-covered-methods)) - (gnus-message 1 "Ignoring disappeared server `%s'" m) - (sit-for 1)))) - (gnus-agent-read-file - (nnheader-concat gnus-agent-directory "lib/servers")))) + (setq gnus-agent-covered-methods + (gnus-agent-read-file + (nnheader-concat gnus-agent-directory "lib/servers")) + gnus-agent-method-p-cache nil) + + ;; I am called so early in start-up that I can not validate server + ;; names. When that is the case, I skip the validation. That is + ;; alright as the gnus startup code calls the validate methods + ;; directly. + (if gnus-server-alist + (gnus-agent-read-servers-validate))) + +(defun gnus-agent-read-servers-validate () + (mapcar (lambda (server-or-method) + (let* ((server (if (stringp server-or-method) + server-or-method + (gnus-method-to-server server-or-method))) + (method (gnus-server-to-method server))) + (if method + (unless (member server gnus-agent-covered-methods) + (push server gnus-agent-covered-methods) + (setq gnus-agent-method-p-cache nil)) + (gnus-message 1 "Ignoring disappeared server `%s'" server)))) + (prog1 gnus-agent-covered-methods + (setq gnus-agent-covered-methods nil)))) + +(defun gnus-agent-read-servers-validate-native (native-method) + (setq gnus-agent-covered-methods + (mapcar (lambda (method) + (if (or (not method) + (equal method native-method)) + "native" + method)) gnus-agent-covered-methods))) (defun gnus-agent-write-servers () "Write the alist of covered servers." @@ -817,7 +902,7 @@ be a select method." (let ((coding-system-for-write nnheader-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) (with-temp-file (nnheader-concat gnus-agent-directory "lib/servers") - (prin1 (mapcar 'gnus-method-simplify gnus-agent-covered-methods) + (prin1 gnus-agent-covered-methods (current-buffer))))) ;;; @@ -892,6 +977,7 @@ article's mark is toggled." (headers (sort (mapcar (lambda (h) (mail-header-number h)) gnus-newsgroup-headers) '<)) + (cached (and gnus-use-cache gnus-newsgroup-cached)) (undownloaded (list nil)) (tail-undownloaded undownloaded) (unfetched (list nil)) @@ -902,23 +988,30 @@ article's mark is toggled." (cond ((< a h) ;; Ignore IDs in the alist that are not being ;; displayed in the summary. - (pop alist)) + (setq alist (cdr alist))) ((> a h) ;; Headers that are not in the alist should be ;; fictious (see nnagent-retrieve-headers); they ;; imply that this article isn't in the agent. (gnus-agent-append-to-list tail-undownloaded h) (gnus-agent-append-to-list tail-unfetched h) - (pop headers)) + (setq headers (cdr headers))) ((cdar alist) - (pop alist) - (pop headers) + (setq alist (cdr alist)) + (setq headers (cdr headers)) nil ; ignore already downloaded ) (t - (pop alist) - (pop headers) - (gnus-agent-append-to-list tail-undownloaded a))))) + (setq alist (cdr alist)) + (setq headers (cdr headers)) + + ;; This article isn't in the agent. Check to see + ;; if it is in the cache. If it is, it's been + ;; downloaded. + (while (and cached (< (car cached) a)) + (setq cached (cdr cached))) + (unless (equal a (car cached)) + (gnus-agent-append-to-list tail-undownloaded a)))))) (while headers (let ((num (pop headers))) @@ -995,10 +1088,6 @@ Optional arg ALL, if non-nil, means to fetch all articles." (setq gnus-newsgroup-downloadable (delq article gnus-newsgroup-downloadable)) - ;; The downloadable mark is implemented as a - ;; type of read mark. Therefore, marking the - ;; article as unread is sufficient to clear - ;; its downloadable flag. (gnus-summary-mark-article article gnus-unread-mark)) (was-marked-downloadable (gnus-summary-set-agent-mark article t))) @@ -1024,87 +1113,130 @@ This can be added to `gnus-select-article-hook' or ;;; (defun gnus-agent-save-active (method) - (gnus-agent-save-active-1 method 'gnus-active-to-gnus-format)) - -(defun gnus-agent-save-active-1 (method function) (when (gnus-agent-method-p method) (let* ((gnus-command-method method) (new (gnus-make-hashtable (count-lines (point-min) (point-max)))) (file (gnus-agent-lib-file "active"))) - (funcall function nil new) + (gnus-active-to-gnus-format nil new) (gnus-agent-write-active file new) (erase-buffer) (nnheader-insert-file-contents file)))) (defun gnus-agent-write-active (file new) - (let ((orig (gnus-make-hashtable (count-lines (point-min) (point-max)))) - (file (gnus-agent-lib-file "active")) - elem osym) - (when (file-exists-p file) - (with-temp-buffer - (nnheader-insert-file-contents file) - (gnus-active-to-gnus-format nil orig)) - (mapatoms - (lambda (sym) - (when (and sym (boundp sym)) - (if (and (boundp (setq osym (intern (symbol-name sym) orig))) - (setq elem (symbol-value osym))) - (progn - (if (and (integerp (car (symbol-value sym))) - (> (car elem) (car (symbol-value sym)))) - (setcar elem (car (symbol-value sym)))) - (if (integerp (cdr (symbol-value sym))) - (setcdr elem (cdr (symbol-value sym))))) - (set (intern (symbol-name sym) orig) (symbol-value sym))))) - new)) (gnus-make-directory (file-name-directory file)) (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system)) - ;; The hashtable contains real names of groups, no more prefix - ;; removing, so set `full' to `t'. - (gnus-write-active-file file orig t)))) - -(defun gnus-agent-save-groups (method) - (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format)) + ;; The hashtable contains real names of groups. However, do NOT + ;; add the foreign server prefix as gnus-active-to-gnus-format + ;; will add it while reading the file. + (gnus-write-active-file file new nil))) + +(defun gnus-agent-possibly-alter-active (group active &optional info) + "Possibly expand a group's active range to include articles +downloaded into the agent." + (let* ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group)))) + (when (gnus-agent-method-p gnus-command-method) + (let* ((local (gnus-agent-get-local group)) + (active-min (car active)) + (active-max (cdr active)) + (agent-min (or (car local) active-min)) + (agent-max (or (cdr local) active-max))) + + (when (< agent-min active-min) + (setcar active agent-min)) + + (when (> agent-max active-max) + (setcdr active agent-max)) + + (when (and info (< agent-max (- active-min 100))) + ;; I'm expanding the active range by such a large amount + ;; that there is a gap of more than 100 articles between the + ;; last article known to the agent and the first article + ;; currently available on the server. This gap contains + ;; articles that have been lost, mark them as read so that + ;; gnus doesn't waste resources trying to fetch them. + + ;; NOTE: I don't do this for smaller gaps (< 100) as I don't + ;; want to modify the local file everytime someone restarts + ;; gnus. The small gap will cause a tiny performance hit + ;; when gnus tries, and fails, to retrieve the articles. + ;; Still that should be smaller than opening a buffer, + ;; printing this list to the buffer, and then writing it to a + ;; file. + + (let ((read (gnus-info-read info))) + (gnus-info-set-read + info + (gnus-range-add + read + (list (cons (1+ agent-max) + (1- active-min)))))) + + ;; Lie about the agent's local range for this group to + ;; disable the set read each time this server is opened. + ;; NOTE: Opening this group will restore the valid local + ;; range but it will also expand the local range to + ;; incompass the new active range. + (gnus-agent-set-local group agent-min (1- active-min))))))) (defun gnus-agent-save-group-info (method group active) + "Update a single group's active range in the agent's copy of the server's active file." (when (gnus-agent-method-p method) (let* ((gnus-command-method method) (coding-system-for-write nnheader-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system) (file (gnus-agent-lib-file "active")) - oactive-min) + oactive-min oactive-max) (gnus-make-directory (file-name-directory file)) (with-temp-file file ;; Emacs got problem to match non-ASCII group in multibyte buffer. (mm-disable-multibyte) (when (file-exists-p file) - (nnheader-insert-file-contents file)) - (goto-char (point-min)) - (when (re-search-forward - (concat "^" (regexp-quote group) " ") nil t) - (save-excursion - (read (current-buffer)) ;; max - (setq oactive-min (read (current-buffer)))) ;; min - (gnus-delete-line)) + (nnheader-insert-file-contents file) + + (goto-char (point-min)) + (when (re-search-forward + (concat "^" (regexp-quote group) " ") nil t) + (save-excursion + (setq oactive-max (read (current-buffer)) ;; max + oactive-min (read (current-buffer)))) ;; min + (gnus-delete-line))) (insert (format "%S %d %d y\n" (intern group) - (cdr active) - (or oactive-min (car active)))) + (max (or oactive-max (cdr active)) (cdr active)) + (min (or oactive-min (car active)) (car active)))) (goto-char (point-max)) (while (search-backward "\\." nil t) (delete-char 1)))))) (defun gnus-agent-group-path (group) "Translate GROUP into a file name." - (if nnmail-use-long-file-names - (gnus-group-real-name group) - (nnheader-translate-file-chars - (nnheader-replace-chars-in-string - (nnheader-replace-duplicate-chars-in-string - (nnheader-replace-chars-in-string - (gnus-group-real-name group) - ?/ ?_) - ?. ?_) - ?. ?/)))) + + ;; NOTE: This is what nnmail-group-pathname does as of Apr 2003. + ;; The two methods must be kept synchronized, which is why + ;; gnus-agent-group-pathname was added. + + (setq group + (nnheader-translate-file-chars + (nnheader-replace-duplicate-chars-in-string + (nnheader-replace-chars-in-string + (gnus-group-real-name group) + ?/ ?_) + ?. ?_))) + (if (or nnmail-use-long-file-names + (file-directory-p (expand-file-name group (gnus-agent-directory)))) + group + (mm-encode-coding-string + (nnheader-replace-chars-in-string group ?. ?/) + nnmail-pathname-coding-system))) + +(defun gnus-agent-group-pathname (group) + "Translate GROUP into a file name." + ;; nnagent uses nnmail-group-pathname to read articles while + ;; unplugged. The agent must, therefore, use the same directory + ;; while plugged. + (let ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group)))) + (nnmail-group-pathname (gnus-group-real-name group) (gnus-agent-directory)))) (defun gnus-agent-get-function (method) (if (gnus-online method) @@ -1112,6 +1244,10 @@ This can be added to `gnus-select-article-hook' or (require 'nnagent) 'nnagent)) +(defun gnus-agent-covered-methods () + "Return the subset of methods that are covered by the agent." + (delq nil (mapcar #'gnus-server-to-method gnus-agent-covered-methods))) + ;;; History functions (defun gnus-agent-history-buffer () @@ -1201,9 +1337,7 @@ This can be added to `gnus-select-article-hook' or (when (or (cdr selected-sets) (car selected-sets)) (let* ((fetched-articles (list nil)) (tail-fetched-articles fetched-articles) - (dir (concat - (gnus-agent-directory) - (gnus-agent-group-path group) "/")) + (dir (gnus-agent-group-pathname group)) (date (time-to-days (current-time))) (case-fold-search t) pos crosses id) @@ -1272,7 +1406,7 @@ This can be added to `gnus-select-article-hook' or (gnus-agent-append-to-list tail-fetched-articles (caar pos))) (widen) - (pop pos)))) + (setq pos (cdr pos))))) (gnus-agent-save-alist group (cdr fetched-articles) date) (gnus-message 7 "")) @@ -1306,7 +1440,7 @@ This can be added to `gnus-select-article-hook' or (insert (string-to-number (cdar crosses))) (insert-buffer-substring gnus-agent-overview-buffer beg end) (gnus-agent-check-overview-buffer)) - (pop crosses)))) + (setq crosses (cdr crosses))))) (defun gnus-agent-backup-overview-buffer () (when gnus-newsgroup-name @@ -1346,7 +1480,7 @@ and that there are no duplicates." (gnus-message 1 "Overview buffer contains garbage '%s'." (buffer-substring - p (gnus-point-at-eol)))) + p (point-at-eol)))) ((= cur prev-num) (or backed-up (setq backed-up (gnus-agent-backup-overview-buffer))) @@ -1374,7 +1508,7 @@ and that there are no duplicates." (gnus-agent-article-name ".overview" (caar gnus-agent-buffer-alist)) nil 'silent)) - (pop gnus-agent-buffer-alist)) + (setq gnus-agent-buffer-alist (cdr gnus-agent-buffer-alist))) (while gnus-agent-group-alist (with-temp-file (gnus-agent-article-name ".agentview" (caar gnus-agent-group-alist)) @@ -1382,7 +1516,7 @@ and that there are no duplicates." (insert "\n") (princ 1 (current-buffer)) (insert "\n")) - (pop gnus-agent-group-alist)))) + (setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))) (defun gnus-agent-find-parameter (group symbol) "Search for GROUPs SYMBOL in the group's parameters, the group's @@ -1393,14 +1527,14 @@ variables. Returns the first non-nil value found." (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) - (agent-predicate . gnus-agent-predicate))))))) + '((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) + (agent-predicate . gnus-agent-predicate))))))) (defun gnus-agent-fetch-headers (group &optional force) "Fetch interesting headers into the agent. The group's overview @@ -1638,15 +1772,13 @@ FILE and places the combined headers into `nntp-server-buffer'." (setq uncomp (cons (cons article-id state) uncomp))) sequence))) alist) - (setq alist (sort uncomp - (lambda (first second) - (< (car first) (car second)))))))) + (setq alist (sort uncomp 'car-less-than-car))))) (when changed-version (let ((gnus-agent-article-alist alist)) (gnus-agent-save-alist gnus-agent-read-agentview))) alist)))) -(defun gnus-agent-save-alist (group &optional articles state dir) +(defun gnus-agent-save-alist (group &optional articles state) "Save the article-state alist for GROUP." (let* ((file-name-coding-system nnmail-pathname-coding-system) (prev (cons nil gnus-agent-article-alist)) @@ -1665,12 +1797,13 @@ FILE and places the combined headers into `nntp-server-buffer'." (setcdr (cadr prev) state))) (setq prev (cdr prev))) (setq gnus-agent-article-alist (cdr all)) - (if dir - (gnus-make-directory dir) - (gnus-make-directory (gnus-agent-article-name "" group))) - (with-temp-file (if dir - (expand-file-name ".agentview" dir) - (gnus-agent-article-name ".agentview" group)) + + (gnus-agent-set-local group + (caar gnus-agent-article-alist) + (caar (last gnus-agent-article-alist))) + + (gnus-make-directory (gnus-agent-article-name "" group)) + (with-temp-file (gnus-agent-article-name ".agentview" group) (cond ((eq gnus-agent-article-alist-save-format 1) (princ gnus-agent-article-alist (current-buffer))) ((eq gnus-agent-article-alist-save-format 2) @@ -1696,11 +1829,142 @@ FILE and places the combined headers into `nntp-server-buffer'." (princ gnus-agent-article-alist-save-format (current-buffer)) (insert "\n")))) +(defvar gnus-agent-article-local nil) +(defvar gnus-agent-file-loading-local nil) + +(defun gnus-agent-load-local (&optional method) + "Load the METHOD'S local file. The local file contains min/max +article counts for each of the method's subscribed groups." + (let ((gnus-command-method (or method gnus-command-method))) + (setq gnus-agent-article-local + (gnus-cache-file-contents + (gnus-agent-lib-file "local") + 'gnus-agent-file-loading-local + 'gnus-agent-read-and-cache-local)))) + +(defun gnus-agent-read-and-cache-local (file) + "Load and read FILE then bind its contents to +gnus-agent-article-local. If that variable had `dirty' (also known as +modified) original contents, they are first saved to their own file." + + (if (and gnus-agent-article-local + (symbol-value (intern "+dirty" gnus-agent-article-local))) + (gnus-agent-save-local)) + (gnus-agent-read-local file)) + +(defun gnus-agent-read-local (file) + "Load FILE and do a `read' there." + (let ((obarray (gnus-make-hashtable (count-lines (point-min) (point-max)))) + (line 1)) + (with-temp-buffer + (condition-case nil + (nnheader-insert-file-contents file) + (file-error)) + + (goto-char (point-min)) + ;; Skip any comments at the beginning of the file (the only place where they may appear) + (while (= (following-char) ?\;) + (forward-line 1) + (setq line (1+ line))) + + (while (not (eobp)) + (condition-case err + (let (group + min + max + (cur (current-buffer))) + (setq group (read cur) + min (read cur) + max (read cur)) + + (when (stringp group) + (setq group (intern group obarray))) + + ;; NOTE: The '+ 0' ensure that min and max are both numerics. + (set group (cons (+ 0 min) (+ 0 max)))) + (error + (gnus-message 3 "Warning - invalid agent local: %s on line %d: " file line (error-message-string err)))) + (forward-line 1) + (setq line (1+ line)))) + + (set (intern "+dirty" obarray) nil) + (set (intern "+method" obarray) gnus-command-method) + obarray)) + +(defun gnus-agent-save-local (&optional force) + "Save gnus-agent-article-local under it method's agent.lib directory." + (let ((obarray gnus-agent-article-local)) + (when (and obarray + (or force (symbol-value (intern "+dirty" obarray)))) + (let* ((gnus-command-method (symbol-value (intern "+method" obarray))) + ;; NOTE: gnus-command-method is used within gnus-agent-lib-file. + (dest (gnus-agent-lib-file "local"))) + (gnus-make-directory (gnus-agent-lib-file "")) + (with-temp-file dest + (let ((gnus-command-method (symbol-value (intern "+method" obarray))) + (file-name-coding-system nnmail-pathname-coding-system) + (coding-system-for-write + gnus-agent-file-coding-system) + print-level print-length item article + (standard-output (current-buffer))) + (mapatoms (lambda (symbol) + (cond ((not (boundp symbol)) + nil) + ((member (symbol-name symbol) '("+dirty" "+method")) + nil) + (t + (prin1 symbol) + (let ((range (symbol-value symbol))) + (princ " ") + (princ (car range)) + (princ " ") + (princ (cdr range)) + (princ "\n")))))))))))) + +(defun gnus-agent-get-local (group) + (let* ((gmane (gnus-group-real-name group)) + (gnus-command-method (gnus-find-method-for-group group)) + (local (gnus-agent-load-local)) + (symb (intern gmane local)) + (minmax (and (boundp symb) (symbol-value symb)))) + (unless minmax + ;; Bind these so that gnus-agent-load-alist doesn't change the + ;; current alist (i.e. gnus-agent-article-alist) + (let* ((gnus-agent-article-alist gnus-agent-article-alist) + (gnus-agent-file-loading-cache gnus-agent-file-loading-cache) + (alist (gnus-agent-load-alist group))) + (when alist + (setq minmax + (cons (caar alist) + (caar (last alist)))) + (gnus-agent-set-local group (car minmax) (cdr minmax) + gmane gnus-command-method local)))) + minmax)) + +(defun gnus-agent-set-local (group min max &optional gmane method local) + (let* ((gmane (or gmane (gnus-group-real-name group))) + (gnus-command-method (or method (gnus-find-method-for-group group))) + (local (or local (gnus-agent-load-local))) + (symb (intern gmane local)) + (minmax (and (boundp symb) (symbol-value symb)))) + + (if (cond ((and minmax + (or (not (eq min (car minmax))) + (not (eq max (cdr minmax))))) + (setcar minmax min) + (setcdr minmax max) + t) + (minmax + nil) + (t + (set symb (cons min max)) + t)) + (set (intern "+dirty" local) t)))) + (defun gnus-agent-article-name (article group) (expand-file-name article (file-name-as-directory - (expand-file-name (gnus-agent-group-path group) - (gnus-agent-directory))))) + (gnus-agent-group-pathname group)))) (defun gnus-agent-batch-confirmation (msg) "Show error message and return t." @@ -1723,7 +1987,7 @@ FILE and places the combined headers into `nntp-server-buffer'." (error "No servers are covered by the Gnus agent")) (unless gnus-plugged (error "Can't fetch articles while Gnus is unplugged")) - (let ((methods gnus-agent-covered-methods) + (let ((methods (gnus-agent-covered-methods)) groups group gnus-command-method) (save-excursion (while methods @@ -1754,7 +2018,7 @@ FILE and places the combined headers into `nntp-server-buffer'." (error-message-string err))) (signal 'quit "Cannot fetch articles into the Gnus agent"))))))))) - (pop methods)) + (setq methods (cdr methods))) (gnus-run-hooks 'gnus-agent-fetched-hook) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) @@ -2099,7 +2363,7 @@ The following commands are available: (gnus-category-position-point))) (defun gnus-category-name () - (or (intern (get-text-property (gnus-point-at-bol) 'gnus-category)) + (or (intern (get-text-property (point-at-bol) 'gnus-category)) (error "No category on the current line"))) (defun gnus-category-read () @@ -2133,7 +2397,7 @@ The following commands are available: '(agent-predicate agent-score-file agent-groups)))) c) old-list))))) - (list (gnus-agent-cat-make 'default))))) + (list (gnus-agent-cat-make 'default 'short))))) (defun gnus-category-write () "Write the category alist." @@ -2316,7 +2580,7 @@ The following commands are available: (cond ;; Functions are just returned as is. ((or (symbolp predicate) - (gnus-functionp predicate)) + (functionp predicate)) `(,(or (cdr (assq predicate gnus-category-predicate-alist)) predicate))) ;; More complex predicate. @@ -2344,22 +2608,58 @@ The following commands are available: (defun gnus-predicate-implies-unread (predicate) "Say whether PREDICATE implies unread articles only. 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 +That is, if this predicate returns true, then indeed the predicate must return only unread articles." - (gnus-function-implies-unread-1 (gnus-category-make-function predicate))) + (eq t (gnus-function-implies-unread-1 + (gnus-category-make-function-1 predicate)))) (defun gnus-function-implies-unread-1 (function) - (cond ((eq function (symbol-function 'gnus-agent-read-p)) - nil) - ((not function) - nil) - ((gnus-functionp 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)))) + "Recursively evaluate a predicate function to determine whether it can select +any read articles. Returns t if the function is known to never +return read articles, nil when it is known to always return read +articles, and t_nil when the function may return both read and unread +articles." + (let ((func (car function)) + (args (mapcar 'gnus-function-implies-unread-1 (cdr function)))) + (cond ((eq func 'and) + (cond ((memq t args) ; if any argument returns only unread articles + ;; then that argument constrains the result to only unread articles. + t) + ((memq 't_nil args) ; if any argument is indeterminate + ;; then the result is indeterminate + 't_nil))) + ((eq func 'or) + (cond ((memq nil args) ; if any argument returns read articles + ;; then that argument ensures that the results includes read articles. + nil) + ((memq 't_nil args) ; if any argument is indeterminate + ;; then that argument ensures that the results are indeterminate + 't_nil) + (t ; if all arguments return only unread articles + ;; then the result returns only unread articles + t))) + ((eq func 'not) + (cond ((eq (car args) 't_nil) ; if the argument is indeterminate + ; then the result is indeterminate + (car args)) + (t ; otherwise + ; toggle the result to be the opposite of the argument + (not (car args))))) + ((eq func 'gnus-agent-read-p) + nil) ; The read predicate NEVER returns unread articles + ((eq func 'gnus-agent-false) + t) ; The false predicate returns t as the empty set excludes all read articles + ((eq func 'gnus-agent-true) + nil) ; The true predicate ALWAYS returns read articles + ((catch 'found-match + (let ((alist gnus-category-predicate-alist)) + (while alist + (if (eq func (cdar alist)) + (throw 'found-match t) + (setq alist (cdr alist)))))) + 't_nil) ; All other predicates return read and unread articles + (t + (error "Unknown predicate function: %s" function))))) (defun gnus-group-category (group) "Return the category GROUP belongs to." @@ -2398,53 +2698,55 @@ FORCE is equivalent to setting the expiration predicates to true." (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 " - "expire all articles in " group "."))) - (let ((gnus-command-method (gnus-find-method-for-group group)) - (overview (gnus-get-buffer-create " *expire overview*")) - orig) - (unwind-protect - (when (file-exists-p (gnus-agent-lib-file "active")) - (with-temp-buffer - (nnheader-insert-file-contents - (gnus-agent-lib-file "active")) - (gnus-active-to-gnus-format - gnus-command-method - (setq orig (gnus-make-hashtable - (count-lines (point-min) (point-max)))))) - (save-excursion - (gnus-agent-expire-group-1 - group overview (gnus-gethash-safe group orig) - articles force))) - (kill-buffer overview)))) - (gnus-message 4 "Expiry...done"))) - -(defmacro gnus-agent-message (level &rest args) - `(if (<= ,level gnus-verbose) - (message ,@args))) + (let ( ;; Bind gnus-agent-expire-stats to enable tracking of + ;; expiration statistics of this single group + (gnus-agent-expire-stats (list 0 0 0.0))) + (if (or (not (eq articles t)) + (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*")) + orig) + (unwind-protect + (let ((active-file (gnus-agent-lib-file "active"))) + (when (file-exists-p active-file) + (with-temp-buffer + (nnheader-insert-file-contents active-file) + (gnus-active-to-gnus-format + gnus-command-method + (setq orig (gnus-make-hashtable + (count-lines (point-min) (point-max)))))) + (save-excursion + (gnus-agent-expire-group-1 + group overview (gnus-gethash-safe group orig) + articles force)))) + (kill-buffer overview)))) + (gnus-message 4 (gnus-agent-expire-done-message))))) (defun gnus-agent-expire-group-1 (group overview active articles force) ;; Internal function - requires caller to have set ;; gnus-command-method, initialized overview buffer, and to have ;; provided a non-nil active - (let ((dir (concat - (gnus-agent-directory) - (gnus-agent-group-path group) - "/"))) + (let ((dir (gnus-agent-group-pathname group))) (when (boundp 'gnus-agent-expire-current-dirs) (set 'gnus-agent-expire-current-dirs (cons dir (symbol-value 'gnus-agent-expire-current-dirs)))) - (if (eq 'DISABLE (gnus-agent-find-parameter group - 'agent-enable-expiration)) + (if (and (not force) + (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)) + (let* ((stats (if (boundp 'gnus-agent-expire-stats) + ;; Use the list provided by my caller + (symbol-value 'gnus-agent-expire-stats) + ;; otherwise use my own temporary list + (list 0 0 0.0))) + (info (gnus-get-info group)) (alist gnus-agent-article-alist) (day (- (time-to-days (current-time)) (gnus-agent-find-parameter group 'agent-days-until-old))) @@ -2484,7 +2786,7 @@ FORCE is equivalent to setting the expiration predicates to true." (cons (caar alist) (caar (last alist)))) (sort articles '<))))) - (marked ;; More articles that are exluded from the + (marked ;; More articles that are excluded from the ;; expiration process (cond (gnus-agent-expire-all ;; All articles are unmarked by global decree @@ -2622,7 +2924,8 @@ line." (point) nov-file))) (while dlist (let ((new-completed (truncate (* 100.0 (/ (setq cnt (1+ cnt)) - len))))) + len)))) + message-log-max) (when (> new-completed completed) (setq completed new-completed) (gnus-message 7 "%3d%% completed..." completed))) @@ -2636,16 +2939,16 @@ line." (point) nov-file))) ;; Kept articles are unread, marked, or special. (keep (gnus-agent-message 10 - "gnus-agent-expire: Article %d: Kept %s article." - article-number keep) + "gnus-agent-expire: %s:%d: Kept %s article%s." + group article-number keep (if fetch-date " and file" "")) (when fetch-date (unless (file-exists-p (concat dir (number-to-string article-number))) (setf (nth 1 entry) nil) (gnus-agent-message 3 "gnus-agent-expire cleared \ -download flag on article %d as the cached article file is missing." - (caar dlist))) +download flag on %s:%d as the cached article file is missing." + group (caar dlist))) (unless marker (gnus-message 1 "gnus-agent-expire detected a \ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) @@ -2681,8 +2984,11 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) (let ((actions nil)) (when (memq type '(forced expired)) (ignore-errors ; Just being paranoid. - (delete-file (concat dir (number-to-string - article-number))) + (let ((file-name (concat dir (number-to-string + article-number)))) + (incf (nth 2 stats) (nth 7 (file-attributes file-name))) + (incf (nth 1 stats)) + (delete-file file-name)) (push "expired cached article" actions)) (setf (nth 1 entry) nil) ) @@ -2690,11 +2996,18 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) (when marker (push "NOV entry removed" actions) (goto-char marker) - (gnus-delete-line)) + + (incf (nth 0 stats)) + + (let ((from (point-at-bol)) + (to (progn (forward-line 1) (point)))) + (incf (nth 2 stats) (- to from)) + (delete-region from to))) ;; If considering all articles is set, I can only ;; expire article IDs that are no longer in the - ;; active range. + ;; active range (That is, articles that preceed the + ;; first article in the new alist). (if (and gnus-agent-consider-all-articles (>= article-number (car active))) ;; I have to keep this ID in the alist @@ -2703,13 +3016,14 @@ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) (push (format "Removed %s article number from \ article alist" type) actions)) - (gnus-agent-message 8 "gnus-agent-expire: Article %d: %s" - article-number - (mapconcat 'identity actions ", ")))) + (when actions + (gnus-agent-message 8 "gnus-agent-expire: %s:%d: %s" + group article-number + (mapconcat 'identity actions ", "))))) (t (gnus-agent-message - 10 "gnus-agent-expire: Article %d: Article kept as \ -expiration tests failed." article-number) + 10 "gnus-agent-expire: %s:%d: Article kept as \ +expiration tests failed." group article-number) (gnus-agent-append-to-list tail-alist (cons article-number fetch-date))) ) @@ -2759,43 +3073,65 @@ FORCE is equivalent to setting the expiration predicates to true." (if (or (not (eq articles t)) (yes-or-no-p "Are you sure that you want to expire all \ articles in every agentized group.")) - (let ((methods gnus-agent-covered-methods) + (let ((methods (gnus-agent-covered-methods)) ;; Bind gnus-agent-expire-current-dirs to enable tracking ;; of agent directories. (gnus-agent-expire-current-dirs nil) + ;; Bind gnus-agent-expire-stats to enable tracking of + ;; expiration statistics across all groups + (gnus-agent-expire-stats (list 0 0 0.0)) gnus-command-method overview orig) (setq overview (gnus-get-buffer-create " *expire overview*")) (unwind-protect (while (setq gnus-command-method (pop methods)) - (when (file-exists-p (gnus-agent-lib-file "active")) - (with-temp-buffer - (nnheader-insert-file-contents - (gnus-agent-lib-file "active")) - (gnus-active-to-gnus-format - gnus-command-method - (setq orig (gnus-make-hashtable - (count-lines (point-min) (point-max)))))) - (dolist (expiring-group (gnus-groups-from-server - gnus-command-method)) - (let* ((active - (gnus-gethash-safe expiring-group orig))) + (let ((active-file (gnus-agent-lib-file "active"))) + (when (file-exists-p active-file) + (with-temp-buffer + (nnheader-insert-file-contents active-file) + (gnus-active-to-gnus-format + gnus-command-method + (setq orig (gnus-make-hashtable + (count-lines (point-min) (point-max)))))) + (dolist (expiring-group (gnus-groups-from-server + gnus-command-method)) + (let* ((active + (gnus-gethash-safe expiring-group orig))) - (when active - (save-excursion - (gnus-agent-expire-group-1 - expiring-group overview active articles force))))))) + (when active + (save-excursion + (gnus-agent-expire-group-1 + expiring-group overview active articles force)))))))) (kill-buffer overview)) (gnus-agent-expire-unagentized-dirs) - (gnus-message 4 "Expiry...done"))))) + (gnus-message 4 (gnus-agent-expire-done-message)))))) + +(defun gnus-agent-expire-done-message () + (if (and (> gnus-verbose 4) + (boundp 'gnus-agent-expire-stats)) + (let* ((stats (symbol-value 'gnus-agent-expire-stats)) + (size (nth 2 stats)) + (units '(B KB MB GB))) + (while (and (> size 1024.0) + (cdr units)) + (setq size (/ size 1024.0) + units (cdr units))) + + (format "Expiry recovered %d NOV entries, deleted %d files,\ + and freed %f %s." + (nth 0 stats) + (nth 1 stats) + size (car units))) + "Expiry...done")) (defun gnus-agent-expire-unagentized-dirs () - (when (boundp 'gnus-agent-expire-current-dirs) + (when (and gnus-agent-expire-unagentized-dirs + (boundp 'gnus-agent-expire-current-dirs)) (let* ((keep (gnus-make-hashtable)) ;; Formally bind gnus-agent-expire-current-dirs so that the ;; compiler will not complain about free references. (gnus-agent-expire-current-dirs (symbol-value 'gnus-agent-expire-current-dirs)) - dir) + dir) (gnus-sethash gnus-agent-directory t keep) (while gnus-agent-expire-current-dirs @@ -2806,57 +3142,69 @@ articles in every agentized group.")) (gnus-sethash dir t keep) (setq dir (file-name-directory (directory-file-name dir)))))) - (let* (to-remove - checker - (checker - (function - (lambda (d) - (let ((files (directory-files d)) - file) - (while (setq file (pop files)) - (cond ((equal file ".") - nil) - ((equal file "..") - nil) - ((equal file ".overview") - (let ((d (file-name-as-directory d)) - r) - (while (not (gnus-gethash - (setq d (file-name-directory d)) keep)) - (setq r d - d (directory-file-name d))) - (if r - (push r to-remove)))) - ((file-directory-p (setq file (nnheader-concat d file))) - (funcall checker file))))))))) - (funcall checker gnus-agent-directory) - - (when (and to-remove - (gnus-y-or-n-p - "gnus-agent-expire has identified local directories that are\ + (let* (to-remove + checker + (checker + (function + (lambda (d) + "Given a directory, check it and its subdirectories for + membership in the keep hash. If it isn't found, add + it to to-remove." + (let ((files (directory-files d)) + file) + (while (setq file (pop files)) + (cond ((equal file ".") ; Ignore self + nil) + ((equal file "..") ; Ignore parent + nil) + ((equal file ".overview") + ;; Directory must contain .overview to be + ;; agent's cache of a group. + (let ((d (file-name-as-directory d)) + r) + ;; Search ancestor's for last directory NOT + ;; found in keep hash. + (while (not (gnus-gethash + (setq d (file-name-directory d)) keep)) + (setq r d + d (directory-file-name d))) + ;; if ANY ancestor was NOT in keep hash and + ;; it it's already in to-remove, add it to + ;; to-remove. + (if (and r + (not (member r to-remove))) + (push r to-remove)))) + ((file-directory-p (setq file (nnheader-concat d file))) + (funcall checker file))))))))) + (funcall checker (expand-file-name gnus-agent-directory)) + + (when (and to-remove + (or gnus-expert-user + (gnus-y-or-n-p + "gnus-agent-expire has identified local directories that are\ not currently required by any agentized group. Do you wish to consider\ - deleting them?")) - (while to-remove - (let ((dir (pop to-remove))) - (if (gnus-y-or-n-p (format "Delete %s?" dir)) - (let* (delete-recursive - (delete-recursive - (function - (lambda (f-or-d) - (ignore-errors - (if (file-directory-p f-or-d) - (condition-case nil - (delete-directory f-or-d) - (file-error - (mapcar (lambda (f) - (or (member f '("." "..")) - (funcall delete-recursive - (nnheader-concat - f-or-d f)))) - (directory-files f-or-d)) - (delete-directory f-or-d))) - (delete-file f-or-d))))))) - (funcall delete-recursive dir)))))))))) + deleting them?"))) + (while to-remove + (let ((dir (pop to-remove))) + (if (gnus-y-or-n-p (format "Delete %s? " dir)) + (let* (delete-recursive + (delete-recursive + (function + (lambda (f-or-d) + (ignore-errors + (if (file-directory-p f-or-d) + (condition-case nil + (delete-directory f-or-d) + (file-error + (mapcar (lambda (f) + (or (member f '("." "..")) + (funcall delete-recursive + (nnheader-concat + f-or-d f)))) + (directory-files f-or-d)) + (delete-directory f-or-d))) + (delete-file f-or-d))))))) + (funcall delete-recursive dir)))))))))) ;;;###autoload (defun gnus-agent-batch () @@ -2884,7 +3232,12 @@ articles in every agentized group.")) (gnus-agent-append-to-list tail-unread candidate) nil) ((> candidate max) - (pop read))))))) + (setq read (cdr read)) + ;; return t so that I always loop one more + ;; time. If I just iterated off the end of + ;; read, min will become nil and the current + ;; candidate will be added to the unread list. + t)))))) (while known (gnus-agent-append-to-list tail-unread (car (pop known)))) (cdr unread))) @@ -2912,14 +3265,14 @@ has been fetched." (v2 (caar ref))) (cond ((< v1 v2) ; v1 does not appear in the reference list (gnus-agent-append-to-list tail-uncached v1) - (pop arts)) + (setq arts (cdr arts))) ((= v1 v2) (unless (or cached-header (cdar ref)) ; v1 is already cached (gnus-agent-append-to-list tail-uncached v1)) - (pop arts) - (pop ref)) + (setq arts (cdr arts)) + (setq ref (cdr ref))) (t ; reference article (v2) preceeds the list being filtered - (pop ref))))) + (setq ref (cdr ref)))))) (while arts (gnus-agent-append-to-list tail-uncached (pop arts))) (cdr uncached)) @@ -3064,10 +3417,7 @@ has been fetched." (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))) + (file (gnus-agent-article-name (number-to-string article) group)) (buffer-read-only nil)) (when (and (file-exists-p file) (> (nth 7 (file-attributes file)) 0)) @@ -3092,236 +3442,220 @@ If REREAD is not nil, downloaded articles are marked as unread." 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))) - (file (gnus-agent-article-name ".overview" group)) - (dir (file-name-directory file)) - point - (downloaded (if (file-exists-p dir) - (sort (mapcar (lambda (name) (string-to-int name)) - (directory-files dir nil "^[0-9]+$" t)) - '>) - (progn (gnus-make-directory dir) nil))) - dl nov-arts - alist header - regenerated) - - (mm-with-unibyte-buffer - (if (file-exists-p file) - (let ((nnheader-file-coding-system - gnus-agent-file-coding-system)) - (nnheader-insert-file-contents file))) - (set-buffer-modified-p nil) - - ;; Load the article IDs found in the overview file. As a - ;; side-effect, validate the file contents. - (let ((load t)) - (while load - (setq load nil) - (goto-char (point-min)) - (while (< (point) (point-max)) - (cond ((and (looking-at "[0-9]+\t") - (<= (- (match-end 0) (match-beginning 0)) 9)) - (push (read (current-buffer)) nov-arts) - (forward-line 1) - (let ((l1 (car nov-arts)) - (l2 (cadr nov-arts))) - (cond ((not l2) - nil) - ((< l1 l2) - (gnus-message 3 "gnus-agent-regenerate-group: NOV\ + (catch 'mark + (while (let (c + (cursor-in-echo-area t) + (echo-keystrokes 0)) + (message "Mark as unread: (n)one / (a)ll / all (d)ownloaded articles? (n) ") + (setq c (read-char-exclusive)) + + (cond ((or (eq c ?\r) (eq c ?n) (eq c ?N)) + (throw 'mark nil)) + ((or (eq c ?a) (eq c ?A)) + (throw 'mark t)) + ((or (eq c ?d) (eq c ?D)) + (throw 'mark 'some))) + (gnus-message 3 "Ignoring unexpected input") + (sit-for 1) + t))))) + + (when group + (gnus-message 5 "Regenerating in %s" group) + (let* ((gnus-command-method (or gnus-command-method + (gnus-find-method-for-group group))) + (file (gnus-agent-article-name ".overview" group)) + (dir (file-name-directory file)) + point + (downloaded (if (file-exists-p dir) + (sort (mapcar (lambda (name) (string-to-int name)) + (directory-files dir nil "^[0-9]+$" t)) + '>) + (progn (gnus-make-directory dir) nil))) + dl nov-arts + alist header + regenerated) + + (mm-with-unibyte-buffer + (if (file-exists-p file) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-file-contents file))) + (set-buffer-modified-p nil) + + ;; Load the article IDs found in the overview file. As a + ;; side-effect, validate the file contents. + (let ((load t)) + (while load + (setq load nil) + (goto-char (point-min)) + (while (< (point) (point-max)) + (cond ((and (looking-at "[0-9]+\t") + (<= (- (match-end 0) (match-beginning 0)) 9)) + (push (read (current-buffer)) nov-arts) + (forward-line 1) + (let ((l1 (car nov-arts)) + (l2 (cadr nov-arts))) + (cond ((not l2) + nil) + ((< l1 l2) + (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\ + ;; 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-delete-line) - (pop nov-arts))))) - (t - (gnus-message 1 "gnus-agent-regenerate-group: NOV\ + (gnus-delete-line) + (setq nov-arts (cdr 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-delete-line)))) - (if load - (progn - (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\ + (gnus-delete-line)))) + (if load + (progn + (gnus-message 5 "gnus-agent-regenerate-group: Sorting NOV\ entries into ascending order.") - (sort-numeric-fields 1 (point-min) (point-max)) + (sort-numeric-fields 1 (point-min) (point-max)) (setq nov-arts nil))))) - (gnus-agent-check-overview-buffer) - - ;; Construct a new article alist whose nodes match every header - ;; 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 - (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)) - (let ((file (concat dir (number-to-string (car downloaded))))) - (mm-with-unibyte-buffer - (nnheader-insert-file-contents file) - (nnheader-remove-body) - (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"))) - (or (re-search-backward key nil t) - (re-search-forward key)) - (forward-line 1)) - (goto-char (point-min))) - (nnheader-insert-nov header)) - (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) - (pop downloaded) - (pop nov-arts)) - (t - ;; This entry in the overview has not been downloaded - (push (cons (car nov-arts) nil) alist) - (pop nov-arts)))) - - ;; When gnus-agent-consider-all-articles is set, - ;; gnus-agent-regenerate-group should NOT remove article IDs from - ;; the alist. Those IDs serve as markers to indicate that an - ;; attempt has been made to fetch that article's header. - - ;; When gnus-agent-consider-all-articles is NOT set, - ;; gnus-agent-regenerate-group can remove the article ID of every - ;; article (with the exception of the last ID in the list - it's - ;; special) that no longer appears in the overview. In this - ;; situtation, the last article ID in the list implies that it, - ;; and every article ID preceeding it, have been fetched from the - ;; server. - (if gnus-agent-consider-all-articles - ;; Restore all article IDs that were not found in the overview file. - (let* ((n (cons nil alist)) - (merged n) - (o (gnus-agent-load-alist group))) - (while o - (let ((nID (caadr n)) - (oID (caar o))) - (cond ((not nID) - (setq n (setcdr n (list (list oID)))) - (pop o)) - ((< oID nID) - (setcdr n (cons (list oID) (cdr n))) - (pop o)) - ((= oID nID) - (pop o) - (pop n)) - (t - (pop n))))) - (setq alist (cdr merged))) - ;; Restore the last article ID if it is not already in the new alist - (let ((n (last alist)) - (o (last (gnus-agent-load-alist group)))) - (cond ((not o) - nil) - ((not n) - (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)) - (let ((coding-system-for-write gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) file nil 'silent))) - - (setq regenerated (or regenerated - (and reread gnus-agent-article-alist) - (not (equal alist gnus-agent-article-alist))) - ) - - (setq gnus-agent-article-alist alist) - - (when regenerated - (gnus-agent-save-alist group))) - ) - - (when (and reread gnus-agent-article-alist) - (gnus-make-ascending-articles-unread - group - (delq nil (mapcar (function (lambda (c) - (cond ((eq reread t) - (car c)) - ((cdr c) - (car c))))) - gnus-agent-article-alist))) - - (when (gnus-buffer-live-p gnus-group-buffer) - (gnus-group-update-group group t) - (sit-for 0)) - ) - - (gnus-message 5 nil) - regenerated)) + (gnus-agent-check-overview-buffer) + + ;; Construct a new article alist whose nodes match every header + ;; 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 + (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)) + (let ((file (concat dir (number-to-string (car downloaded))))) + (mm-with-unibyte-buffer + (nnheader-insert-file-contents file) + (nnheader-remove-body) + (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"))) + (or (re-search-backward key nil t) + (re-search-forward key)) + (forward-line 1)) + (goto-char (point-min))) + (nnheader-insert-nov header)) + (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) + (setq downloaded (cdr downloaded)) + (setq nov-arts (cdr nov-arts))) + (t + ;; This entry in the overview has not been downloaded + (push (cons (car nov-arts) nil) alist) + (setq nov-arts (cdr nov-arts))))) + + ;; When gnus-agent-consider-all-articles is set, + ;; gnus-agent-regenerate-group should NOT remove article IDs from + ;; the alist. Those IDs serve as markers to indicate that an + ;; attempt has been made to fetch that article's header. + + ;; When gnus-agent-consider-all-articles is NOT set, + ;; gnus-agent-regenerate-group can remove the article ID of every + ;; article (with the exception of the last ID in the list - it's + ;; special) that no longer appears in the overview. In this + ;; situtation, the last article ID in the list implies that it, + ;; and every article ID preceeding it, have been fetched from the + ;; server. + + (if gnus-agent-consider-all-articles + ;; Restore all article IDs that were not found in the overview file. + (let* ((n (cons nil alist)) + (merged n) + (o (gnus-agent-load-alist group))) + (while o + (let ((nID (caadr n)) + (oID (caar o))) + (cond ((not nID) + (setq n (setcdr n (list (list oID)))) + (setq o (cdr o))) + ((< oID nID) + (setcdr n (cons (list oID) (cdr n))) + (setq o (cdr o))) + ((= oID nID) + (setq o (cdr o)) + (setq n (cdr n))) + (t + (setq n (cdr n)))))) + (setq alist (cdr merged))) + ;; Restore the last article ID if it is not already in the new alist + (let ((n (last alist)) + (o (last (gnus-agent-load-alist group)))) + (cond ((not o) + nil) + ((not n) + (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)) + (let ((coding-system-for-write gnus-agent-file-coding-system)) + (write-region (point-min) (point-max) file nil 'silent))) + + (setq regenerated (or regenerated + (and reread gnus-agent-article-alist) + (not (equal alist gnus-agent-article-alist)))) + + (setq gnus-agent-article-alist alist) + + (when regenerated + (gnus-agent-save-alist group) + + ;; I have to alter the group's active range NOW as + ;; gnus-make-ascending-articles-unread will use it to + ;; recalculate the number of unread articles in the group + + (let ((group (gnus-group-real-name group)) + (group-active (gnus-active group))) + (gnus-agent-possibly-alter-active group group-active))))) + + (when (and reread gnus-agent-article-alist) + (gnus-make-ascending-articles-unread + group + (delq nil (mapcar (function (lambda (c) + (cond ((eq reread t) + (car c)) + ((cdr c) + (car c))))) + gnus-agent-article-alist))) + + (when (gnus-buffer-live-p gnus-group-buffer) + (gnus-group-update-group group t) + (sit-for 0))) + + (gnus-message 5 nil) + regenerated))) ;;;###autoload (defun gnus-agent-regenerate (&optional clean reread) "Regenerate all agent covered files. -If CLEAN, don't read existing active files." +If CLEAN, obsolete (ignore)." (interactive "P") (let (regenerated) (gnus-message 4 "Regenerating Gnus agent files...") - (dolist (gnus-command-method gnus-agent-covered-methods) - (let ((active-file (gnus-agent-lib-file "active")) - active-hashtb active-changed - point) - (gnus-make-directory (file-name-directory active-file)) - (if clean - (setq active-hashtb (gnus-make-hashtable 1000)) - (mm-with-unibyte-buffer - (if (file-exists-p active-file) - (let ((nnheader-file-coding-system - gnus-agent-file-coding-system)) - (nnheader-insert-file-contents active-file)) - (setq active-changed t)) - (gnus-active-to-gnus-format - nil (setq active-hashtb - (gnus-make-hashtable - (count-lines (point-min) (point-max))))))) + (dolist (gnus-command-method (gnus-agent-covered-methods)) (dolist (group (gnus-groups-from-server gnus-command-method)) (setq regenerated (or (gnus-agent-regenerate-group group reread) - regenerated)) - (let ((min (or (caar gnus-agent-article-alist) 1)) - (max (or (caar (last gnus-agent-article-alist)) 0)) - (active (gnus-gethash-safe (gnus-group-real-name group) - active-hashtb)) - (read (gnus-info-read (gnus-get-info group)))) - (if (not active) - (progn - (setq active (cons min max) - active-changed t) - (gnus-sethash group active active-hashtb)) - (when (> (car active) min) - (setcar active min) - (setq active-changed t)) - (when (< (cdr active) max) - (setcdr active max) - (setq active-changed t))))) - (when active-changed - (setq regenerated t) - (gnus-message 4 "Regenerate %s" active-file) - (let ((nnmail-active-file-coding-system - gnus-agent-file-coding-system)) - (gnus-write-active-file active-file active-hashtb))))) + regenerated)))) (gnus-message 4 "Regenerating Gnus agent files...done") + regenerated)) (defun gnus-agent-go-online (&optional force) @@ -3350,8 +3684,7 @@ If CLEAN, don't read existing active files." (if (eq status 'offline) 'online 'offline)))) (defun gnus-agent-group-covered-p (group) - (member (gnus-group-method group) - gnus-agent-covered-methods)) + (gnus-agent-method-p (gnus-group-method group))) (add-hook 'gnus-group-prepare-hook (lambda () @@ -3378,7 +3711,7 @@ If CLEAN, don't read existing active files." (caar days) group)) (throw 'found (cadar days))) - (pop days)) + (setq days (cdr days))) nil))) (when day (gnus-group-set-parameter group 'agent-days-until-old