X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-agent.el;h=6ff7b492bd20b3062c19502e187f28c8b132f07e;hb=e405b22c6b46721607c5e6c712a4705c23dee751;hp=5ab22515c73f5127e9fbf61f2757c1851601afe5;hpb=0b49f53ac6aa0dcc7c3d6fab64206e5f00c75ceb;p=gnus diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 5ab22515c..8da270859 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,5 +1,5 @@ ;;; gnus-agent.el --- unplugged support for Gnus -;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002 +;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -26,10 +26,12 @@ (require 'gnus) (require 'gnus-cache) +(require 'nnmail) (require 'nnvirtual) (require 'gnus-sum) (require 'gnus-score) (require 'gnus-srvr) +(require 'gnus-util) (eval-when-compile (if (featurep 'xemacs) (require 'itimer) @@ -37,7 +39,9 @@ (require 'cl)) (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." @@ -55,7 +59,8 @@ :type 'hook) (defcustom gnus-agent-fetched-hook nil - "Hook run after finishing fetching articles." + "Hook run when finished fetching articles." + :version "22.1" :group 'gnus-agent :type 'hook) @@ -66,10 +71,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 'integer) + :type '(number :tag "days")) (defcustom gnus-agent-expire-all nil "If non-nil, also expire unread, ticked and dormant articles. @@ -110,7 +114,7 @@ If nil, only read articles will be expired." :group 'gnus-agent :type 'function) -(defcustom gnus-agent-synchronize-flags 'ask +(defcustom gnus-agent-synchronize-flags nil "Indicate if flags are synchronized when you plug in. If this is `ask' the hook will query the user." :version "21.1" @@ -122,7 +126,7 @@ If this is `ask' the hook will query the user." (defcustom gnus-agent-go-online 'ask "Indicate if offline servers go online when you plug in. If this is `ask' the hook will query the user." - :version "21.1" + :version "21.3" :type '(choice (const :tag "Always" t) (const :tag "Never" nil) (const :tag "Ask" ask)) @@ -141,17 +145,86 @@ 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." - :version "21.4" + "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 "22.1" + :type 'boolean + :group 'gnus-agent) + +(defcustom gnus-agent-max-fetch-size 10000000 ;; 10 Mb + "Chunk size for `gnus-agent-fetch-session'. +The function will split its article fetches into chunks smaller than +this limit." + :version "22.1" + :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 DISABLE then +enable expiration per categories, topics, and groups." + :version "22.1" + :group 'gnus-agent + :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." + :version "22.1" :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'." + :version "22.1" + :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." + :version "22.1" + :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." + :version "22.1" + :group 'gnus-agent + :type 'boolean) + ;;; Internal variables (defvar gnus-agent-history-buffers nil) (defvar gnus-agent-buffer-alist nil) -(defvar gnus-agent-article-alist nil) -(defvar gnus-agent-fetched-headers nil) +(defvar gnus-agent-article-alist nil + "An assoc list identifying the articles whose headers have been fetched. +If successfully fetched, these headers will be stored in the group's overview +file. The key of each assoc pair is the article ID, the value of each assoc +pair is a flag indicating whether the identified article has been downloaded +\(gnus-agent-fetch-articles sets the value to the day of the download). +NOTES: +1) The last element of this list can not be expired as some + routines (for example, get-agent-fetch-headers) use the last + value to track which articles have had their headers retrieved. +2) The function `gnus-agent-regenerate' may destructively modify the value.") (defvar gnus-agent-group-alist nil) (defvar gnus-category-alist nil) (defvar gnus-agent-current-history nil) @@ -163,12 +236,9 @@ If this is `ask' the hook will query the user." (defvar gnus-agent-send-mail-function nil) (defvar gnus-agent-file-coding-system 'raw-text) (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'.") +(defvar gnus-agent-total-fetched-hashtb nil) +(defvar gnus-agent-inhibit-update-total-fetched-for nil) +(defvar gnus-agent-need-update-total-fetched-for nil) ;; Dynamic variables (defvar gnus-headers) @@ -199,8 +269,7 @@ node `(gnus)Server Buffer'.") (gnus-add-shutdown 'gnus-close-agent 'gnus) (defun gnus-close-agent () - (setq gnus-agent-covered-methods nil - gnus-category-predicate-cache nil + (setq gnus-category-predicate-cache nil gnus-category-group-cache nil gnus-agent-spam-hashtb nil) (gnus-kill-buffer gnus-agent-overview-buffer)) @@ -209,6 +278,17 @@ node `(gnus)Server Buffer'.") ;;; Utility functions ;;; +(defmacro gnus-agent-with-refreshed-group (group &rest body) + "Performs the body then updates the group's line in the group +buffer. Automatically blocks multiple updates due to recursion." +`(prog1 (let ((gnus-agent-inhibit-update-total-fetched-for t)) ,@body) + (when (and gnus-agent-need-update-total-fetched-for + (not gnus-agent-inhibit-update-total-fetched-for)) + (save-excursion + (set-buffer gnus-group-buffer) + (setq gnus-agent-need-update-total-fetched-for nil) + (gnus-group-update-group ,group t))))) + (defun gnus-agent-read-file (file) "Load FILE and do a `read' there." (with-temp-buffer @@ -224,28 +304,144 @@ node `(gnus)Server Buffer'.") (cadr gnus-command-method)))) (defsubst gnus-agent-directory () - "Path of the Gnus agent directory." + "The name of the Gnus agent directory." (nnheader-concat gnus-agent-directory (nnheader-translate-file-chars (gnus-agent-method)) "/")) (defun gnus-agent-lib-file (file) - "The full path of the Gnus agent library FILE." + "The full name of the Gnus agent library FILE." (expand-file-name file (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) + +(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-- (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-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) +(gnus-agent-cat-defaccessor + gnus-agent-cat-enable-undownloaded-faces agent-enable-undownloaded-faces) + + +;; This form is equivalent to defsetf except that it calls make-symbol +;; whereas defsetf calls gensym (Using gensym creates a run-time +;; dependency on the CL library). + +(eval-and-compile + (define-setf-method gnus-agent-cat-groups (category) + (let* ((--category--temp-- (make-symbol "--category--")) + (--groups--temp-- (make-symbol "--groups--"))) + (list (list --category--temp--) + (list category) + (list --groups--temp--) + (let* ((category --category--temp--) + (groups --groups--temp--)) + (list (quote gnus-agent-set-cat-groups) category groups)) + (list (quote gnus-agent-cat-groups) --category--temp--)))) + ) + +(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 &optional default-agent-predicate) + (list name `(agent-predicate . ,(or default-agent-predicate 'false)))) + ;;; Fetching setup functions. (defun gnus-agent-start-fetch () "Initialize data structures for efficient fetching." - (gnus-agent-open-history) - (setq gnus-agent-current-history (gnus-agent-history-buffer)) (gnus-agent-create-buffer)) (defun gnus-agent-stop-fetch () "Save all data structures and clean up." - (gnus-agent-save-history) - (gnus-agent-close-history) (setq gnus-agent-spam-hashtb nil) (save-excursion (set-buffer nntp-server-buffer) @@ -262,6 +458,13 @@ node `(gnus)Server Buffer'.") (put 'gnus-agent-with-fetch 'lisp-indent-function 0) (put 'gnus-agent-with-fetch 'edebug-form-spec '(body)) +(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 ;;; @@ -291,7 +494,13 @@ node `(gnus)Server Buffer'.") buffer)))) minor-mode-map-alist)) (when (eq major-mode 'gnus-group-mode) - (gnus-agent-toggle-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. + (setq gnus-plugged :unknown) + (gnus-agent-toggle-plugged init-plugged))) (gnus-run-hooks 'gnus-agent-mode-hook (intern (format "gnus-agent-%s-mode-hook" buffer))))) @@ -315,15 +524,21 @@ node `(gnus)Server Buffer'.") ["Toggle plugged" gnus-agent-toggle-plugged t] ["Toggle group plugged" gnus-agent-toggle-group-plugged t] ["List categories" gnus-enter-category-buffer t] + ["Add (current) group to category" gnus-agent-add-group t] + ["Remove (current) group from category" gnus-agent-remove-group t] ["Send queue" gnus-group-send-queue gnus-plugged] ("Fetch" ["All" gnus-agent-fetch-session gnus-plugged] - ["Group" gnus-agent-fetch-group gnus-plugged]))))) + ["Group" gnus-agent-fetch-group gnus-plugged]) + ["Synchronize flags" gnus-agent-synchronize-flags t] + )))) (defvar gnus-agent-summary-mode-map (make-sparse-keymap)) (gnus-define-keys gnus-agent-summary-mode-map "Jj" gnus-agent-toggle-plugged "Ju" gnus-agent-summary-fetch-group + "JS" gnus-agent-fetch-group + "Js" gnus-agent-summary-fetch-series "J#" gnus-agent-mark-article "J\M-#" gnus-agent-unmark-article "@" gnus-agent-toggle-mark @@ -363,31 +578,43 @@ node `(gnus)Server Buffer'.") (make-mode-line-mouse-map mouse-button mouse-func)) string)) -(defun gnus-agent-toggle-plugged (plugged) +(defun gnus-agent-toggle-plugged (set-to) "Toggle whether Gnus is unplugged or not." (interactive (list (not gnus-plugged))) - (if plugged - (progn - (setq gnus-plugged plugged) - (gnus-run-hooks 'gnus-agent-plugged-hook) - (setcar (cdr gnus-agent-mode-status) - (gnus-agent-make-mode-line-string " Plugged" - 'mouse-2 - 'gnus-agent-toggle-plugged)) - (gnus-agent-go-online gnus-agent-go-online) - (gnus-agent-possibly-synchronize-flags)) - (gnus-agent-close-connections) - (setq gnus-plugged plugged) - (gnus-run-hooks 'gnus-agent-unplugged-hook) - (setcar (cdr gnus-agent-mode-status) - (gnus-agent-make-mode-line-string " Unplugged" - 'mouse-2 - 'gnus-agent-toggle-plugged))) + (cond ((eq set-to gnus-plugged) + nil) + (set-to + (setq gnus-plugged set-to) + (gnus-run-hooks 'gnus-agent-plugged-hook) + (setcar (cdr gnus-agent-mode-status) + (gnus-agent-make-mode-line-string " Plugged" + 'mouse-2 + 'gnus-agent-toggle-plugged)) + (gnus-agent-go-online gnus-agent-go-online) + (gnus-agent-possibly-synchronize-flags)) + (t + (gnus-agent-close-connections) + (setq gnus-plugged set-to) + (gnus-run-hooks 'gnus-agent-unplugged-hook) + (setcar (cdr gnus-agent-mode-status) + (gnus-agent-make-mode-line-string " Unplugged" + 'mouse-2 + 'gnus-agent-toggle-plugged)))) (set-buffer-modified-p t)) +(defmacro gnus-agent-while-plugged (&rest body) + `(let ((original-gnus-plugged gnus-plugged)) + (unwind-protect + (progn (gnus-agent-toggle-plugged t) + ,@body) + (gnus-agent-toggle-plugged original-gnus-plugged)))) + +(put 'gnus-agent-while-plugged 'lisp-indent-function 0) +(put 'gnus-agent-while-plugged 'edebug-form-spec '(body)) + (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))))) @@ -415,10 +642,10 @@ node `(gnus)Server Buffer'.") ;;;###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 @@ -427,31 +654,43 @@ minor mode in all Gnus buffers." (gnus-open-agent) (add-hook 'gnus-setup-news-hook 'gnus-agent-queue-setup) (unless gnus-agent-send-mail-function - (setq gnus-agent-send-mail-function (or - message-send-mail-real-function - message-send-mail-function) + (setq gnus-agent-send-mail-function + (or message-send-mail-real-function + (function (lambda () (funcall 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 @@ -478,7 +717,8 @@ be a select method." "Restore GCC field from saved header." (save-excursion (goto-char (point-min)) - (while (re-search-forward (concat gnus-agent-gcc-header ":") nil t) + (while (re-search-forward + (concat "^" (regexp-quote gnus-agent-gcc-header) ":") nil t) (replace-match "Gcc:" 'fixedcase)))) (defun gnus-agent-any-covered-gcc () @@ -522,23 +762,18 @@ be a select method." (error "Groups can't be fetched when Gnus is unplugged")) (gnus-group-iterate n 'gnus-agent-fetch-group)) -(defun gnus-agent-fetch-group (group) +(defun gnus-agent-fetch-group (&optional group) "Put all new articles in GROUP into the Agent." (interactive (list (gnus-group-group-name))) - (let ((state gnus-plugged)) - (unwind-protect - (progn - (unless group - (error "No group on the current line")) - (unless state - (gnus-agent-toggle-plugged gnus-plugged)) - (let ((gnus-command-method (gnus-find-method-for-group group))) - (gnus-agent-with-fetch - (gnus-agent-fetch-group-1 group gnus-command-method) - (gnus-message 5 "Fetching %s...done" group)))) - (when (and (not state) - gnus-plugged) - (gnus-agent-toggle-plugged gnus-plugged))))) + (setq group (or group gnus-newsgroup-name)) + (unless group + (error "No group on the current line")) + + (gnus-agent-while-plugged + (let ((gnus-command-method (gnus-find-method-for-group group))) + (gnus-agent-with-fetch + (gnus-agent-fetch-group-1 group gnus-command-method) + (gnus-message 5 "Fetching %s...done" group))))) (defun gnus-agent-add-group (category arg) "Add the current group to an agent category." @@ -555,10 +790,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) @@ -567,15 +804,16 @@ 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 () "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))))) @@ -583,27 +821,40 @@ be a select method." "Synchronize flags according to `gnus-agent-synchronize-flags'." (interactive) (save-excursion - (dolist (gnus-command-method gnus-agent-covered-methods) - (when (file-exists-p (gnus-agent-lib-file "flags")) + (dolist (gnus-command-method (gnus-agent-covered-methods)) + (when (and (file-exists-p (gnus-agent-lib-file "flags")) + (not (eq (gnus-server-status gnus-command-method) 'offline))) (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) (defun gnus-agent-synchronize-flags-server (method) "Synchronize flags set when unplugged for server." - (let ((gnus-command-method method)) + (let ((gnus-command-method method) + (gnus-agent nil)) (when (file-exists-p (gnus-agent-lib-file "flags")) (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) (erase-buffer) (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) - (if (null (gnus-check-server gnus-command-method)) - (message "Couldn't open server %s" (nth 1 gnus-command-method)) - (while (not (eobp)) - (if (null (eval (read (current-buffer)))) - (progn (forward-line) - (kill-line -1)) - (write-file (gnus-agent-lib-file "flags")) - (error "Couldn't set flags from file %s" - (gnus-agent-lib-file "flags")))) - (delete-file (gnus-agent-lib-file "flags"))) + (cond ((null gnus-plugged) + (gnus-message + 1 "You must be plugged to synchronize flags with server %s" + (nth 1 gnus-command-method))) + ((null (gnus-check-server gnus-command-method)) + (gnus-message + 1 "Couldn't open server %s" (nth 1 gnus-command-method))) + (t + (condition-case err + (while t + (let ((bgn (point))) + (eval (read (current-buffer))) + (delete-region bgn (point)))) + (end-of-file + (delete-file (gnus-agent-lib-file "flags"))) + (error + (let ((file (gnus-agent-lib-file "flags"))) + (write-region (point-min) (point-max) + (gnus-agent-lib-file "flags") nil 'silent) + (error "Couldn't set flags from file %s due to %s" + file (error-message-string err))))))) (kill-buffer nil)))) (defun gnus-agent-possibly-synchronize-flags-server (method) @@ -615,49 +866,134 @@ be a select method." (cadr method))))) (gnus-agent-synchronize-flags-server method))) +;;;###autoload +(defun gnus-agent-rename-group (old-group new-group) + "Rename fully-qualified OLD-GROUP as NEW-GROUP. Always updates the agent, even when +disabled, as the old agent files would corrupt gnus when the agent was +next enabled. Depends upon the caller to determine whether group renaming is supported." + (let* ((old-command-method (gnus-find-method-for-group old-group)) + (old-path (directory-file-name + (let (gnus-command-method old-command-method) + (gnus-agent-group-pathname old-group)))) + (new-command-method (gnus-find-method-for-group new-group)) + (new-path (directory-file-name + (let (gnus-command-method new-command-method) + (gnus-agent-group-pathname new-group))))) + (gnus-rename-file old-path new-path t) + + (let* ((old-real-group (gnus-group-real-name old-group)) + (new-real-group (gnus-group-real-name new-group)) + (old-active (gnus-agent-get-group-info old-command-method old-real-group))) + (gnus-agent-save-group-info old-command-method old-real-group nil) + (gnus-agent-save-group-info new-command-method new-real-group old-active) + + (let ((old-local (gnus-agent-get-local old-group + old-real-group old-command-method))) + (gnus-agent-set-local old-group + nil nil + old-real-group old-command-method) + (gnus-agent-set-local new-group + (car old-local) (cdr old-local) + new-real-group new-command-method))))) + +;;;###autoload +(defun gnus-agent-delete-group (group) + "Delete fully-qualified GROUP. Always updates the agent, even when +disabled, as the old agent files would corrupt gnus when the agent was +next enabled. Depends upon the caller to determine whether group deletion is supported." + (let* ((command-method (gnus-find-method-for-group group)) + (path (directory-file-name + (let (gnus-command-method command-method) + (gnus-agent-group-pathname group))))) + (gnus-delete-directory path) + + (let* ((real-group (gnus-group-real-name group))) + (gnus-agent-save-group-info command-method real-group nil) + + (let ((local (gnus-agent-get-local group + real-group command-method))) + (gnus-agent-set-local group + nil nil + real-group command-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) - (message "Entered %s into the Agent" server))) + (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)) + (delete named-server gnus-agent-covered-methods) + gnus-agent-method-p-cache nil) + (gnus-server-update-server server) (gnus-agent-write-servers) - (message "Removed %s from the agent" server))) + (gnus-message 1 "Removed %s from the agent" server))) (defun gnus-agent-read-servers () "Read the alist of covered servers." - (mapcar (lambda (m) - (let ((server (gnus-server-get-method - nil - (or m "native")))) - (if server - (push server gnus-agent-covered-methods) - (message "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." @@ -665,7 +1001,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))))) ;;; @@ -708,61 +1044,120 @@ the actual number of articles toggled is returned." (gnus-agent-mark-article n 'toggle)) (defun gnus-summary-set-agent-mark (article &optional unmark) - "Mark ARTICLE as downloadable." - (let ((unmark (if (and (not (null unmark)) (not (eq t unmark))) - (memq article gnus-newsgroup-downloadable) - unmark))) - (if unmark - (progn - (setq gnus-newsgroup-downloadable - (delq article gnus-newsgroup-downloadable)) - (push article gnus-newsgroup-undownloaded)) - (setq gnus-newsgroup-undownloaded - (delq article gnus-newsgroup-undownloaded)) - (setq gnus-newsgroup-downloadable - (gnus-add-to-sorted-list gnus-newsgroup-downloadable article))) - (gnus-summary-update-mark - (if unmark gnus-undownloaded-mark gnus-downloadable-mark) - 'unread))) + "Mark ARTICLE as downloadable. If UNMARK is nil, article is marked. +When UNMARK is t, the article is unmarked. For any other value, the +article's mark is toggled." + (let ((unmark (cond ((eq nil unmark) + nil) + ((eq t unmark) + t) + (t + (memq article gnus-newsgroup-downloadable))))) + (when (gnus-summary-goto-subject article nil t) + (gnus-summary-update-mark + (if unmark + (progn + (setq gnus-newsgroup-downloadable + (delq article gnus-newsgroup-downloadable)) + (gnus-article-mark article)) + (setq gnus-newsgroup-downloadable + (gnus-add-to-sorted-list gnus-newsgroup-downloadable article)) + gnus-downloadable-mark) + 'unread)))) +;;;###autoload (defun gnus-agent-get-undownloaded-list () - "Mark all unfetched articles as read." + "Construct list of articles that have not been downloaded." (let ((gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name))) - (when (and (not (gnus-online gnus-command-method)) - (gnus-agent-method-p gnus-command-method)) - (gnus-agent-load-alist gnus-newsgroup-name) - ;; First mark all undownloaded articles as undownloaded. - ;; CCC kaig: Maybe change here to consider all headers. - (let ((articles (mapcar (lambda (header) (mail-header-number header)) - gnus-newsgroup-headers)) - (agent-articles gnus-agent-article-alist) - candidates article) - (while (setq article (pop articles)) - (while (and agent-articles - (< (caar agent-articles) article)) - (setq agent-articles (cdr agent-articles))) - (when (or (not (cdar agent-articles)) - (not (= (caar agent-articles) article))) - (push article candidates))) - (dolist (article candidates) - (unless (or (memq article gnus-newsgroup-downloadable) - (memq article gnus-newsgroup-cached)) - (push article gnus-newsgroup-undownloaded)))) - ;; Then mark downloaded downloadable as not-downloadable, - ;; if you get my drift. - (dolist (article gnus-newsgroup-downloadable) - (when (cdr (assq article gnus-agent-article-alist)) - (setq gnus-newsgroup-downloadable - (delq article gnus-newsgroup-downloadable))))))) + (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) '<)) + (cached (and gnus-use-cache gnus-newsgroup-cached)) + (undownloaded (list nil)) + (tail-undownloaded undownloaded) + (unfetched (list nil)) + (tail-unfetched unfetched)) + (while (and alist headers) + (let ((a (caar alist)) + (h (car headers))) + (cond ((< a h) + ;; Ignore IDs in the alist that are not being + ;; displayed in the summary. + (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) + (setq headers (cdr headers))) + ((cdar alist) + (setq alist (cdr alist)) + (setq headers (cdr headers)) + nil ; ignore already downloaded + ) + (t + (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))) + (gnus-agent-append-to-list tail-undownloaded num) + (gnus-agent-append-to-list tail-unfetched num))) + + (setq gnus-newsgroup-undownloaded (cdr undownloaded) + gnus-newsgroup-unfetched (cdr unfetched)))))) (defun gnus-agent-catchup () - "Mark all undownloaded articles as read." + "Mark as read all unhandled articles. +An article is unhandled if it is neither cached, nor downloaded, nor +downloadable." (interactive) (save-excursion - (while gnus-newsgroup-undownloaded - (gnus-summary-mark-article - (pop gnus-newsgroup-undownloaded) gnus-catchup-mark))) - (gnus-summary-position-point)) + (let ((articles gnus-newsgroup-undownloaded)) + (when (or gnus-newsgroup-downloadable + gnus-newsgroup-cached) + (setq articles (gnus-sorted-ndifference + (gnus-sorted-ndifference + (gnus-copy-sequence articles) + gnus-newsgroup-downloadable) + gnus-newsgroup-cached))) + + (while articles + (gnus-summary-mark-article + (pop articles) gnus-catchup-mark))) + (gnus-summary-position-point))) + +(defun gnus-agent-summary-fetch-series () + (interactive) + (when gnus-newsgroup-processable + (setq gnus-newsgroup-downloadable + (let* ((dl gnus-newsgroup-downloadable) + (gnus-newsgroup-downloadable + (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 + ;; article successfully fetched. + + ;; For each article that I processed, remove its + ;; processable mark IF the article is no longer + ;; downloadable (i.e. it's already downloaded) + (dolist (article gnus-newsgroup-processable) + (unless (memq article gnus-newsgroup-downloadable) + (gnus-summary-remove-process-mark article))) + (gnus-sorted-ndifference dl fetched-articles))))) (defun gnus-agent-summary-fetch-group (&optional all) "Fetch the downloadable articles in the group. @@ -772,24 +1167,31 @@ Optional arg ALL, if non-nil, means to fetch all articles." (if all gnus-newsgroup-articles gnus-newsgroup-downloadable)) (gnus-command-method (gnus-find-method-for-group gnus-newsgroup-name)) - (state gnus-plugged)) - (unwind-protect - (progn - (unless state - (gnus-agent-toggle-plugged t)) - (unless articles - (error "No articles to download")) - (gnus-agent-with-fetch - (gnus-agent-fetch-articles gnus-newsgroup-name articles)) - (save-excursion - (dolist (article articles) - (setq gnus-newsgroup-downloadable - (delq article gnus-newsgroup-downloadable)) - (if gnus-agent-mark-unread-after-downloaded - (gnus-summary-mark-article article gnus-unread-mark))))) - (when (and (not state) - gnus-plugged) - (gnus-agent-toggle-plugged nil))))) + fetched-articles) + (gnus-agent-while-plugged + (unless articles + (error "No articles to download")) + (gnus-agent-with-fetch + (setq gnus-newsgroup-undownloaded + (gnus-sorted-ndifference + gnus-newsgroup-undownloaded + (setq fetched-articles + (gnus-agent-fetch-articles + gnus-newsgroup-name articles))))) + (save-excursion + (dolist (article articles) + (let ((was-marked-downloadable + (memq article gnus-newsgroup-downloadable))) + (cond (gnus-agent-mark-unread-after-downloaded + (setq gnus-newsgroup-downloadable + (delq article gnus-newsgroup-downloadable)) + + (gnus-summary-mark-article article gnus-unread-mark)) + (was-marked-downloadable + (gnus-summary-set-agent-mark article t))) + (when (gnus-summary-goto-subject article nil t) + (gnus-summary-update-download-mark article)))))) + fetched-articles)) (defun gnus-agent-fetch-selected-article () "Fetch the current article as it is selected. @@ -797,105 +1199,212 @@ This can be added to `gnus-select-article-hook' or `gnus-mark-article-hook'." (let ((gnus-command-method gnus-current-select-method)) (when (and gnus-plugged (gnus-agent-method-p gnus-command-method)) - (let ((gnus-agent-current-history - (gnus-agent-history-buffer))) - (unless (and gnus-agent-current-history - (buffer-live-p gnus-agent-current-history)) - (gnus-agent-open-history) - (setq gnus-agent-current-history - (gnus-agent-history-buffer))) - (gnus-agent-fetch-articles - gnus-newsgroup-name - (list gnus-current-article)))))) + (when (gnus-agent-fetch-articles + gnus-newsgroup-name + (list gnus-current-article)) + (setq gnus-newsgroup-undownloaded + (delq gnus-current-article gnus-newsgroup-undownloaded)) + (gnus-summary-update-download-mark gnus-current-article))))) ;;; ;;; Internal functions ;;; -(defun gnus-agent-save-active (method) - (gnus-agent-save-active-1 method 'gnus-active-to-gnus-format)) +(defun gnus-agent-synchronize-group-flags (group actions server) +"Update a plugged group by performing the indicated actions." + (let* ((gnus-command-method (gnus-server-to-method server)) + (info + ;; This initializer is required as gnus-request-set-mark + ;; calls gnus-group-real-name to strip off the host name + ;; before calling the backend. Now that the backend is + ;; trying to call gnus-request-set-mark, I have to + ;; reconstruct the original group name. + (or (gnus-get-info group) + (gnus-get-info + (setq group (gnus-group-full-name + group gnus-command-method)))))) + (gnus-request-set-mark group actions) + + (when info + (dolist (action actions) + (let ((range (nth 0 action)) + (what (nth 1 action)) + (marks (nth 2 action))) + (dolist (mark marks) + (cond ((eq mark 'read) + (gnus-info-set-read + info + (funcall (if (eq what 'add) + 'gnus-range-add + 'gnus-remove-from-range) + (gnus-info-read info) + range)) + (gnus-get-unread-articles-in-group + info + (gnus-active (gnus-info-group info)))) + ((memq mark '(tick)) + (let ((info-marks (assoc mark (gnus-info-marks info)))) + (unless info-marks + (gnus-info-set-marks info (cons (setq info-marks (list mark)) (gnus-info-marks info)))) + (setcdr info-marks (funcall (if (eq what 'add) + 'gnus-range-add + 'gnus-remove-from-range) + (cdr info-marks) + range))))))))) + nil)) -(defun gnus-agent-save-active-1 (method function) +(defun gnus-agent-save-active (method) (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)))) + ;; 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-save-groups (method) - (gnus-agent-save-active-1 method 'gnus-groups-to-gnus-format)) +;;;###autoload +(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 (or (car active) 0)) + (active-max (or (cdr active) 0)) + (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) + (let* ((gnus-command-method (or method gnus-command-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)) - (insert (format "%S %d %d y\n" (intern group) - (cdr active) - (or oactive-min (car active)))) - (goto-char (point-max)) - (while (search-backward "\\." nil t) - (delete-char 1)))))) + (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))) + (when active + (insert (format "%S %d %d y\n" (intern group) + (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-get-group-info (method group) + "Get 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 (or method gnus-command-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-max) + (gnus-make-directory (file-name-directory file)) + (with-temp-buffer + ;; 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 + (setq oactive-max (read (current-buffer)) ;; max + oactive-min (read (current-buffer))) ;; min + (cons oactive-min oactive-max)))))))) (defun gnus-agent-group-path (group) - "Translate GROUP into a path." - (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) - ?/ ?_) - ?. ?_) - ?. ?/)))) - - + "Translate GROUP into a file name." + + ;; 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 (gnus-group-decoded-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 + (gnus-group-decoded-name group)) + (gnus-agent-directory)))) (defun gnus-agent-get-function (method) (if (gnus-online method) @@ -903,6 +1412,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 () @@ -923,14 +1436,6 @@ This can be added to `gnus-select-article-hook' or (nnheader-insert-file-contents file)) (set (make-local-variable 'gnus-agent-file-name) file)))) -(defun gnus-agent-save-history () - (save-excursion - (set-buffer gnus-agent-current-history) - (gnus-make-directory (file-name-directory gnus-agent-file-name)) - (let ((coding-system-for-write gnus-agent-file-coding-system)) - (write-region (1+ (point-min)) (point-max) - gnus-agent-file-name nil 'silent)))) - (defun gnus-agent-close-history () (when (gnus-buffer-live-p gnus-agent-current-history) (kill-buffer gnus-agent-current-history) @@ -938,37 +1443,6 @@ This can be added to `gnus-select-article-hook' or (delq (assoc (gnus-agent-method) gnus-agent-history-buffers) gnus-agent-history-buffers)))) -(defun gnus-agent-enter-history (id group-arts date) - (save-excursion - (set-buffer gnus-agent-current-history) - (goto-char (point-max)) - (let ((p (point))) - (insert id "\t" (number-to-string date) "\t") - (while group-arts - (insert (format "%S" (intern (caar group-arts))) - " " (number-to-string (cdr (pop group-arts))) - " ")) - (insert "\n") - (while (search-backward "\\." p t) - (delete-char 1))))) - -(defun gnus-agent-article-in-history-p (id) - (save-excursion - (set-buffer (gnus-agent-history-buffer)) - (goto-char (point-min)) - (search-forward (concat "\n" id "\t") nil t))) - -(defun gnus-agent-history-path (id) - (save-excursion - (set-buffer (gnus-agent-history-buffer)) - (goto-char (point-min)) - (when (search-forward (concat "\n" id "\t") nil t) - (let ((method (gnus-agent-method))) - (let (paths group) - (while (not (numberp (setq group (read (current-buffer))))) - (push (concat method "/" group) paths)) - (nreverse paths)))))) - ;;; ;;; Fetching ;;; @@ -976,81 +1450,172 @@ This can be added to `gnus-select-article-hook' or (defun gnus-agent-fetch-articles (group articles) "Fetch ARTICLES from GROUP and put them into the Agent." (when articles - ;; Prune off articles that we have already fetched. - (while (and articles - (cdr (assq (car articles) gnus-agent-article-alist))) - (pop articles)) - (let ((arts articles)) - (while (cdr arts) - (if (cdr (assq (cadr arts) gnus-agent-article-alist)) - (setcdr arts (cddr arts)) - (setq arts (cdr arts))))) - (when articles - (let ((dir (concat - (gnus-agent-directory) - (gnus-agent-group-path group) "/")) - (date (time-to-days (current-time))) - (case-fold-search t) - pos crosses id elem) - (gnus-make-directory dir) - (gnus-message 7 "Fetching articles for %s..." group) - ;; Fetch the articles from the backend. - (if (gnus-check-backend-function 'retrieve-articles group) - (setq pos (gnus-retrieve-articles articles group)) - (with-temp-buffer - (let (article) - (while (setq article (pop articles)) - (gnus-message 10 "Fetching article %s for %s..." - article group) - (when (or - (gnus-backlog-request-article group article - nntp-server-buffer) - (gnus-request-article article group)) - (goto-char (point-max)) - (push (cons article (point)) pos) - (insert-buffer-substring nntp-server-buffer))) - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) - (setq pos (nreverse pos))))) - ;; Then save these articles into the Agent. - (save-excursion - (set-buffer nntp-server-buffer) - (while pos - (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) - (goto-char (point-min)) - (unless (eobp) ;; Don't save empty articles. - (when (search-forward "\n\n" nil t) - (when (search-backward "\nXrefs: " nil t) - ;; Handle cross posting. - (skip-chars-forward "^ ") - (skip-chars-forward " ") - (setq crosses nil) - (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) +") - (push (cons (buffer-substring (match-beginning 1) - (match-end 1)) - (buffer-substring (match-beginning 2) - (match-end 2))) - crosses) - (goto-char (match-end 0))) - (gnus-agent-crosspost crosses (caar pos)))) - (goto-char (point-min)) - (if (not (re-search-forward - "^Message-ID: *<\\([^>\n]+\\)>" nil t)) - (setq id "No-Message-ID-in-article") - (setq id (buffer-substring (match-beginning 1) (match-end 1)))) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) - (concat dir (number-to-string (caar pos))) - nil 'silent)) - (when (setq elem (assq (caar pos) gnus-agent-article-alist)) - (setcdr elem t)) - (gnus-agent-enter-history - id (or crosses (list (cons group (caar pos)))) date)) - (widen) - (pop pos))) - (gnus-agent-save-alist group))))) - -(defun gnus-agent-crosspost (crosses article) + (gnus-agent-load-alist group) + (let* ((alist gnus-agent-article-alist) + (headers (if (< (length articles) 2) nil gnus-newsgroup-headers)) + (selected-sets (list nil)) + (current-set-size 0) + article + header-number) + ;; Check each article + (while (setq article (pop articles)) + ;; Skip alist entries preceeding this article + (while (> article (or (caar alist) (1+ article))) + (setq alist (cdr alist))) + + ;; Prune off articles that we have already fetched. + (unless (and (eq article (caar alist)) + (cdar alist)) + ;; Skip headers preceeding this article + (while (> article + (setq header-number + (let* ((header (car headers))) + (if header + (mail-header-number header) + (1+ article))))) + (setq headers (cdr headers))) + + ;; Add this article to the current set + (setcar selected-sets (cons article (car selected-sets))) + + ;; Update the set size, when the set is too large start a + ;; new one. I do this after adding the article as I want at + ;; least one article in each set. + (when (< gnus-agent-max-fetch-size + (setq current-set-size + (+ current-set-size + (if (= header-number article) + (let ((char-size (mail-header-chars + (car headers)))) + (if (<= char-size 0) + ;; 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)))) + (setcar selected-sets (nreverse (car selected-sets))) + (setq selected-sets (cons nil selected-sets) + current-set-size 0)))) + + (when (or (cdr selected-sets) (car selected-sets)) + (let* ((fetched-articles (list nil)) + (tail-fetched-articles fetched-articles) + (dir (gnus-agent-group-pathname group)) + (date (time-to-days (current-time))) + (case-fold-search t) + pos crosses id) + + (setcar selected-sets (nreverse (car selected-sets))) + (setq selected-sets (nreverse selected-sets)) + + (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. + (if (gnus-check-backend-function 'retrieve-articles group) + (setq pos (gnus-retrieve-articles articles group)) + (with-temp-buffer + (let (article) + (while (setq article (pop articles)) + (gnus-message 10 "Fetching article %s for %s..." + article group) + (when (or + (gnus-backlog-request-article group article + nntp-server-buffer) + (gnus-request-article article group)) + (goto-char (point-max)) + (push (cons article (point)) pos) + (insert-buffer-substring nntp-server-buffer))) + (copy-to-buffer + nntp-server-buffer (point-min) (point-max)) + (setq pos (nreverse pos))))) + ;; Then save these articles into the Agent. + (save-excursion + (set-buffer nntp-server-buffer) + (while pos + (narrow-to-region (cdar pos) (or (cdadr pos) (point-max))) + (goto-char (point-min)) + (unless (eobp) ;; Don't save empty articles. + (when (search-forward "\n\n" nil t) + (when (search-backward "\nXrefs: " nil t) + ;; Handle cross posting. + (goto-char (match-end 0)) ; move to end of header name + (skip-chars-forward "^ ") ; skip server name + (skip-chars-forward " ") + (setq crosses nil) + (while (looking-at "\\([^: \n]+\\):\\([0-9]+\\) *") + (push (cons (buffer-substring (match-beginning 1) + (match-end 1)) + (string-to-int + (buffer-substring (match-beginning 2) + (match-end 2)))) + crosses) + (goto-char (match-end 0))) + (gnus-agent-crosspost crosses (caar pos) date))) + (goto-char (point-min)) + (if (not (re-search-forward + "^Message-ID: *<\\([^>\n]+\\)>" nil t)) + (setq id "No-Message-ID-in-article") + (setq id (buffer-substring + (match-beginning 1) (match-end 1)))) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (write-region (point-min) (point-max) + (concat dir (number-to-string (caar pos))) + nil 'silent)) + + (gnus-agent-append-to-list + tail-fetched-articles (caar pos))) + (widen) + (setq pos (cdr pos))))) + + (gnus-agent-save-alist group (cdr fetched-articles) date) + (gnus-agent-update-files-total-fetched-for group (cdr fetched-articles)) + + (gnus-message 7 "")) + (cdr fetched-articles)))))) + +(defun gnus-agent-unfetch-articles (group articles) + "Delete ARTICLES that were fetched from GROUP into the agent." + (when articles + (gnus-agent-with-refreshed-group + group + (gnus-agent-load-alist group) + (let* ((alist (cons nil gnus-agent-article-alist)) + (articles (sort articles #'<)) + (next-possibility alist) + (delete-this (pop articles))) + (while (and (cdr next-possibility) delete-this) + (let ((have-this (caar (cdr next-possibility)))) + (cond ((< delete-this have-this) + (setq delete-this (pop articles))) + ((= delete-this have-this) + (let ((timestamp (cdar (cdr next-possibility)))) + (when timestamp + (let* ((file-name (concat (gnus-agent-group-pathname group) + (number-to-string have-this))) + (size-file (float (or (and gnus-agent-total-fetched-hashtb + (nth 7 (file-attributes file-name))) + 0)))) + (delete-file file-name) + (gnus-agent-update-files-total-fetched-for group (- size-file))))) + + (setcdr next-possibility (cddr next-possibility))) + (t + (setq next-possibility (cdr next-possibility)))))) + (setq gnus-agent-article-alist (cdr alist)) + (gnus-agent-save-alist group))))) + +(defun gnus-agent-crosspost (crosses article &optional date) + (setq date (or date t)) + (let (gnus-agent-article-alist group alist beg end) (save-excursion (set-buffer gnus-agent-overview-buffer) @@ -1063,7 +1628,7 @@ This can be added to `gnus-select-article-hook' or (unless (setq alist (assoc group gnus-agent-group-alist)) (push (setq alist (list group (gnus-agent-load-alist (caar crosses)))) gnus-agent-group-alist)) - (setcdr alist (cons (cons (cdar crosses) t) (cdr alist))) + (setcdr alist (cons (cons (cdar crosses) date) (cdr alist))) (save-excursion (set-buffer (gnus-get-buffer-create (format " *Gnus agent overview %s*" group))) @@ -1074,8 +1639,65 @@ This can be added to `gnus-select-article-hook' or (gnus-agent-article-name ".overview" group)))) (nnheader-find-nov-line (string-to-number (cdar crosses))) (insert (string-to-number (cdar crosses))) - (insert-buffer-substring gnus-agent-overview-buffer beg end)) - (pop crosses)))) + (insert-buffer-substring gnus-agent-overview-buffer beg end) + (gnus-agent-check-overview-buffer)) + (setq crosses (cdr crosses))))) + +(defun gnus-agent-backup-overview-buffer () + (when gnus-newsgroup-name + (let ((root (gnus-agent-article-name ".overview" gnus-newsgroup-name)) + (cnt 0) + name) + (while (file-exists-p + (setq name (concat root "~" + (int-to-string (setq cnt (1+ cnt))) "~")))) + (write-region (point-min) (point-max) name nil 'no-msg) + (gnus-message 1 "Created backup copy of overview in %s." name))) + t) + +(defun gnus-agent-check-overview-buffer (&optional buffer) + "Check the overview file given for sanity. +In particular, checks that the file is sorted by article number +and that there are no duplicates." + (let ((prev-num -1) + (backed-up nil)) + (save-excursion + (when buffer + (set-buffer buffer)) + (save-restriction + (widen) + (goto-char (point-min)) + + (while (< (point) (point-max)) + (let ((p (point)) + (cur (condition-case nil + (read (current-buffer)) + (error nil)))) + (cond + ((or (not (integerp cur)) + (not (eq (char-after) ?\t))) + (or backed-up + (setq backed-up (gnus-agent-backup-overview-buffer))) + (gnus-message 1 + "Overview buffer contains garbage '%s'." + (buffer-substring + p (point-at-eol)))) + ((= cur prev-num) + (or backed-up + (setq backed-up (gnus-agent-backup-overview-buffer))) + (gnus-message 1 + "Duplicate overview line for %d" cur) + (delete-region p (progn (forward-line 1) (point)))) + ((< cur prev-num) + (or backed-up + (setq backed-up (gnus-agent-backup-overview-buffer))) + (gnus-message 1 "Overview buffer not sorted!") + (sort-numeric-fields 1 (point-min) (point-max)) + (goto-char (point-min)) + (setq prev-num -1)) + (t + (setq prev-num cur))) + (forward-line 1))))))) (defun gnus-agent-flush-cache () (save-excursion @@ -1087,84 +1709,163 @@ This can be added to `gnus-select-article-hook' or (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 (caar gnus-agent-group-alist) + (with-temp-file (gnus-agent-article-name + ".agentview" (caar gnus-agent-group-alist)) (princ (cdar gnus-agent-group-alist)) + (insert "\n") + (princ 1 (current-buffer)) (insert "\n")) - (pop gnus-agent-group-alist)))) + (setq gnus-agent-group-alist (cdr gnus-agent-group-alist))))) + +;;;###autoload +(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) + (agent-predicate . gnus-agent-predicate))))))) (defun gnus-agent-fetch-headers (group &optional force) - (let ((articles - (if (and gnus-agent-consider-all-articles - ;; 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-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) - ;; Add articles with marks to the list of article headers we want to - ;; fetch. Don't fetch articles solely on the basis of a recent or seen - ;; mark, but do fetch recent or seen articles if they have other, more - ;; interesting marks. (We have to fetch articles with boring marks - ;; because otherwise the agent will remove their marks.) - (dolist (arts (gnus-info-marks (gnus-get-info group))) - (unless (memq (car arts) '(seen recent)) - (setq articles (gnus-range-add articles (cdr arts))))) - (setq articles (sort (gnus-uncompress-sequence articles) '<)) - ;; Note which headers are fetched, and don't fetch those again. - (gnus-agent-load-fetched-headers group) - (let ((new-fetched (gnus-range-add gnus-agent-fetched-headers - articles)) - (new-articles (gnus-list-range-difference - articles gnus-agent-fetched-headers))) - (gnus-agent-save-fetched-headers group new-fetched) - (setq articles new-articles)) - ;; Remove known articles. - (when (gnus-agent-load-alist group) - (let ((low (1+ (caar (last gnus-agent-article-alist)))) - (high (cdr (gnus-active group)))) - ;; I suspect a deeper problem here and I suspect that low - ;; should never be greater than high. But for the time being - ;; we just work around the problem and abstain from frobbing - ;; the article list in that case. If anyone knows how to - ;; properly deal with it, please holler. -- kai - (when (<= low high) - (setq articles (gnus-list-range-intersection - articles (list (cons low high))))))) - ;; Fetch them. - (gnus-make-directory (nnheader-translate-file-chars - (file-name-directory file) t)) - (when articles - (gnus-message 7 "Fetching headers for %s..." group) + "Fetch interesting headers into the agent. The group's overview +file will be updated to include the headers while a list of available +article numbers will be returned." + (let* ((fetch-all (and gnus-agent-consider-all-articles + ;; Do not fetch all headers if the predicate + ;; implies that we only consider unread articles. + (not (gnus-predicate-implies-unread + (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))) + + (unless fetch-all + ;; Add articles with marks to the list of article headers we want to + ;; fetch. Don't fetch articles solely on the basis of a recent or seen + ;; mark, but do fetch recent or seen articles if they have other, more + ;; interesting marks. (We have to fetch articles with boring marks + ;; because otherwise the agent will remove their marks.) + (dolist (arts (gnus-info-marks (gnus-get-info group))) + (unless (memq (car arts) '(seen recent killed cache)) + (setq articles (gnus-range-add articles (cdr arts))))) + (setq articles (sort (gnus-uncompress-sequence articles) '<))) + + ;; At this point, I have the list of articles to consider for + ;; fetching. This is the list that I'll return to my caller. Some + ;; of these articles may have already been fetched. That's OK as + ;; the fetch article code will filter those out. Internally, I'll + ;; filter this list to just those articles whose headers need to + ;; be fetched. + (let ((articles articles)) + ;; Remove known articles. + (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. + ;; Therefore, exclude only those headers that are in the + ;; article alist. + ;; NOTE: This is probably NOT what I want to do after + ;; agent expiration in this group. + (setq articles (gnus-agent-uncached-articles articles group)) + + ;; I want to only fetch those headers that have never been + ;; fetched. Therefore, exclude all headers that are, or + ;; WERE, in the article alist. + (let ((low (1+ (caar (last gnus-agent-article-alist)))) + (high (cdr (gnus-active group)))) + ;; Low can be greater than High when the same group is + ;; fetched twice in the same session {The first fetch will + ;; fill the article alist such that (last + ;; gnus-agent-article-alist) equals (cdr (gnus-active + ;; group))}. The addition of one(the 1+ above) then + ;; forces Low to be greater than High. When this happens, + ;; gnus-list-range-intersection returns nil which + ;; indicates that no headers need to be fetched. -- Kevin + (setq articles (gnus-list-range-intersection + articles (list (cons low high))))))) + + (gnus-message + 10 "gnus-agent-fetch-headers: undownloaded articles are '%s'" + (gnus-compress-sequence articles t)) + (save-excursion - (set-buffer nntp-server-buffer) - (unless (eq 'nov (gnus-retrieve-headers articles group)) - (nnvirtual-convert-headers)) - ;; Save these headers for later processing. - (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) - (when (file-exists-p file) - (gnus-agent-braid-nov group articles file)) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) file nil 'silent)) - (gnus-agent-save-alist group articles nil) - (gnus-agent-enter-history - "last-header-fetched-for-session" - (list (cons group (nth (- (length articles) 1) articles))) - (time-to-days (current-time))) - articles)))) + (set-buffer nntp-server-buffer) + + (if articles + (progn + (gnus-message 7 "Fetching headers for %s..." group) + + ;; Fetch them. + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file) t)) + + (unless (eq 'nov (gnus-retrieve-headers articles group)) + (nnvirtual-convert-headers)) + (gnus-agent-check-overview-buffer) + ;; Move these headers to the overview buffer so that + ;; gnus-agent-braid-nov can merge them with the contents + ;; of FILE. + (copy-to-buffer + gnus-agent-overview-buffer (point-min) (point-max)) + ;; NOTE: Call g-a-brand-nov even when the file does not + ;; exist. As a minimum, it will validate the article + ;; numbers already in the buffer. + (gnus-agent-braid-nov group articles file) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (gnus-agent-check-overview-buffer) + (write-region (point-min) (point-max) file nil 'silent)) + (gnus-agent-update-view-total-fetched-for group t) + (gnus-agent-save-alist group articles nil) + articles) + (ignore-errors + (erase-buffer) + (nnheader-insert-file-contents file))))) + articles)) + +(defsubst gnus-agent-read-article-number () + "Reads the article number at point. Returns nil when a valid article number can not be read." + + ;; It is unfortunite but the read function quietly overflows + ;; integer. As a result, I have to use string operations to test + ;; for overflow BEFORE calling read. + (when (looking-at "[0-9]+\t") + (let ((len (- (match-end 0) (match-beginning 0)))) + (cond ((< len 9) + (read (current-buffer))) + ((= len 9) + ;; Many 9 digit base-10 numbers can be represented in a 27-bit int + ;; Back convert from int to string to ensure that this is one of them. + (let* ((str1 (buffer-substring (match-beginning 0) (1- (match-end 0)))) + (num (read (current-buffer))) + (str2 (int-to-string num))) + (when (equal str1 str2) + num))))))) (defsubst gnus-agent-copy-nov-line (article) + "Copy the indicated ARTICLE from the overview buffer to the nntp server buffer." (let (art b e) (set-buffer gnus-agent-overview-buffer) (while (and (not (eobp)) - (< (setq art (read (current-buffer))) article)) + (or (not (setq art (gnus-agent-read-article-number))) + (< art article))) (forward-line 1)) (beginning-of-line) (if (or (eobp) @@ -1176,53 +1877,151 @@ This can be added to `gnus-select-article-hook' or (insert-buffer-substring gnus-agent-overview-buffer b e)))) (defun gnus-agent-braid-nov (group articles file) + "Merge agent overview data with given file. +Takes unvalidated headers for ARTICLES from +`gnus-agent-overview-buffer' and validated headers from the given +FILE and places the combined valid headers into +`nntp-server-buffer'. This function can be used, when file +doesn't exist, to valid the overview buffer." (let (start last) (set-buffer gnus-agent-overview-buffer) (goto-char (point-min)) (set-buffer nntp-server-buffer) (erase-buffer) - (nnheader-insert-file-contents file) + (when (file-exists-p file) + (nnheader-insert-file-contents file)) (goto-char (point-max)) + (forward-line -1) + (unless (or (= (point-min) (point-max)) - (progn - (forward-line -1) - (< (setq last (read (current-buffer))) (car articles)))) - ;; We do it the hard way. - (nnheader-find-nov-line (car articles)) + (< (setq last (read (current-buffer))) (car articles))) + ;; Old and new overlap -- We do it the hard way. + (when (nnheader-find-nov-line (car articles)) + ;; Replacing existing NOV entry + (delete-region (point) (progn (forward-line 1) (point)))) (gnus-agent-copy-nov-line (pop articles)) - (while (and articles - (not (eobp))) - (while (and (not (eobp)) - (< (read (current-buffer)) (car articles))) - (forward-line 1)) - (beginning-of-line) - (unless (eobp) - (gnus-agent-copy-nov-line (pop articles))))) - ;; Copy the rest lines - (set-buffer nntp-server-buffer) + + (ignore-errors + (while articles + (while (let ((art (read (current-buffer)))) + (cond ((< art (car articles)) + (forward-line 1) + t) + ((= art (car articles)) + (beginning-of-line) + (delete-region + (point) (progn (forward-line 1) (point))) + nil) + (t + (beginning-of-line) + nil)))) + + (gnus-agent-copy-nov-line (pop articles))))) + (goto-char (point-max)) + + ;; Append the remaining lines (when articles (when last (set-buffer gnus-agent-overview-buffer) - (while (and (not (eobp)) - (<= (read (current-buffer)) last)) - (forward-line 1)) - (beginning-of-line) (setq start (point)) (set-buffer nntp-server-buffer)) - (insert-buffer-substring gnus-agent-overview-buffer start)))) + + (let ((p (point))) + (insert-buffer-substring gnus-agent-overview-buffer start) + (goto-char p)) + + (setq last (or last -134217728)) + (let (sort art) + (while (not (eobp)) + (setq art (gnus-agent-read-article-number)) + (cond ((not art) + ;; Bad art num - delete this line + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point)))) + ((< art last) + ;; Art num out of order - enable sort + (setq sort t) + (forward-line 1)) + (t + ;; Good art num + (setq last art) + (forward-line 1)))) + (when sort + (sort-numeric-fields 1 (point-min) (point-max))))))) + +;; Keeps the compiler from warning about the free variable in +;; gnus-agent-read-agentview. +(eval-when-compile + (defvar gnus-agent-read-agentview)) (defun gnus-agent-load-alist (group) "Load the article-state alist for GROUP." - (setq gnus-agent-article-alist - (gnus-cache-file-contents - (gnus-agent-article-name ".agentview" group) - 'gnus-agent-file-loading-cache - 'gnus-agent-read-file))) - -;; Why do we have to create the directory for the .fetched files (see -;; function gnus-agent-save-fetched-headers below) but not for the -;; .agentview files? + ;; Bind free variable that's used in `gnus-agent-read-agentview'. + (let ((gnus-agent-read-agentview group)) + (setq gnus-agent-article-alist + (gnus-cache-file-contents + (gnus-agent-article-name ".agentview" group) + 'gnus-agent-file-loading-cache + 'gnus-agent-read-agentview)))) + +;; Save format may be either 1 or 2. Two is the new, compressed +;; format that is still being tested. Format 1 is uncompressed but +;; known to be reliable. +(defconst gnus-agent-article-alist-save-format 2) + +(defun gnus-agent-read-agentview (file) + "Load FILE and do a `read' there." + (with-temp-buffer + (condition-case nil + (progn + (nnheader-insert-file-contents file) + (goto-char (point-min)) + (let ((alist (read (current-buffer))) + (version (condition-case nil (read (current-buffer)) + (end-of-file 0))) + changed-version) + + (cond + ((< version 2) + (error "gnus-agent-read-agentview no longer supports version %d. Stop gnus, manually evaluate gnus-agent-convert-to-compressed-agentview, then restart gnus." version)) + ((= version 0) + (let ((inhibit-quit t) + entry) + (gnus-agent-open-history) + (set-buffer (gnus-agent-history-buffer)) + (goto-char (point-min)) + (while (not (eobp)) + (if (and (looking-at + "[^\t\n]+\t\\([0-9]+\\)\t\\([^ \n]+\\) \\([0-9]+\\)") + (string= (match-string 2) + gnus-agent-read-agentview) + (setq entry (assoc (string-to-number (match-string 3)) alist))) + (setcdr entry (string-to-number (match-string 1)))) + (forward-line 1)) + (gnus-agent-close-history) + (setq changed-version t))) + ((= version 1) + (setq changed-version (not (= 1 gnus-agent-article-alist-save-format)))) + ((= version 2) + (let (uncomp) + (mapcar + (lambda (comp-list) + (let ((state (car comp-list)) + (sequence (inline + (gnus-uncompress-range + (cdr comp-list))))) + (mapcar (lambda (article-id) + (setq uncomp (cons (cons article-id state) uncomp))) + sequence))) + alist) + (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)) + (file-error nil)))) + (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) @@ -1231,7 +2030,7 @@ This can be added to `gnus-select-article-hook' or print-level print-length item article) (while (setq article (pop articles)) (while (and (cdr prev) - (< (caadr prev) article)) + (< (caadr prev) article)) (setq prev (cdr prev))) (cond ((not (cdr prev)) @@ -1242,36 +2041,182 @@ This can be added to `gnus-select-article-hook' or (setcdr (cadr prev) state))) (setq prev (cdr prev))) (setq gnus-agent-article-alist (cdr all)) + + (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) - (princ gnus-agent-article-alist (current-buffer)) - (insert "\n")))) - -(defun gnus-agent-load-fetched-headers (group) - "Load ranges of fetched headers for GROUP." - (setq gnus-agent-fetched-headers - (gnus-cache-file-contents - (gnus-agent-article-name ".fetched" group) - 'gnus-agent-file-header-cache - 'gnus-agent-read-file))) - -(defun gnus-agent-save-fetched-headers (group range) - "Save ranges of fetched headers for GROUP. -This range includes nonexisting articles." - (let ((file-name-coding-system nnmail-pathname-coding-system) - (fetched-file (gnus-agent-article-name ".fetched" group)) - print-level print-length) - (setq gnus-agent-fetched-headers range) - (unless (file-exists-p (file-name-directory fetched-file)) - (make-directory (file-name-directory fetched-file) t)) - (with-temp-file fetched-file - (princ gnus-agent-fetched-headers (current-buffer)) - (insert "\n")))) + (cond ((eq gnus-agent-article-alist-save-format 1) + (princ gnus-agent-article-alist (current-buffer))) + ((eq gnus-agent-article-alist-save-format 2) + (let ((compressed nil)) + (mapcar (lambda (pair) + (let* ((article-id (car pair)) + (day-of-download (cdr pair)) + (comp-list (assq day-of-download compressed))) + (if comp-list + (setcdr comp-list + (cons article-id (cdr comp-list))) + (setq compressed + (cons (list day-of-download article-id) + compressed))) + nil)) gnus-agent-article-alist) + (mapcar (lambda (comp-list) + (setcdr comp-list + (gnus-compress-sequence + (nreverse (cdr comp-list))))) + compressed) + (princ compressed (current-buffer))))) + (insert "\n") + (princ gnus-agent-article-alist-save-format (current-buffer)) + (insert "\n")) + + (gnus-agent-update-view-total-fetched-for group nil))) + +(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 ((my-obarray (gnus-make-hashtable (count-lines (point-min) + (point-max)))) + (line 1)) + (with-temp-buffer + (condition-case nil + (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) + (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 my-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" my-obarray) nil) + (set (intern "+method" my-obarray) gnus-command-method) + my-obarray)) + +(defun gnus-agent-save-local (&optional force) + "Save gnus-agent-article-local under it method's agent.lib directory." + (let ((my-obarray gnus-agent-article-local)) + (when (and my-obarray + (or force (symbol-value (intern "+dirty" my-obarray)))) + (let* ((gnus-command-method (symbol-value (intern "+method" my-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 "")) + + (let ((buffer-file-coding-system gnus-agent-file-coding-system)) + (with-temp-file dest + (let ((gnus-command-method (symbol-value (intern "+method" my-obarray))) + (file-name-coding-system nnmail-pathname-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"))))) + my-obarray)))))))) + +(defun gnus-agent-get-local (group &optional gmane method) + (let* ((gmane (or gmane (gnus-group-real-name group))) + (gnus-command-method (or 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) + ((and min max) + (set symb (cons min max)) + t) + (t + (unintern symb local))) + (set (intern "+dirty" local) t)))) (defun gnus-agent-article-name (article group) - (expand-file-name (if (stringp article) article (string-to-number article)) + (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." @@ -1294,117 +2239,227 @@ This range includes nonexisting articles." (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 - (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? " (cadr err))) - (error "Cannot fetch articles into the Gnus agent"))) - (quit - (unless (funcall gnus-agent-confirmation-function - (format "Quit fetching session (%s). Continue? " - (cadr err))) - (signal 'quit "Cannot fetch articles into the Gnus agent")))) - (pop methods)) - (run-hooks 'gnus-agent-fetch-hook) + (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) + (if (or debug-on-error debug-on-quit) + (gnus-agent-fetch-group-1 + group gnus-command-method) + (condition-case err + (gnus-agent-fetch-group-1 + group gnus-command-method) + (error + (unless (funcall gnus-agent-confirmation-function + (format "Error %s while fetching session. Should gnus continue? " + (error-message-string err))) + (error "Cannot fetch articles into the Gnus agent"))) + (quit + (gnus-agent-regenerate-group group) + (unless (funcall gnus-agent-confirmation-function + (format + "%s while fetching session. Should gnus continue? " + (error-message-string err))) + (signal 'quit + "Cannot fetch articles into the Gnus agent"))))))))) + (setq methods (cdr methods))) + (gnus-run-hooks 'gnus-agent-fetched-hook) (gnus-message 6 "Finished fetching articles into the Gnus agent")))) (defun gnus-agent-fetch-group-1 (group method) "Fetch GROUP." (let ((gnus-command-method method) (gnus-newsgroup-name group) - gnus-newsgroup-dependencies gnus-newsgroup-headers - gnus-newsgroup-scored gnus-headers gnus-score - gnus-use-cache articles arts - category predicate info marks score-param + (gnus-newsgroup-dependencies gnus-newsgroup-dependencies) + (gnus-newsgroup-headers gnus-newsgroup-headers) + (gnus-newsgroup-scored gnus-newsgroup-scored) + (gnus-use-cache gnus-use-cache) (gnus-summary-expunge-below gnus-summary-expunge-below) (gnus-summary-mark-below gnus-summary-mark-below) (gnus-orphan-score gnus-orphan-score) ;; Maybe some other gnus-summary local variables should also ;; be put here. + + gnus-headers + gnus-score + articles arts + category predicate info marks score-param ) (unless (gnus-check-group group) (error "Can't open server for %s" group)) + ;; Fetch headers. - (when (and (or (gnus-active group) - (gnus-activate-group group)) - (setq articles (gnus-agent-fetch-headers group)) - (let ((nntp-server-buffer gnus-agent-overview-buffer)) - ;; Parse them and see which articles we want to fetch. - (setq gnus-newsgroup-dependencies - (make-vector (length articles) 0)) - (setq gnus-newsgroup-headers - (gnus-get-newsgroup-headers-xover articles nil nil - group)) - ;; Some articles may not exist, so update `articles' - ;; from what was actually found. -- kai - (setq articles - (mapcar (lambda (x) (aref x 0)) - gnus-newsgroup-headers)) - ;; `gnus-agent-overview-buffer' may be killed for - ;; timeout reason. If so, recreate it. - (gnus-agent-create-buffer))) - (setq category (gnus-group-category group)) - (setq predicate - (gnus-get-predicate - (or (gnus-group-find-parameter group 'agent-predicate t) - (cadr category)))) - (if (memq predicate '(gnus-agent-true gnus-agent-false)) - ;; Simple implementation - (setq arts (and (eq predicate 'gnus-agent-true) articles)) - (setq arts nil) - (setq score-param - (or (gnus-group-get-parameter group 'agent-score t) - (caddr category))) - ;; Translate score-param into real one - (cond - ((not score-param)) - ((eq score-param 'file) - (setq score-param (gnus-all-score-files group))) - ((stringp (car score-param))) - (t - (setq score-param (list (list score-param))))) - (when score-param - (gnus-score-headers score-param)) - (while (setq gnus-headers (pop gnus-newsgroup-headers)) - (setq gnus-score - (or (cdr (assq (mail-header-number gnus-headers) - gnus-newsgroup-scored)) - gnus-summary-default-score)) - (when (funcall predicate) - (push (mail-header-number gnus-headers) - arts)))) - ;; Fetch the articles. - (when arts - (gnus-agent-fetch-articles group arts))) - ;; Perhaps we have some additional articles to fetch. - (dolist (mark gnus-agent-download-marks) - (setq arts (assq mark (gnus-info-marks - (setq info (gnus-get-info group))))) - (when (cdr arts) - (gnus-message 8 "Agent is downloading marked articles...") - (gnus-agent-fetch-articles - group (gnus-uncompress-range (cdr arts))) - (when (eq mark 'download) - (setq marks (delq arts (gnus-info-marks info))) - (gnus-info-set-marks info marks) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string info) - ")"))))))) + (when (or gnus-newsgroup-active + (gnus-active group) + (gnus-activate-group group)) + (let ((marked-articles gnus-newsgroup-downloadable)) + ;; Identify the articles marked for download + (unless gnus-newsgroup-active + ;; The variable gnus-newsgroup-active was selected as I need + ;; a gnus-summary local variable that is NOT bound to any + ;; value (its global value should default to nil). + (dolist (mark gnus-agent-download-marks) + (let ((arts (cdr (assq mark (gnus-info-marks + (setq info (gnus-get-info group))))))) + (when arts + (setq marked-articles (nconc (gnus-uncompress-range arts) + marked-articles)) + )))) + (setq marked-articles (sort marked-articles '<)) + + ;; Fetch any new articles from the server + (setq articles (gnus-agent-fetch-headers group)) + + ;; Merge new articles with marked + (setq articles (sort (append marked-articles articles) '<)) + + (when articles + ;; Parse them and see which articles we want to fetch. + (setq gnus-newsgroup-dependencies + (or gnus-newsgroup-dependencies + (make-vector (length articles) 0))) + (setq gnus-newsgroup-headers + (or gnus-newsgroup-headers + (gnus-get-newsgroup-headers-xover articles nil nil + group))) + ;; `gnus-agent-overview-buffer' may be killed for + ;; timeout reason. If so, recreate it. + (gnus-agent-create-buffer) + + ;; Figure out how to select articles in this group + (setq category (gnus-group-category group)) + + (setq predicate + (gnus-get-predicate + (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 + (gnus-agent-find-parameter group 'agent-score-file))) + ;; Translate score-param into real one + (cond + ((not score-param)) + ((eq score-param 'file) + (setq score-param (gnus-all-score-files group))) + ((stringp (car score-param))) + (t + (setq score-param (list (list score-param))))) + (when score-param + (gnus-score-headers score-param)))) + + (unless (and (eq predicate 'gnus-agent-false) + (not marked-articles)) + (let ((arts (list nil))) + (let ((arts-tail arts) + (alist (gnus-agent-load-alist group)) + (marked-articles marked-articles) + (gnus-newsgroup-headers gnus-newsgroup-headers)) + (while (setq gnus-headers (pop gnus-newsgroup-headers)) + (let ((num (mail-header-number gnus-headers))) + ;; Determine if this article is already in the cache + (while (and alist + (> num (caar alist))) + (setq alist (cdr alist))) + + (unless (and (eq num (caar alist)) + (cdar alist)) + + ;; Determine if this article was marked for download. + (while (and marked-articles + (> num (car marked-articles))) + (setq marked-articles + (cdr marked-articles))) + + ;; When this article is marked, or selected by the + ;; predicate, add it to the download list + (when (or (eq num (car marked-articles)) + (let ((gnus-score + (or (cdr + (assq num gnus-newsgroup-scored)) + gnus-summary-default-score)) + (gnus-agent-long-article + (gnus-agent-find-parameter + group 'agent-long-article)) + (gnus-agent-short-article + (gnus-agent-find-parameter + group 'agent-short-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)))))) + + (let (fetched-articles) + ;; Fetch all selected articles + (setq gnus-newsgroup-undownloaded + (gnus-sorted-ndifference + gnus-newsgroup-undownloaded + (setq fetched-articles + (if (cdr arts) + (gnus-agent-fetch-articles group (cdr arts)) + nil)))) + + (let ((unfetched-articles + (gnus-sorted-ndifference (cdr arts) fetched-articles))) + (if gnus-newsgroup-active + ;; Update the summary buffer + (progn + (dolist (article marked-articles) + (gnus-summary-set-agent-mark article t)) + (dolist (article fetched-articles) + (if gnus-agent-mark-unread-after-downloaded + (gnus-summary-mark-article + article gnus-unread-mark)) + (when (gnus-summary-goto-subject article nil t) + (gnus-summary-update-download-mark article))) + (dolist (article unfetched-articles) + (gnus-summary-mark-article + article gnus-canceled-mark))) + + ;; Update the group buffer. + + ;; When some, or all, of the marked articles came + ;; from the download mark. Remove that mark. I + ;; didn't do this earlier as I only want to remove + ;; the marks after the fetch is completed. + + (dolist (mark gnus-agent-download-marks) + (when (eq mark 'download) + (let ((marked-arts + (assq mark (gnus-info-marks + (setq info (gnus-get-info group)))))) + (when (cdr marked-arts) + (setq marks + (delq marked-arts (gnus-info-marks info))) + (gnus-info-set-marks info marks))))) + (let ((read (gnus-info-read + (or info (setq info (gnus-get-info group)))))) + (gnus-info-set-read + info (gnus-add-to-range read unfetched-articles))) + + (gnus-group-update-group group t) + (sit-for 0) + + (gnus-dribble-enter + (concat "(gnus-group-set-info '" + (gnus-prin1-to-string info) + ")")))))))))))) ;;; ;;; Agent Category Mode @@ -1426,6 +2481,9 @@ General format specifiers can also be used. See Info node (defvar gnus-category-mode-line-format "Gnus: %%b" "The format specification for the category mode line.") +(defvar gnus-agent-predicate 'false + "The selection predicate used when no other source is available.") + (defvar gnus-agent-short-article 100 "Articles that have fewer lines than this are short.") @@ -1465,6 +2523,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 @@ -1485,6 +2544,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] @@ -1498,7 +2558,7 @@ General format specifiers can also be used. See Info node All normal editing commands are switched off. \\ For more in-depth information on this mode, read the manual -(`\\[gnus-info-find-node]'). +\(`\\[gnus-info-find-node]'). The following commands are available: @@ -1522,7 +2582,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) @@ -1556,15 +2616,41 @@ 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 () "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))))) + (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 + (delq nil + (gnus-mapcar + (lambda (valu symb) + (if valu + (cons symb valu))) + (cdr c) + '(agent-predicate agent-score-file agent-groups)))) + c) + old-list))))) + (list (gnus-agent-cat-make 'default 'short))))) (defun gnus-category-write () "Write the category alist." @@ -1572,6 +2658,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) @@ -1579,9 +2675,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))))) @@ -1590,10 +2693,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 (cddr (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))))) @@ -1602,9 +2711,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))))) @@ -1621,8 +2737,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))) @@ -1632,7 +2750,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)) @@ -1694,9 +2812,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) @@ -1710,29 +2828,29 @@ 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) + (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 predicate for CATEGORY." + "Return the function implementing PREDICATE." (or (cdr (assoc predicate gnus-category-predicate-cache)) (let ((func (gnus-category-make-function predicate))) (setq gnus-category-predicate-cache @@ -1743,10 +2861,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." - ;; Todo: make this work in more cases. - (equal predicate '(not read))) + (eq t (gnus-function-implies-unread-1 + (gnus-category-make-function-1 predicate)))) + +(defun gnus-function-implies-unread-1 (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." @@ -1755,234 +2921,555 @@ 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) (assq 'default gnus-category-alist))) +(defun gnus-agent-expire-group (group &optional articles force) + "Expire all old articles in GROUP. +If you want to force expiring of certain articles, this function can +take ARTICLES, and FORCE parameters as well. + +The articles on which the expiration process runs are selected as follows: + if ARTICLES is null, all read and unmarked articles. + 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 + (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) + (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 (gnus-agent-group-pathname group))) + (gnus-agent-with-refreshed-group + group + (when (boundp 'gnus-agent-expire-current-dirs) + (set 'gnus-agent-expire-current-dirs + (cons dir + (symbol-value 'gnus-agent-expire-current-dirs)))) + + (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* ((bytes-freed 0) + (size-files-deleted 0.0) + (files-deleted 0) + (nov-entries-deleted 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))) + (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 excluded 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) + (buffer-disable-undo) + (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)))) + message-log-max) + (when (> new-completed completed) + (setq completed new-completed) + (gnus-message 7 "%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-agent-message 10 + "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 %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."))) + (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. + (let* ((file-name (nnheader-concat dir (number-to-string + article-number))) + (size (float (nth 7 (file-attributes file-name))))) + (incf bytes-freed size) + (incf size-files-deleted size) + (incf files-deleted) + (delete-file file-name)) + (push "expired cached article" actions)) + (setf (nth 1 entry) nil) + ) + + (when marker + (push "NOV entry removed" actions) + (goto-char marker) + + (incf nov-entries-deleted) + + (let ((from (point-at-bol)) + (to (progn (forward-line 1) (point)))) + (incf bytes-freed (- 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 (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 + (gnus-agent-append-to-list + tail-alist (cons article-number fetch-date)) + (push (format "Removed %s article number from \ +article alist" type) 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: %s:%d: Article kept as \ +expiration tests failed." group 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) + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (gnus-make-directory dir) + (write-region (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) + (gnus-agent-update-view-total-fetched-for group t))) + + (when (eq articles t) + (gnus-summary-update-info)))) + + (when (boundp 'gnus-agent-expire-stats) + (let ((stats (symbol-value 'gnus-agent-expire-stats))) + (incf (nth 2 stats) bytes-freed) + (incf (nth 1 stats) files-deleted) + (incf (nth 0 stats) nov-entries-deleted))) + + (gnus-agent-update-files-total-fetched-for group (- size-files-deleted))))))) + (defun gnus-agent-expire (&optional articles group force) "Expire all old articles. If you want to force expiring of certain articles, this function can -take ARTICLES, GROUP and FORCE parameters as well. Setting ARTICLES -and GROUP without FORCE is not supported." +take ARTICLES, GROUP and FORCE parameters as well. + +The articles on which the expiration process runs are selected as follows: + if ARTICLES is null, all read and unmarked articles. + if ARTICLES is t, all articles. + if ARTICLES is a list, just those articles. +Setting GROUP will limit expiration to that group. +FORCE is equivalent to setting the expiration predicates to true." (interactive) - (let ((methods (if group - (list (gnus-find-method-for-group group)) - gnus-agent-covered-methods)) - (day (if (numberp gnus-agent-expire-days) - (- (time-to-days (current-time)) gnus-agent-expire-days) - nil)) - (current-day (time-to-days (current-time))) - gnus-command-method sym arts pos - history overview file histories elem art nov-file low info - unreads marked article orig lowest highest found days) - (save-excursion - (setq overview (gnus-get-buffer-create " *expire overview*")) - (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)))))) - (let ((expiry-hashtb (gnus-make-hashtable 1023))) - (gnus-agent-open-history) - (set-buffer - (setq gnus-agent-current-history - (setq history (gnus-agent-history-buffer)))) - (goto-char (point-min)) - (if (and articles group force) ;; point usless without art+group - (while (setq article (pop articles)) - ;; try to find history entries for articles - (goto-char (point-min)) - (if (re-search-forward - (concat "^[^\t]*\t[^\t]*\t\(.* ?\)" - (format "%S" (gnus-group-prefixed-name - group gnus-command-method)) - " " - (number-to-string article) - " $") - nil t) - (setq pos (point)) - (setq pos nil)) - (setq sym (let ((obarray expiry-hashtb) s) - (intern group))) - (if (boundp sym) - (set sym (cons (cons article pos) - (symbol-value sym))) - (set sym (list (cons article pos))))) - ;; go through history file to find eligble articles - (when (> (buffer-size) 1) - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward "^\t") - (if (let ((fetch-date (read (current-buffer)))) - (if (numberp fetch-date) - ;; We now have the arrival day, so we see - ;; whether it's old enough to be expired. - (if (numberp day) - (> fetch-date day) - (skip-chars-forward "\t") - (setq found nil - days gnus-agent-expire-days) - (while (and (not found) - days) - (when (looking-at (caar days)) - (setq found (cadar days))) - (pop days)) - (> fetch-date (- current-day found))) - ;; History file is corrupted. - (gnus-message - 5 - (format "File %s is corrupted!" - (gnus-agent-lib-file "history"))) - (sit-for 1) - ;; Ignore it - t)) - ;; New article; we don't expire it. - (forward-line 1) - ;; Old article. Schedule it for possible nuking. - (while (not (eolp)) - (setq sym (let ((obarray expiry-hashtb) s) - (setq s (read (current-buffer))) - (if (stringp s) (intern s) s))) - (if (boundp sym) - (set sym (cons (cons (read (current-buffer)) (point)) - (symbol-value sym))) - (set sym (list (cons (read (current-buffer)) - (point))))) - (skip-chars-forward " ")) - (forward-line 1))))) - ;; We now have all articles that can possibly be expired. - (mapatoms - (lambda (sym) - (setq group (symbol-name sym) - arts (sort (symbol-value sym) 'car-less-than-car) - low (car (gnus-active group)) - info (gnus-get-info group) - unreads (ignore-errors - (gnus-list-of-unread-articles group)) - marked (nconc - (gnus-uncompress-range - (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range - (cdr (assq 'dormant - (gnus-info-marks info))))) - nov-file (gnus-agent-article-name ".overview" group) - lowest nil - highest nil) - (gnus-agent-load-alist group) - (gnus-message 5 "Expiring articles in %s" group) - (set-buffer overview) - (erase-buffer) - (when (file-exists-p nov-file) - (nnheader-insert-file-contents nov-file)) - (goto-char (point-min)) - (setq article 0) - (while (setq elem (pop arts)) - (setq article (car elem)) - (when (or (null low) - (< article low) - gnus-agent-expire-all - (and (not (memq article unreads)) - (not (memq article marked))) - force) - ;; Find and nuke the NOV line. - (while (and (not (eobp)) - (or (not (numberp - (setq art (read (current-buffer))))) - (< art article))) - (if (and (numberp art) - (file-exists-p - (gnus-agent-article-name - (number-to-string art) group))) - (progn - (unless lowest - (setq lowest art)) - (setq highest art) - (forward-line 1)) - ;; Remove old NOV lines that have no articles. - (gnus-delete-line))) - (if (or (eobp) - (/= art article)) - (beginning-of-line) - (gnus-delete-line)) - ;; Nuke the article. - (when (file-exists-p - (setq file (gnus-agent-article-name - (number-to-string article) - group))) - (delete-file file)) - ;; Schedule the history line for nuking. - (if (cdr elem) - (push (cdr elem) histories)))) - (gnus-make-directory (file-name-directory nov-file)) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) nov-file nil 'silent)) - ;; Delete the unwanted entries in the alist. - (setq gnus-agent-article-alist - (sort gnus-agent-article-alist 'car-less-than-car)) - (let* ((alist gnus-agent-article-alist) - (prev (cons nil alist)) - (first prev) - expired) - (while (and alist - (<= (caar alist) article)) - (if (or (not (cdar alist)) - (not (file-exists-p - (gnus-agent-article-name - (number-to-string - (caar alist)) - group)))) - (progn - (push (caar alist) expired) - (setcdr prev (setq alist (cdr alist)))) - (setq prev alist - alist (cdr alist)))) - (setq gnus-agent-article-alist (cdr first)) - (gnus-agent-save-alist group) - ;; Mark all articles up to the first article - ;; in `gnus-agent-article-alist' as read. - (when (and info (caar gnus-agent-article-alist)) - (setcar (nthcdr 2 info) - (gnus-range-add - (nth 2 info) - (cons 1 (- (caar gnus-agent-article-alist) 1))))) - ;; Maybe everything has been expired from - ;; `gnus-agent-article-alist' and so the above marking as - ;; read could not be conducted, or there are - ;; expired article within the range of the alist. - (when (and info - expired - (or (not (caar gnus-agent-article-alist)) - (> (car expired) - (caar gnus-agent-article-alist)))) - (setcar (nthcdr 2 info) - (gnus-add-to-range - (nth 2 info) - (nreverse expired)))) - (gnus-dribble-enter - (concat "(gnus-group-set-info '" - (gnus-prin1-to-string info) - ")"))) - (when lowest - (if (gnus-gethash group orig) - (setcar (gnus-gethash group orig) lowest) - (gnus-sethash group (cons lowest highest) orig)))) - expiry-hashtb) - (set-buffer history) - (setq histories (nreverse (sort histories '<))) - (while histories - (goto-char (pop histories)) - (gnus-delete-line)) - (gnus-agent-save-history) - (gnus-agent-close-history) - (gnus-write-active-file - (gnus-agent-lib-file "active") orig)) - (gnus-message 4 "Expiry...done")))))) + + (if group + (gnus-agent-expire-group group articles force) + (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)) + ;; 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)) + (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)))))))) + (kill-buffer overview)) + (gnus-agent-expire-unagentized-dirs) + (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 (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) + + (gnus-sethash gnus-agent-directory t keep) + (while gnus-agent-expire-current-dirs + (setq dir (pop gnus-agent-expire-current-dirs)) + (when (and (stringp dir) + (file-directory-p dir)) + (while (not (gnus-gethash dir keep)) + (gnus-sethash dir t keep) + (setq dir (file-name-directory (directory-file-name dir)))))) + + (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)))))))))) ;;;###autoload (defun gnus-agent-batch () @@ -1995,6 +3482,68 @@ and GROUP without FORCE is not supported." (gnus-group-send-queue) (gnus-agent-fetch-session))) +(defun gnus-agent-unread-articles (group) + (let* ((read (gnus-info-read (gnus-get-info group))) + (known (gnus-agent-load-alist group)) + (unread (list nil)) + (tail-unread unread)) + (while (and known read) + (let ((candidate (car (pop known)))) + (while (let* ((range (car read)) + (min (if (numberp range) range (car range))) + (max (if (numberp range) range (cdr range)))) + (cond ((or (not min) + (< candidate min)) + (gnus-agent-append-to-list tail-unread candidate) + nil) + ((> candidate max) + (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))) + +(defun gnus-agent-uncached-articles (articles group &optional cached-header) + "Restrict ARTICLES to numbers already fetched. +Returns a sublist of ARTICLES that excludes those article ids in GROUP +that have already been fetched. +If CACHED-HEADER is nil, articles are only excluded if the article itself +has been fetched." + + ;; Logically equivalent to: (gnus-sorted-difference articles (mapcar + ;; 'car gnus-agent-article-alist)) + + ;; Functionally, I don't need to construct a temp list using mapcar. + + (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)) + (tail-uncached uncached)) + (while (and ref arts) + (let ((v1 (car arts)) + (v2 (caar ref))) + (cond ((< v1 v2) ; v1 does not appear in the reference list + (gnus-agent-append-to-list tail-uncached v1) + (setq arts (cdr arts))) + ((= v1 v2) + (unless (or cached-header (cdar ref)) ; v1 is already cached + (gnus-agent-append-to-list tail-uncached v1)) + (setq arts (cdr arts)) + (setq ref (cdr ref))) + (t ; reference article (v2) preceeds the list being filtered + (setq ref (cdr ref)))))) + (while arts + (gnus-agent-append-to-list tail-uncached (pop arts))) + (cdr uncached)) + ;; if gnus-agent-load-alist fails, no articles are cached. + articles)) + (defun gnus-agent-retrieve-headers (articles group &optional fetch-old) (save-excursion (gnus-agent-create-buffer) @@ -2003,50 +3552,119 @@ and GROUP without FORCE is not supported." cached-articles uncached-articles) (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) + + ;; Populate temp buffer with known headers (when (file-exists-p file) (with-current-buffer gnus-agent-overview-buffer (erase-buffer) (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) - (nnheader-insert-nov-file file (car articles))) - (nnheader-find-nov-line (car articles)) - (while (not (eobp)) - (when (looking-at "[0-9]") - (push (read (current-buffer)) cached-articles)) - (forward-line 1)) - (setq cached-articles (nreverse cached-articles)))) - (if (setq uncached-articles - (gnus-sorted-difference articles cached-articles)) + (nnheader-insert-nov-file file (car articles))))) + + (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) - (unless (eq 'nov - (gnus-retrieve-headers - uncached-articles group fetch-old)) - (nnvirtual-convert-headers))) + (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)) + art) + (while (< (point) pm) + (when (setq art (gnus-agent-read-article-number)) + (gnus-agent-append-to-list tail-fetched-articles art)) + (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) (erase-buffer) + + ;; Copy the nntp-server-buffer to the temp buffer (set-buffer nntp-server-buffer) (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) - (when (and uncached-articles (file-exists-p file)) + + ;; Merge the temp buffer with the known headers (found on + ;; disk in FILE) into the nntp-server-buffer + (when uncached-articles (gnus-agent-braid-nov group uncached-articles file)) + + ;; Save the new set of known headers to FILE (set-buffer nntp-server-buffer) (let ((coding-system-for-write gnus-agent-file-coding-system)) + (gnus-agent-check-overview-buffer) (write-region (point-min) (point-max) file nil 'silent)) + + (gnus-agent-update-view-total-fetched-for group t) + + ;; 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) - (gnus-agent-open-history) - (setq gnus-agent-current-history (gnus-agent-history-buffer)) - (gnus-agent-enter-history - "last-header-fetched-for-session" - (list (cons group (nth (- (length articles) 1) articles))) - (time-to-days (current-time))) - (gnus-agent-save-history)) - (set-buffer nntp-server-buffer) + ) + + ;; Copy the temp buffer to the nntp-server-buffer + (set-buffer nntp-server-buffer) (erase-buffer) (insert-buffer-substring gnus-agent-overview-buffer))) + (if (and fetch-old (not (numberp fetch-old))) t ; Don't remove anything. @@ -2055,218 +3673,290 @@ and GROUP without FORCE is not supported." (car articles)) (car (last articles))) t) + 'nov)) (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 - (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) - (let ((coding-system-for-read gnus-cache-coding-system)) - (insert-file-contents file)) - t))) - -(defun gnus-agent-regenerate-group (group &optional clean) - "Regenerate GROUP." - (let ((dir (concat (gnus-agent-directory) - (gnus-agent-group-path group) "/")) - (file (gnus-agent-article-name ".overview" group)) - n point arts alist header new-alist changed) - (when (file-exists-p dir) - (setq arts - (sort (mapcar (lambda (name) (string-to-int name)) - (directory-files dir nil "^[0-9]+$" t)) - '<))) - (gnus-make-directory (nnheader-translate-file-chars - (file-name-directory file) t)) - (mm-with-unibyte-buffer - (if (file-exists-p file) - (let ((nnheader-file-coding-system - gnus-agent-file-coding-system)) - (nnheader-insert-file-contents file))) - (goto-char (point-min)) - (while (not (eobp)) - (while (not (or (eobp) (looking-at "[0-9]"))) - (setq point (point)) - (forward-line 1) - (delete-region point (point))) - (unless (eobp) - (setq n (read (current-buffer))) - (when (and arts (> n (car arts))) - (beginning-of-line) - (while (and arts (> n (car arts))) - (message "Regenerating NOV %s %d..." group (car arts)) - (mm-with-unibyte-buffer - (nnheader-insert-file-contents - (concat dir (number-to-string (car arts)))) - (nnheader-remove-body) - (setq header (nnheader-parse-naked-head))) - (mail-header-set-number header (car arts)) - (nnheader-insert-nov header) - (setq changed t) - (push (cons (car arts) t) alist) - (pop arts))) - (if (and arts (= n (car arts))) - (progn - (push (cons n t) alist) - (pop arts)) - (push (cons n nil) alist)) - (forward-line 1))) - (if changed - (let ((coding-system-for-write gnus-agent-file-coding-system)) - (write-region (point-min) (point-max) file nil 'silent)))) - (setq gnus-agent-article-alist nil) - (unless clean - (gnus-agent-load-alist group)) - (setq alist (sort alist 'car-less-than-car)) - (setq gnus-agent-article-alist (sort gnus-agent-article-alist - 'car-less-than-car)) - (while (and alist gnus-agent-article-alist) - (cond - ((< (caar alist) (caar gnus-agent-article-alist)) - (push (pop alist) new-alist)) - ((> (caar alist) (caar gnus-agent-article-alist)) - (push (list (car (pop gnus-agent-article-alist))) new-alist)) - (t - (pop gnus-agent-article-alist) - (while (and gnus-agent-article-alist - (= (caar alist) (caar gnus-agent-article-alist))) - (pop gnus-agent-article-alist)) - (push (pop alist) new-alist)))) - (while alist - (push (pop alist) new-alist)) - (while gnus-agent-article-alist - (push (list (car (pop gnus-agent-article-alist))) new-alist)) - (setq gnus-agent-article-alist (nreverse new-alist)) - (gnus-agent-save-alist group))) - -(defun gnus-agent-regenerate-history (group article) - (let ((file (concat (gnus-agent-directory) - (gnus-agent-group-path group) "/" - (number-to-string article))) id) - (mm-with-unibyte-buffer - (nnheader-insert-file-contents file) - (message-narrow-to-head) - (goto-char (point-min)) - (if (not (re-search-forward "^Message-ID: *<\\([^>\n]+\\)>" nil t)) - (setq id "No-Message-ID-in-article") - (setq id (buffer-substring (match-beginning 1) (match-end 1)))) - (gnus-agent-enter-history - id (list (cons group article)) - (time-to-days (nth 5 (file-attributes file))))))) + (when (and gnus-agent + (or gnus-agent-cache + (not gnus-plugged)) + (numberp article)) + (let* ((gnus-command-method (gnus-find-method-for-group group)) + (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)) + (erase-buffer) + (gnus-kill-all-overlays) + (let ((coding-system-for-read gnus-cache-coding-system)) + (insert-file-contents 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 a list, the specified articles will be marked as unread. +In addition, their NOV entries in .overview will be refreshed using +the articles' current headers. +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))) + (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 ((and (listp reread) (memq l1 reread)) + (gnus-delete-line) + (setq nov-arts (cdr nov-arts)) + (gnus-message 4 "gnus-agent-regenerate-group: NOV\ +entry of article %s deleted." l1)) + ((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\ + entries contained duplicate of article %s. Duplicate deleted." l1) + (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)))) + (when load + (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) + + ;; 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)))) + +<<<<<<< TREE + (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 (or (gnus-active group) + (gnus-activate-group group)))) + (gnus-agent-possibly-alter-active group group-active))))) + + (when (and reread gnus-agent-article-alist) + (gnus-make-ascending-articles-unread + group + (if (listp reread) + reread + (delq nil (mapcar (function (lambda (c) + (cond ((eq reread t) + (car c)) + ((cdr c) + (car c))))) + gnus-agent-article-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 (or (gnus-active group) + (gnus-activate-group group)))) + (gnus-agent-possibly-alter-active group group-active))))) + + (when (and reread gnus-agent-article-alist) + (gnus-make-ascending-articles-unread + group + (if (listp reread) + reread + (delq nil (mapcar (function (lambda (c) + (cond ((eq reread t) + (car c)) + ((cdr c) + (car c))))) + gnus-agent-article-alist)))) +>>>>>>> MERGE-SOURCE + + (when regenerated + (gnus-agent-update-files-total-fetched-for group nil))) + + (gnus-message 5 "") + regenerated))) ;;;###autoload -(defun gnus-agent-regenerate (&optional clean) +(defun gnus-agent-regenerate (&optional clean reread) "Regenerate all agent covered files. -If CLEAN, don't read existing active and agentview files." +If CLEAN, obsolete (ignore)." (interactive "P") - (message "Regenerating Gnus agent files...") - (dolist (gnus-command-method gnus-agent-covered-methods) - (let ((active-file (gnus-agent-lib-file "active")) - history-hashtb active-hashtb active-changed - history-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))))))) - (gnus-agent-open-history) - (setq history-hashtb (gnus-make-hashtable 1000)) - (with-current-buffer - (setq gnus-agent-current-history (gnus-agent-history-buffer)) - (goto-char (point-min)) - (forward-line 1) - (while (not (eobp)) - (if (looking-at - "\\([^\t\n]+\\)\t[0-9]+\t\\([^ \n]+\\) \\([0-9]+\\)") - (progn - (unless (string= (match-string 1) - "last-header-fetched-for-session") - (gnus-sethash (match-string 2) - (cons (string-to-number (match-string 3)) - (gnus-gethash-safe (match-string 2) - history-hashtb)) - history-hashtb)) - (forward-line 1)) - (setq point (point)) - (forward-line 1) - (delete-region point (point)) - (setq history-changed t)))) - (dolist (group (gnus-groups-from-server gnus-command-method)) - (gnus-agent-regenerate-group group clean) - (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))) - (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)))) - (let ((arts (sort (gnus-gethash-safe group history-hashtb) '<)) - n) - (gnus-sethash group arts history-hashtb) - (while (and arts gnus-agent-article-alist) - (cond - ((> (car arts) (caar gnus-agent-article-alist)) - (when (cdar gnus-agent-article-alist) - (gnus-agent-regenerate-history - group (caar gnus-agent-article-alist)) - (setq history-changed t)) - (setq n (car (pop gnus-agent-article-alist))) - (while (and gnus-agent-article-alist - (= n (caar gnus-agent-article-alist))) - (pop gnus-agent-article-alist))) - ((< (car arts) (caar gnus-agent-article-alist)) - (setq n (pop arts)) - (while (and arts (= n (car arts))) - (pop arts))) - (t - (setq n (car (pop gnus-agent-article-alist))) - (while (and gnus-agent-article-alist - (= n (caar gnus-agent-article-alist))) - (pop gnus-agent-article-alist)) - (setq n (pop arts)) - (while (and arts (= n (car arts))) - (pop arts))))) - (while gnus-agent-article-alist - (when (cdar gnus-agent-article-alist) - (gnus-agent-regenerate-history - group (caar gnus-agent-article-alist)) - (setq history-changed t)) - (pop gnus-agent-article-alist)))) - (when history-changed - (message "Regenerate the history file of %s:%s" - (car gnus-command-method) - (cadr gnus-command-method)) - (gnus-agent-save-history)) - (gnus-agent-close-history) - (when active-changed - (message "Regenerate %s" active-file) - (let ((nnmail-active-file-coding-system gnus-agent-file-coding-system)) - (gnus-write-active-file active-file active-hashtb))))) - (message "Regenerating Gnus agent files...done")) + (let (regenerated) + (gnus-message 4 "Regenerating Gnus agent files...") + (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)))) + (gnus-message 4 "Regenerating Gnus agent files...done") + + regenerated)) (defun gnus-agent-go-online (&optional force) "Switch servers into online status." @@ -2293,6 +3983,95 @@ If CLEAN, don't read existing active and agentview files." (if (eq status 'offline) 'offline 'online) (if (eq status 'offline) 'online 'offline)))) +(defun gnus-agent-group-covered-p (group) + (gnus-agent-method-p (gnus-group-method group))) + +;; Added to support XEmacs +(eval-and-compile + (unless (fboundp 'directory-files-and-attributes) + (defun directory-files-and-attributes (directory + &optional full match nosort) + (let (result) + (dolist (file (directory-files directory full match nosort)) + (push (cons file (file-attributes file)) result)) + (nreverse result))))) + +(defun gnus-agent-update-files-total-fetched-for + (group delta &optional method path) + "Update, or set, the total disk space used by the articles that the +agent has fetched." + (when gnus-agent-total-fetched-hashtb + (gnus-agent-with-refreshed-group + group + ;; if null, gnus-agent-group-pathname will calc method. + (let* ((gnus-command-method method) + (path (or path (gnus-agent-group-pathname group))) + (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) + (gnus-sethash path (make-list 3 0) + gnus-agent-total-fetched-hashtb)))) + (when (listp delta) + (if delta + (let ((sum 0.0) + file) + (while (setq file (pop delta)) + (incf sum (float (or (nth 7 (file-attributes + (nnheader-concat + path + (if (numberp file) + (number-to-string file) + file)))) 0)))) + (setq delta sum)) + (let ((sum 0.0) + (info (directory-files-and-attributes path nil "^-?[0-9]+$" t)) + file) + (while (setq file (pop info)) + (incf sum (float (or (nth 8 file) 0)))) + (setq delta sum)))) + + (setq gnus-agent-need-update-total-fetched-for t) + (incf (nth 2 entry) delta))))) + +(defun gnus-agent-update-view-total-fetched-for + (group agent-over &optional method path) + "Update, or set, the total disk space used by the .agentview and +.overview files. These files are calculated separately as they can be +modified." + (when gnus-agent-total-fetched-hashtb + (gnus-agent-with-refreshed-group + group + ;; if null, gnus-agent-group-pathname will calc method. + (let* ((gnus-command-method method) + (path (or path (gnus-agent-group-pathname group))) + (entry (or (gnus-gethash path gnus-agent-total-fetched-hashtb) + (gnus-sethash path (make-list 3 0) + gnus-agent-total-fetched-hashtb))) + (size (or (nth 7 (file-attributes + (nnheader-concat + path (if agent-over + ".overview" + ".agentview")))) + 0))) + (setq gnus-agent-need-update-total-fetched-for t) + (setf (nth (if agent-over 1 0) entry) size))))) + +(defun gnus-agent-total-fetched-for (group &optional method no-inhibit) + "Get the total disk space used by the specified GROUP." + (unless gnus-agent-total-fetched-hashtb + (setq gnus-agent-total-fetched-hashtb (gnus-make-hashtable 1024))) + + ;; if null, gnus-agent-group-pathname will calc method. + (let* ((gnus-command-method method) + (path (gnus-agent-group-pathname group)) + (entry (gnus-gethash path gnus-agent-total-fetched-hashtb))) + (if entry + (apply '+ entry) + (let ((gnus-agent-inhibit-update-total-fetched-for (not no-inhibit))) + (+ + (gnus-agent-update-view-total-fetched-for group nil method path) + (gnus-agent-update-view-total-fetched-for group t method path) + (gnus-agent-update-files-total-fetched-for group nil method path)))))) + (provide 'gnus-agent) +;;; arch-tag: b0ba4afc-5229-4cee-ad25-9956daa4e91e ;;; gnus-agent.el ends here