diff -u lisp.cvs_ref/gnus-agent.el lisp/gnus-agent.el --- lisp.cvs_ref/gnus-agent.el Thu Nov 6 16:42:37 2003 +++ lisp/gnus-agent.el Wed Oct 22 07:31:39 2003 @@ -69,12 +69,9 @@ :type 'integer) (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." + "Read articles older than this will be expired." :group 'gnus-agent - :type '(choice (number :tag "days") - (sexp :tag "List" nil))) + :type '(number :tag "days")) (defcustom gnus-agent-expire-all nil "If non-nil, also expire unread, ticked and dormant articles. @@ -556,9 +553,11 @@ (defun gnus-agent-close-connections () "Close all methods covered by the Gnus agent." - (let ((methods gnus-agent-covered-methods)) - (while methods - (gnus-close-server (pop methods))))) + + (mapcar (lambda (method) + (gnus-close-server method)) + (gnus-agent-opened-methods))) + ;;;###autoload (defun gnus-unplugged () @@ -598,18 +597,19 @@ (unless gnus-agent-send-mail-function (setq gnus-agent-send-mail-function (or message-send-mail-real-function - message-send-mail-function) + message-send-mail-function) message-send-mail-real-function 'gnus-agent-send-mail)) (unless gnus-agent-covered-methods - (mapcar + (mapc (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)))) + (let ((method (gnus-server-to-method server))) + (if (memq (car method) + gnus-agent-auto-agentize-methods) + (setq gnus-agent-covered-methods + (cons (gnus-agent-covered-method method) + gnus-agent-covered-methods))))) + (cons gnus-select-method gnus-secondary-select-methods)))) (defun gnus-agent-queue-setup (&optional group-name) "Make sure the queue group exists. @@ -747,7 +747,7 @@ "Synchronize unplugged flags with servers." (interactive) (save-excursion - (dolist (gnus-command-method gnus-agent-covered-methods) + (dolist (gnus-command-method (gnus-agent-opened-methods)) (when (file-exists-p (gnus-agent-lib-file "flags")) (gnus-agent-synchronize-flags-server gnus-command-method))))) @@ -755,7 +755,7 @@ "Synchronize flags according to `gnus-agent-synchronize-flags'." (interactive) (save-excursion - (dolist (gnus-command-method gnus-agent-covered-methods) + (dolist (gnus-command-method (gnus-agent-opened-methods)) (when (file-exists-p (gnus-agent-lib-file "flags")) (gnus-agent-possibly-synchronize-flags-server gnus-command-method))))) @@ -798,7 +798,7 @@ (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) (when (gnus-agent-method-p method) (error "Server already in the agent program")) - (push method gnus-agent-covered-methods) + (push (gnus-agent-covered-method method) gnus-agent-covered-methods) (gnus-server-update-server server) (gnus-agent-write-servers) (gnus-message 1 "Entered %s into the Agent" server))) @@ -811,8 +811,11 @@ (let ((method (gnus-server-get-method nil (gnus-server-server-name)))) (unless (gnus-agent-method-p method) (error "Server not in the agent program")) - (setq gnus-agent-covered-methods - (delete method gnus-agent-covered-methods)) + + (setq gnus-agent-covered-methods + (gnus-delete-if method gnus-agent-covered-methods + #'gnus-methods-equal-p)) + (gnus-server-update-server server) (gnus-agent-write-servers) (gnus-message 1 "Removed %s from the agent" server))) @@ -824,8 +827,8 @@ nil (or m "native")))) (if method - (unless (member method gnus-agent-covered-methods) - (push method gnus-agent-covered-methods)) + (unless (gnus-agent-method-p method) + (push (gnus-agent-covered-method method) gnus-agent-covered-methods)) (gnus-message 1 "Ignoring disappeared server `%s'" m)))) (gnus-agent-read-file (nnheader-concat gnus-agent-directory "lib/servers")))) @@ -836,7 +839,7 @@ (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))))) ;;; @@ -1175,6 +1178,18 @@ (require 'nnagent) 'nnagent)) +(defun gnus-agent-opened-methods () + "Return the subset of opened methods that are covered by the agent." + + (let* ((opened-covered (cons nil nil)) + (opened-covered-head opened-covered)) + (mapc (lambda (method) + (setq method (car method)) + (if (gnus-agent-method-p method) + (setq opened-covered (setcdr opened-covered (cons method nil))))) + gnus-opened-servers) + (cdr opened-covered-head))) + ;;; History functions (defun gnus-agent-history-buffer () @@ -1783,7 +1798,7 @@ (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-opened-methods)) groups group gnus-command-method) (save-excursion (while methods @@ -2004,6 +2019,36 @@ (gnus-prin1-to-string info) ")")))))))))))) +(defun gnus-agent-unfetch-group (group articles) + "Remove ARTICLES for GROUP from the Agent." + (when articles + (gnus-agent-load-alist group) + + (let ((dir (gnus-agent-group-pathname group)) + (alist gnus-agent-article-alist) + (arts (sort articles #'<)) + changed) + + (while arts + (let ((art (pop arts))) + (while (let* ((entry (pop alist)) + (artnum (car entry))) + (and artnum + (cond ((< artnum art) + t) + ((and (= artnum art) + (cdr entry)) + (setq changed t) + (setcdr entry nil) + + (ignore-errors + (delete-file (concat dir (number-to-string art)))) + nil))))))) + + (if changed + (let ((inhibit-quit t)) + (gnus-agent-save-alist group)))))) + ;;; ;;; Agent Category Mode ;;; @@ -2458,29 +2503,46 @@ (if (not group) (gnus-agent-expire articles group force) - (if (or (not (eq articles t)) - (yes-or-no-p - (concat "Are you sure that you want to " - "expire all articles in " group "."))) - (let ((gnus-command-method (gnus-find-method-for-group group)) - (overview (gnus-get-buffer-create " *expire overview*")) - orig) - (unwind-protect - (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)) - (gnus-agent-write-active active-file orig t))) - (kill-buffer overview)))) - (gnus-message 4 "Expiry...done"))) + (let ( ;; Bind gnus-agent-expire-stats to enable tracking of expiration statistics + (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)) + (gnus-agent-write-active active-file orig t))) + (kill-buffer overview)))) + + (if (> gnus-verbose 4) + (let ((size (nth 2 gnus-agent-expire-stats)) + (units '(B KB MB GB))) + (while (and (> size 1024.0) + (cdr units)) + (setq size (/ size 1024.0) + units (cdr units))) + + (gnus-message 5 "Expiry recovered %d NOV entries, deleted %d files,\ + and freed %f %s." + (nth 0 gnus-agent-expire-stats) + (nth 1 gnus-agent-expire-stats) + size (car units))) + (gnus-message 4 "Expiry...done") + )))) (defun gnus-agent-expire-group-1 (group overview active articles force) ;; Internal function - requires caller to have set @@ -2499,7 +2561,10 @@ (gnus-message 5 "Expiry skipping over %s" group) (gnus-message 5 "Expiring articles in %s" group) (gnus-agent-load-alist group) - (let* ((info (gnus-get-info group)) + (let* ((stats (if (boundp 'gnus-agent-expire-stats) + (symbol-value 'gnus-agent-expire-stats) + (list 0 0 0.0))) + (info (gnus-get-info group)) (alist gnus-agent-article-alist) (day (- (time-to-days (current-time)) (gnus-agent-find-parameter group 'agent-days-until-old))) @@ -2539,7 +2604,7 @@ (cons (caar alist) (caar (last alist)))) (sort articles '<))))) - (marked ;; More articles that are exluded from the + (marked ;; More articles that are excluded from the ;; expiration process (cond (gnus-agent-expire-all ;; All articles are unmarked by global decree @@ -2691,8 +2756,8 @@ ;; Kept articles are unread, marked, or special. (keep (gnus-agent-message 10 - "gnus-agent-expire: Article %d: Kept %s article." - article-number keep) + "gnus-agent-expire: Article %d: Kept %s article%s." + article-number keep (if fetch-date " and file" "")) (when fetch-date (unless (file-exists-p (concat dir (number-to-string @@ -2736,8 +2801,11 @@ (let ((actions nil)) (when (memq type '(forced expired)) (ignore-errors ; Just being paranoid. - (delete-file (concat dir (number-to-string - article-number))) + (let ((file-name (concat dir (number-to-string + article-number)))) + (incf (nth 2 stats) (nth 7 (file-attributes file-name))) + (incf (nth 1 stats)) + (delete-file file-name)) (push "expired cached article" actions)) (setf (nth 1 entry) nil) ) @@ -2745,7 +2813,13 @@ (when marker (push "NOV entry removed" actions) (goto-char marker) - (gnus-delete-line)) + + (incf (nth 0 stats)) + + (let ((from (gnus-point-at-bol)) + (to (progn (forward-line 1) (point)))) + (incf (nth 2 stats) (- to from)) + (delete-region from to))) ;; If considering all articles is set, I can only ;; expire article IDs that are no longer in the @@ -2820,10 +2894,12 @@ (if (or (not (eq articles t)) (yes-or-no-p "Are you sure that you want to expire all \ articles in every agentized group.")) - (let ((methods gnus-agent-covered-methods) + (let ((methods (gnus-agent-opened-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 + (gnus-agent-expire-stats (list 0 0 0.0)) gnus-command-method overview orig) (setq overview (gnus-get-buffer-create " *expire overview*")) (unwind-protect @@ -2848,7 +2924,21 @@ (gnus-agent-write-active active-file orig t)))) (kill-buffer overview)) (gnus-agent-expire-unagentized-dirs) - (gnus-message 4 "Expiry...done"))))) + (if (> gnus-verbose 4) + (let ((size (nth 2 gnus-agent-expire-stats)) + (units '(B KB MB GB))) + (while (and (> size 1024.0) + (cdr units)) + (setq size (/ size 1024.0) + units (cdr units))) + + (gnus-message 5 "Expiry recovered %d NOV entries, deleted %d files,\ + and freed %f %s." + (nth 0 gnus-agent-expire-stats) + (nth 1 gnus-agent-expire-stats) + size (car units))) + (gnus-message 4 "Expiry...done") + ))))) (defun gnus-agent-expire-unagentized-dirs () (when (and gnus-agent-expire-unagentized-dirs @@ -2945,9 +3035,9 @@ (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)) + (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)))) @@ -2959,7 +3049,12 @@ (gnus-agent-append-to-list tail-unread candidate) nil) ((> candidate max) - (setq read (cdr read)))))))) + (setq read (cdr read)) + ;; return t so that I always loop one more + ;; time. If I just iterated off the end of + ;; read, min will become nil and the current + ;; candidate will be added to the unread list. + t)))))) (while known (gnus-agent-append-to-list tail-unread (car (pop known)))) (cdr unread))) @@ -3164,9 +3259,17 @@ def) def select))) - (intern-soft - (read-string - "Reread (nil)? (t=>all, nil=>none, some=>all downloaded): ")))) + (catch 'mark + (while (let ((c (read-char-exclusive "Mark as unread: (n)one / (a)ll / all (d)ownloaded articles? (n)"))) + (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))) + (message "Unexpected input") + (sit-for 1) + t))))) (gnus-message 5 "Regenerating in %s" group) (let* ((gnus-command-method (or gnus-command-method (gnus-find-method-for-group group))) @@ -3351,7 +3454,7 @@ (interactive "P") (let (regenerated) (gnus-message 4 "Regenerating Gnus agent files...") - (dolist (gnus-command-method gnus-agent-covered-methods) + (dolist (gnus-command-method (gnus-agent-opened-methods)) (let ((active-file (gnus-agent-lib-file "active")) active-hashtb active-changed point) @@ -3422,8 +3525,18 @@ (if (eq status 'offline) 'online 'offline)))) (defun gnus-agent-group-covered-p (group) - (member (gnus-group-method group) - gnus-agent-covered-methods)) + (gnus-agent-method-p (gnus-group-method group))) + +(defun gnus-agent-covered-method (method) + "When given a full select method, truncate it to the minimal method +stored in gnus-agent-covered-methods." + + (let ((select (nth 0 method))) + (if (memq 'address + (assoc (symbol-name select) + gnus-valid-select-methods)) + (list select (nth 1 method)) + (list select)))) (add-hook 'gnus-group-prepare-hook (lambda () diff -u lisp.cvs_ref/gnus-srvr.el lisp/gnus-srvr.el --- lisp.cvs_ref/gnus-srvr.el Thu Nov 6 16:42:39 2003 +++ lisp/gnus-srvr.el Sun Oct 19 22:16:03 2003 @@ -281,8 +281,7 @@ "(closed)") ((error) "(error)"))))) (gnus-tmp-agent (if (and gnus-agent - (member method - gnus-agent-covered-methods)) + (gnus-agent-method-p method)) " (agent)" ""))) (beginning-of-line) diff -u lisp.cvs_ref/gnus-start.el lisp/gnus-start.el --- lisp.cvs_ref/gnus-start.el Thu Nov 6 16:42:39 2003 +++ lisp/gnus-start.el Mon Oct 20 00:48:52 2003 @@ -658,6 +658,7 @@ ;; Clear other internal variables. (setq gnus-list-of-killed-groups nil gnus-have-read-active-file nil + gnus-agent-covered-methods nil gnus-newsrc-alist nil gnus-newsrc-hashtb nil gnus-killed-list nil diff -u lisp.cvs_ref/gnus-util.el lisp/gnus-util.el --- lisp.cvs_ref/gnus-util.el Thu Nov 6 16:42:40 2003 +++ lisp/gnus-util.el Thu Nov 6 16:50:37 2003 @@ -160,6 +160,22 @@ `(delete-region (gnus-point-at-bol) (progn (forward-line ,(or n 1)) (point)))) +(defun gnus-delete-if (elt list &optional func) + (setq func (or func #'equal)) + + (let* ((root (cons nil list)) + (at root)) + (while (cond ((not (cdr at)) + nil) + ((funcall func elt (cadr at)) + (setcdr at (cddr at)) + t) + (t + (setq at (cdr at)) + t))) + (cdr root))) + + (defun gnus-byte-code (func) "Return a form that can be `eval'ed based on FUNC." (let ((fval (indirect-function func))) diff -u lisp.cvs_ref/gnus.el lisp/gnus.el --- lisp.cvs_ref/gnus.el Thu Nov 6 16:42:40 2003 +++ lisp/gnus.el Thu Nov 6 16:48:19 2003 @@ -2236,7 +2236,11 @@ (defvar gnus-agent-fetching nil "Whether Gnus agent is in fetching mode.") -(defvar gnus-agent-covered-methods nil) +(defvar gnus-agent-covered-methods nil + "A list of abbreviated select methods. In this list, the +abbreviated select methods identify the back end to use (e.g. `nntp', +`nnimap', etc.) and the \"server name\". All other back end elements +removed.") (defvar gnus-command-method nil "Dynamically bound variable that says what the current back end is.") @@ -2348,7 +2352,7 @@ gnus-newsrc-alist gnus-server-alist gnus-killed-list gnus-zombie-list gnus-topic-topology gnus-topic-alist - gnus-agent-covered-methods gnus-format-specs) + gnus-format-specs) "Gnus variables saved in the quick startup file.") (defvar gnus-newsrc-alist nil @@ -3799,7 +3803,18 @@ (defun gnus-agent-method-p (method) "Say whether METHOD is covered by the agent." - (member method gnus-agent-covered-methods)) + (catch 'found-match + (let ((covered-methods gnus-agent-covered-methods)) + (while covered-methods + (let* ((covered-method (pop covered-methods)) + (covered-method-select (nth 0 covered-method)) + (covered-method-name (nth 1 covered-method)) + (method-select (nth 0 method)) + (method-name (nth 1 method))) + (if (and (eq covered-method-select method-select) + (or (not covered-method-name) + (equal covered-method-name method-name))) + (throw 'found-match t))))))) (defun gnus-online (method) (not