From fbf7c27401455124dfa6c90405d02940189eeb50 Mon Sep 17 00:00:00 2001 From: yamaoka Date: Wed, 5 Feb 2003 06:42:45 +0000 Subject: [PATCH] Synch to Oort Gnus. --- lisp/ChangeLog | 9 + lisp/gnus-agent.el | 626 ++++++++++++++++++++++++++++------------------------ 2 files changed, 345 insertions(+), 290 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 03200c9..a8d4886 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2003-02-05 Simon Josefsson + + * gnus-agent.el (gnus-agent-expire-days): Change default to nil. + (gnus-agent-expire): Don't expire if g-a-e-d is nil. + (gnus-agent-expire): Move most code into gnus-agent-expire-1. + (gnus-agent-expire-1): New. + (gnus-agent-expire-1): Move code into gnus-agent-expire-2. + (gnus-agent-expire-2): New. + 2003-02-05 Jesper Harder * gnus-util.el (gnus-delete-if): Rename to gnus-remove-if. diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index 94b1c3f..12338f1 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1,5 +1,5 @@ ;;; gnus-agent.el --- unplugged support for Semi-gnus -;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002 +;; Copyright (C) 1997, 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -63,12 +63,14 @@ :group 'gnus-agent :type 'integer) -(defcustom gnus-agent-expire-days 7 +(defcustom gnus-agent-expire-days nil "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." +This can also be a list of regexp/day pairs. The regexps will be +matched against group names. If nil, articles in the agent cache are +never expired." :group 'gnus-agent - :type 'integer) + :type '(choice (number :tag "days") + (const :tag "never" nil))) (defcustom gnus-agent-expire-all nil "If non-nil, also expire unread, ticked and dormant articles. @@ -2133,8 +2135,328 @@ return only unread articles." (or (gnus-gethash group gnus-category-group-cache) (assq 'default gnus-category-alist))) +(defun gnus-agent-expire-2 (expiring-group active articles overview day force) + (gnus-agent-load-alist expiring-group) + (gnus-message 5 "Expiring articles in %s" expiring-group) + (let* ((info (gnus-get-info expiring-group)) + (alist gnus-agent-article-alist) + (specials (if alist + (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 expiring-group))) + (t + ;; All articles EXCEPT those named by the caller are + ;; protected from expiration + (gnus-sorted-difference + (gnus-uncompress-range + (cons (caar alist) (caar (last alist)))) + (sort articles '<))))) + (marked ;; More articles that are exluded from the expiration process + (cond (gnus-agent-expire-all + ;; All articles are unmarked by global decree + nil) + ((eq articles t) + ;; All articles are unmarked by function parameter + nil) + (articles + ;; All articles may as well be unmarked as the + ;; unreads list already names the articles we are + ;; going to keep + nil) + (t + ;; Ticked and/or dormant articles are excluded from expiration + (nconc + (gnus-uncompress-range + (cdr (assq 'tick (gnus-info-marks info)))) + (gnus-uncompress-range + (cdr (assq 'dormant + (gnus-info-marks info)))))))) + (nov-file (concat dir ".overview")) + (cnt 0) + (completed -1) + dlist + type) + + ;; The normal article alist contains + ;; elements that look like (article# . + ;; fetch_date) I need to combine other + ;; information with this list. For + ;; example, a flag indicating that a + ;; particular article MUST BE KEPT. To + ;; do this, I'm going to transform the + ;; elements to look like (article# + ;; fetch_date keep_flag + ;; NOV_entry_marker) Later, I'll reverse + ;; the process to generate the expired + ;; article alist. + + ;; Convert the alist elements to + ;; (article# fetch_date nil nil). + (setq dlist (mapcar (lambda (e) (list (car e) (cdr e) nil nil)) alist)) + + ;; Convert the keep lists to elements + ;; that look like (article# nil + ;; keep_flag nil) then append it to the + ;; expanded dlist These statements are + ;; sorted by ascending precidence of the + ;; keep_flag. + (setq dlist (nconc dlist (mapcar (lambda (e) + (list e nil 'unread nil)) unreads))) + (setq dlist (nconc dlist (mapcar (lambda (e) + (list e nil 'marked nil)) marked))) + (setq dlist (nconc dlist (mapcar (lambda (e) + (list e nil 'special nil)) specials))) + + (set-buffer overview) + (erase-buffer) + (when (file-exists-p nov-file) + (gnus-message 7 "gnus-agent-expire: Loading overview...") + (nnheader-insert-file-contents nov-file) + (goto-char (point-min)) + + (let (p) + (while (< (setq p (point)) (point-max)) + (condition-case nil + ;; If I successfully read an + ;; integer (the plus zero + ;; ensures a numeric type), + ;; prepend a marker entry to + ;; the list + (push (list (+ 0 (read (current-buffer))) nil nil + (set-marker (make-marker) p)) dlist) + (error + (gnus-message 1 (concat "gnus-agent-expire: read error occurred " + "when reading expression at %s in %s. " + "Skipping to next line.") + (point) nov-file))) + ;; Whether I succeeded, or failed, + ;; it doesn't matter. Move to the + ;; next line then try again. + (forward-line 1))) + (gnus-message 7 "gnus-agent-expire: Loading overview... Done")) + (set-buffer-modified-p nil) + + ;; At this point, all of the information + ;; is in dlist. The only problem is + ;; that much of it is spread across + ;; multiple entries. Sort then MERGE!! + (gnus-message 7 "gnus-agent-expire: Sorting entries... ") + ;; If two entries have the same + ;; article-number then sort by ascending + ;; keep_flag. + (let ((special 0) + (marked 1) + (unread 2)) + (setq dlist + (sort dlist + (lambda (a b) + (cond ((< (nth 0 a) (nth 0 b)) + t) + ((> (nth 0 a) (nth 0 b)) + nil) + (t + (let ((a (or (symbol-value (nth 2 a)) 3)) + (b (or (symbol-value (nth 2 b)) 3))) + (<= a b)))))))) + (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") + (gnus-message 7 "gnus-agent-expire: Merging entries... ") + (let ((dlist dlist)) + (while (cdr dlist) ; I'm not at the end-of-list + (if (eq (caar dlist) (caadr dlist)) + (let ((first (cdr (car dlist))) + (secnd (cdr (cadr dlist)))) + (setcar first (or (car first) (car secnd))) ; fetch_date + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) (car secnd))) ; Keep_flag + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) (car secnd))) ; NOV_entry_marker + + (setcdr dlist (cddr dlist))) + (setq dlist (cdr dlist))))) + (gnus-message 7 "gnus-agent-expire: Merging entries... Done") + + (let* ((len (float (length dlist))) + (alist (list nil)) + (tail-alist alist)) + (while dlist + (let ((new-completed (truncate (* 100.0 (/ (setq cnt (1+ cnt)) len))))) + (when (> new-completed completed) + (setq completed new-completed) + (gnus-message 9 "%3d%% completed..." completed))) + (let* ((entry (car dlist)) + (article-number (nth 0 entry)) + (fetch-date (nth 1 entry)) + (keep (nth 2 entry)) + (marker (nth 3 entry))) + + (cond + ;; Kept articles are unread, marked, or special. + (keep + (when fetch-date + (unless (file-exists-p (concat dir (number-to-string + article-number))) + (setf (nth 1 entry) nil) + (gnus-message 3 (concat "gnus-agent-expire cleared download " + "flag on article %d as the cached " + "article file is missing.") + (caar dlist))) + (unless marker + (gnus-message 1 (concat "gnus-agent-expire detected a " + "missing NOV entry. Run " + "gnus-agent-regenerate-group to " + "restore it.")))) + (gnus-agent-append-to-list tail-alist (cons article-number fetch-date))) + + ;; The following articles are READ, UNMARKED, and ORDINARY. + ;; See if they can be EXPIRED!!! + ((setq type + (cond + ((not (integerp fetch-date)) + 'read) ;; never fetched article (may expire right now) + ((not (file-exists-p (concat dir (number-to-string + article-number)))) + (setf (nth 1 entry) nil) + 'externally-expired) ;; Can't find the cached + ;; article. Handle case as + ;; though this article was + ;; never fetched. + + ;; We now have the arrival day, so we see + ;; whether it's old enough to be expired. + ((< fetch-date day) + 'expired) + (force + 'forced))) + + ;; I found some reason to expire this entry. + + (let ((actions nil)) + (when (memq type '(forced expired)) + (ignore-errors ; Just being paranoid. + (delete-file (concat dir (number-to-string article-number))) + (push "expired cached article" actions)) + (setf (nth 1 entry) nil)) + + (when marker + (push "NOV entry removed" actions) + (goto-char marker) + (gnus-delete-line)) + + ;; If considering all articles is set, I can only expire + ;; article IDs that are no longer in the active range. + (if (and gnus-agent-consider-all-articles + (>= article-number (car active))) + ;; I have to keep this ID in the alist + (gnus-agent-append-to-list tail-alist + (cons article-number fetch-date)) + (push (format "Removed %s article number from article alist" + type) actions)) + + (gnus-message 7 "gnus-agent-expire: Article %d: %s" + article-number (mapconcat 'identity + actions ", ")))) + (t + (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 expiring-group)) + + (when (buffer-modified-p) + (gnus-make-directory dir) + (write-region-as-coding-system gnus-agent-file-coding-system + (point-min) (point-max) nov-file + nil 'silent) + ;; clear the modified flag as that I'm not confused by its + ;; status on the next pass through this routine. + (set-buffer-modified-p nil)) + + (when (eq articles t) + (gnus-summary-update-info)))))) + +(defun gnus-agent-expire-1 (&optional articles group force) + "Expire all old agent cached articles unconditionally. +See `gnus-agent-expire'." + (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)) + 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*")) + (unwind-protect + (while (setq gnus-command-method (pop methods)) + (when (file-exists-p (gnus-agent-lib-file "active")) + (with-temp-buffer + (nnheader-insert-file-contents + (gnus-agent-lib-file "active")) + (gnus-active-to-gnus-format + gnus-command-method + (setq orig (gnus-make-hashtable + (count-lines (point-min) (point-max)))))) + (dolist (expiring-group (gnus-groups-from-server + gnus-command-method)) + (if (or (not group) + (equal group expiring-group)) + (let* ((dir (concat + (gnus-agent-directory) + (gnus-agent-group-path expiring-group) + "/")) + (active + (gnus-gethash-safe expiring-group orig)) + (day (if (numberp day) + day + (let (found + (days gnus-agent-expire-days)) + (catch 'found + (while (and (not found) days) + (when (eq 0 (string-match + (caar days) + expiring-group)) + (throw 'found (- (time-to-days + (current-time)) + (cadar days)))) + (pop days)) + ;; No regexp matched so set + ;; a limit that will block + ;; expiration in this group. + 0))))) + + (when active + (gnus-agent-expire-2 expiring-group active + articles overview day force))))))) + (kill-buffer overview))))) + (defun gnus-agent-expire (&optional articles group force) - "Expire all old articles. + "Expire all old agent cached articles. If you want to force expiring of certain articles, this function can take ARTICLES, GROUP and FORCE parameters as well. @@ -2145,290 +2467,14 @@ The articles on which the expiration process runs are selected as follows: Setting GROUP will limit expiration to that group. FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (interactive) - - (if (or (not (eq articles t)) - (yes-or-no-p (concat "Are you sure that you want to expire all articles in " (if group group "every agentized group") "."))) - (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)) - 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*")) - (unwind-protect - (while (setq gnus-command-method (pop methods)) - (when (file-exists-p (gnus-agent-lib-file "active")) - (with-temp-buffer - (nnheader-insert-file-contents - (gnus-agent-lib-file "active")) - (gnus-active-to-gnus-format - gnus-command-method - (setq orig (gnus-make-hashtable - (count-lines (point-min) (point-max)))))) - (dolist (expiring-group (gnus-groups-from-server - gnus-command-method)) - (if (or (not group) - (equal group expiring-group)) - (let* ((dir (concat - (gnus-agent-directory) - (gnus-agent-group-path expiring-group) - "/")) - (active - (gnus-gethash-safe expiring-group orig)) - (day (if (numberp day) - day - (let (found - (days gnus-agent-expire-days)) - (catch 'found - (while (and (not found) days) - (when (eq 0 (string-match (caar days) expiring-group)) - (throw 'found (- (time-to-days (current-time)) (cadar days)))) - (pop days)) - ;; No regexp matched so set - ;; a limit that will block - ;; expiration in this group. - 0))))) - - (when active - (gnus-agent-load-alist expiring-group) - (gnus-message 5 "Expiring articles in %s" expiring-group) - (let* ((info (gnus-get-info expiring-group)) - (alist gnus-agent-article-alist) - (specials (if alist - (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 expiring-group))) - (t - ;; All articles EXCEPT those named by the caller are protected from expiration - (gnus-sorted-difference (gnus-uncompress-range (cons (caar alist) (caar (last alist)))) (sort articles '<))))) - (marked ;; More articles that are exluded from the expiration process - (cond (gnus-agent-expire-all - ;; All articles are unmarked by global decree - nil) - ((eq articles t) - ;; All articles are unmarked by function parameter - nil) - (articles - ;; All articles may as well be unmarked as the unreads list already names the articles we are going to keep - nil) - (t - ;; Ticked and/or dormant articles are excluded from expiration - (nconc - (gnus-uncompress-range - (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range - (cdr (assq 'dormant - (gnus-info-marks info)))))))) - (nov-file (concat dir ".overview")) - (cnt 0) - (completed -1) - dlist - type) - - ;; The normal article alist contains - ;; elements that look like (article# . - ;; fetch_date) I need to combine other - ;; information with this list. For - ;; example, a flag indicating that a - ;; particular article MUST BE KEPT. To - ;; do this, I'm going to transform the - ;; elements to look like (article# - ;; fetch_date keep_flag - ;; NOV_entry_marker) Later, I'll reverse - ;; the process to generate the expired - ;; article alist. - - ;; Convert the alist elements to - ;; (article# fetch_date nil nil). - (setq dlist (mapcar (lambda (e) (list (car e) (cdr e) nil nil)) alist)) - - ;; Convert the keep lists to elements - ;; that look like (article# nil - ;; keep_flag nil) then append it to the - ;; expanded dlist These statements are - ;; sorted by ascending precidence of the - ;; keep_flag. - (setq dlist (nconc dlist - (mapcar (lambda (e) (list e nil 'unread nil)) unreads))) - (setq dlist (nconc dlist - (mapcar (lambda (e) (list e nil 'marked nil)) marked))) - (setq dlist (nconc dlist - (mapcar (lambda (e) (list e nil 'special nil)) specials))) - - (set-buffer overview) - (erase-buffer) - (when (file-exists-p nov-file) - (gnus-message 7 "gnus-agent-expire: Loading overview...") - (nnheader-insert-file-contents nov-file) - (goto-char (point-min)) - - (let (p) - (while (< (setq p (point)) (point-max)) - (condition-case nil - ;; If I successfully read an - ;; integer (the plus zero - ;; ensures a numeric type), - ;; prepend a marker entry to - ;; the list - (push (list (+ 0 (read (current-buffer))) nil nil (set-marker (make-marker) p)) dlist) - (error - (gnus-message 1 "gnus-agent-expire: read error occurred when reading expression at %s in %s. Skipping to next line." (point) nov-file))) - ;; Whether I succeeded, or failed, - ;; it doesn't matter. Move to the - ;; next line then try again. - (forward-line 1))) - (gnus-message 7 "gnus-agent-expire: Loading overview... Done")) - (set-buffer-modified-p nil) - - ;; At this point, all of the information - ;; is in dlist. The only problem is - ;; that much of it is spread across - ;; multiple entries. Sort then MERGE!! - (gnus-message 7 "gnus-agent-expire: Sorting entries... ") - ;; If two entries have the same - ;; article-number then sort by ascending - ;; keep_flag. - (let ((special 0) - (marked 1) - (unread 2)) - (setq dlist - (sort dlist - (lambda (a b) - (cond ((< (nth 0 a) (nth 0 b)) - t) - ((> (nth 0 a) (nth 0 b)) - nil) - (t - (let ((a (or (symbol-value (nth 2 a)) 3)) - (b (or (symbol-value (nth 2 b)) 3))) - (<= a b)))))))) - (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") - (gnus-message 7 "gnus-agent-expire: Merging entries... ") - (let ((dlist dlist)) - (while (cdr dlist) ; I'm not at the end-of-list - (if (eq (caar dlist) (caadr dlist)) - (let ((first (cdr (car dlist))) - (secnd (cdr (cadr dlist)))) - (setcar first (or (car first) (car secnd))) ; fetch_date - (setq first (cdr first) - secnd (cdr secnd)) - (setcar first (or (car first) (car secnd))) ; Keep_flag - (setq first (cdr first) - secnd (cdr secnd)) - (setcar first (or (car first) (car secnd))) ; NOV_entry_marker - - (setcdr dlist (cddr dlist))) - (setq dlist (cdr dlist))))) - (gnus-message 7 "gnus-agent-expire: Merging entries... Done") - - (let* ((len (float (length dlist))) - (alist (list nil)) - (tail-alist alist)) - (while dlist - (let ((new-completed (truncate (* 100.0 (/ (setq cnt (1+ cnt)) len))))) - (when (> new-completed completed) - (setq completed new-completed) - (gnus-message 9 "%3d%% completed..." completed))) - (let* ((entry (car dlist)) - (article-number (nth 0 entry)) - (fetch-date (nth 1 entry)) - (keep (nth 2 entry)) - (marker (nth 3 entry))) - - (cond - ;; Kept articles are unread, marked, or special. - (keep - (when fetch-date - (unless (file-exists-p (concat dir (number-to-string article-number))) - (setf (nth 1 entry) nil) - (gnus-message 3 "gnus-agent-expire cleared download flag on article %d as the cached article file is missing." (caar dlist))) - (unless marker - (gnus-message 1 "gnus-agent-expire detected a missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) - (gnus-agent-append-to-list tail-alist (cons article-number fetch-date))) - - ;; The following articles are READ, UNMARKED, and ORDINARY. - ;; See if they can be EXPIRED!!! - ((setq type - (cond - ((not (integerp fetch-date)) - 'read) ;; never fetched article (may expire right now) - ((not (file-exists-p (concat dir (number-to-string article-number)))) - (setf (nth 1 entry) nil) - 'externally-expired) ;; Can't find the cached article. Handle case as though this article was never fetched. - - ;; We now have the arrival day, so we see - ;; whether it's old enough to be expired. - ((< fetch-date day) - 'expired) - (force - 'forced))) - - ;; I found some reason to expire this entry. - - (let ((actions nil)) - (when (memq type '(forced expired)) - (ignore-errors ; Just being paranoid. - (delete-file (concat dir (number-to-string article-number))) - (push "expired cached article" actions)) - (setf (nth 1 entry) nil) - ) - - (when marker - (push "NOV entry removed" actions) - (goto-char marker) - (gnus-delete-line)) - - ;; If considering all articles is set, I can only expire article IDs that are no longer in the active range. - (if (and gnus-agent-consider-all-articles - (>= article-number (car active))) - ;; I have to keep this ID in the alist - (gnus-agent-append-to-list tail-alist (cons article-number fetch-date)) - (push (format "Removed %s article number from article alist" type) actions)) - - (gnus-message 7 "gnus-agent-expire: Article %d: %s" article-number (mapconcat 'identity actions ", ")))) - (t - (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 expiring-group)) - - (when (buffer-modified-p) - (gnus-make-directory dir) - (write-region-as-coding-system - gnus-agent-file-coding-system - (point-min) (point-max) nov-file - nil 'silent) - ;; clear the modified flag as that I'm not confused by its status on the next pass through this routine. - (set-buffer-modified-p nil)) - - (when (eq articles t) - (gnus-summary-update-info))))))))))) - (kill-buffer overview))))) - (gnus-message 4 "Expiry...done")) + (if (and (not gnus-agent-expire-days) + (or (not (eq articles t)) + (yes-or-no-p (concat "Are you sure that you want to expire all " + "articles in " (if group group + "every agentized group") + ".")))) + (gnus-agent-expire-1 articles group force) + (gnus-message 4 "Expiry...done"))) ;;;###autoload (defun gnus-agent-batch () -- 1.7.10.4