X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Fgnus.git-;a=blobdiff_plain;f=lisp%2Fgnus-agent.el;fp=lisp%2Fgnus-agent.el;h=61b218b3003b92ee3ab0d358acb7ef4a4fdb6c8f;hp=a8971889d3aca15b10fb3b412c257da64e5d4534;hb=0b5861a4ba4284582290efbc3f09fb49dd9f754f;hpb=aee15b3b79e95fd011d113d9e4bc354d1d55e51c diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index a897188..61b218b 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -1032,7 +1032,7 @@ This can be added to `gnus-select-article-hook' or (list gnus-current-article)) (setq gnus-newsgroup-undownloaded (delq gnus-current-article gnus-newsgroup-undownloaded)) - (gnus-summary-update-line gnus-current-article))))) + (gnus-summary-update-download-mark gnus-current-article))))) ;;; ;;; Internal functions @@ -2452,308 +2452,315 @@ FORCE is equivalent to setting the expiration predicates to true." ;; gnus-command-method, initialized overview buffer, and to have ;; provided a non-nil active - (if (eq 'DISABLE (gnus-agent-find-parameter group 'agent-enable-expiration)) - (gnus-message 5 "Expiry skipping over %s" group) - (gnus-message 5 "Expiring articles in %s" group) - (gnus-agent-load-alist group) - (let* ((info (gnus-get-info group)) - (alist gnus-agent-article-alist) - (dir (concat - (gnus-agent-directory) - (gnus-agent-group-path group) - "/")) - (day (- (time-to-days (current-time)) - (gnus-agent-find-parameter group 'agent-days-until-old))) - (specials (if (and alist - (not force)) - ;; This could be a bit of a problem. I need to - ;; keep the last article to avoid refetching - ;; headers when using nntp in the backend. At - ;; the same time, if someone uses a backend - ;; that supports article moving then I may have - ;; to remove the last article to complete the - ;; move. Right now, I'm going to assume that - ;; FORCE overrides specials. - (list (caar (last alist))))) - (unreads ;; Articles that are excluded from the - ;; expiration process - (cond (gnus-agent-expire-all - ;; All articles are marked read by global decree - nil) - ((eq articles t) - ;; All articles are marked read by function - ;; parameter - nil) - ((not articles) - ;; Unread articles are marked protected from - ;; expiration Don't call - ;; gnus-list-of-unread-articles as it returns - ;; articles that have not been fetched into the - ;; agent. - (ignore-errors - (gnus-agent-unread-articles group))) - (t - ;; All articles EXCEPT those named by the caller - ;; are protected from expiration - (gnus-sorted-difference - (gnus-uncompress-range - (cons (caar alist) - (caar (last alist)))) - (sort articles '<))))) - (marked ;; More articles that are exluded from the - ;; expiration process - (cond (gnus-agent-expire-all - ;; All articles are unmarked by global decree - nil) - ((eq articles t) - ;; All articles are unmarked by function - ;; parameter - nil) - (articles - ;; All articles may as well be unmarked as the - ;; unreads list already names the articles we are - ;; going to keep - nil) - (t - ;; Ticked and/or dormant articles are excluded - ;; from expiration - (nconc - (gnus-uncompress-range - (cdr (assq 'tick (gnus-info-marks info)))) - (gnus-uncompress-range - (cdr (assq 'dormant - (gnus-info-marks info)))))))) - (nov-file (concat dir ".overview")) - (cnt 0) - (completed -1) - dlist - type) - - ;; The normal article alist contains elements that look like - ;; (article# . fetch_date) I need to combine other - ;; information with this list. For example, a flag indicating - ;; that a particular article MUST BE KEPT. To do this, I'm - ;; going to transform the elements to look like (article# - ;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse - ;; the process to generate the expired article alist. - - ;; Convert the alist elements to (article# fetch_date nil - ;; nil). - (setq dlist (mapcar (lambda (e) - (list (car e) (cdr e) nil nil)) alist)) - - ;; Convert the keep lists to elements that look like (article# - ;; nil keep_flag nil) then append it to the expanded dlist - ;; These statements are sorted by ascending precidence of the - ;; keep_flag. - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'unread nil)) - unreads))) - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'marked nil)) - marked))) - (setq dlist (nconc dlist - (mapcar (lambda (e) - (list e nil 'special nil)) - specials))) - - (set-buffer overview) - (erase-buffer) - (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 \ + (let ((dir (concat + (gnus-agent-directory) + (gnus-agent-group-path group) + "/"))) + (when (boundp 'gnus-agent-expire-current-dirs) + (set 'gnus-agent-expire-current-dirs + (cons dir + (symbol-value 'gnus-agent-expire-current-dirs)))) + + (if (eq 'DISABLE (gnus-agent-find-parameter group + 'agent-enable-expiration)) + (gnus-message 5 "Expiry skipping over %s" group) + (gnus-message 5 "Expiring articles in %s" group) + (gnus-agent-load-alist group) + (let* ((info (gnus-get-info group)) + (alist gnus-agent-article-alist) + (day (- (time-to-days (current-time)) + (gnus-agent-find-parameter group 'agent-days-until-old))) + (specials (if (and alist + (not force)) + ;; This could be a bit of a problem. I need to + ;; keep the last article to avoid refetching + ;; headers when using nntp in the backend. At + ;; the same time, if someone uses a backend + ;; that supports article moving then I may have + ;; to remove the last article to complete the + ;; move. Right now, I'm going to assume that + ;; FORCE overrides specials. + (list (caar (last alist))))) + (unreads ;; Articles that are excluded from the + ;; expiration process + (cond (gnus-agent-expire-all + ;; All articles are marked read by global decree + nil) + ((eq articles t) + ;; All articles are marked read by function + ;; parameter + nil) + ((not articles) + ;; Unread articles are marked protected from + ;; expiration Don't call + ;; gnus-list-of-unread-articles as it returns + ;; articles that have not been fetched into the + ;; agent. + (ignore-errors + (gnus-agent-unread-articles group))) + (t + ;; All articles EXCEPT those named by the caller + ;; are protected from expiration + (gnus-sorted-difference + (gnus-uncompress-range + (cons (caar alist) + (caar (last alist)))) + (sort articles '<))))) + (marked ;; More articles that are exluded from the + ;; expiration process + (cond (gnus-agent-expire-all + ;; All articles are unmarked by global decree + nil) + ((eq articles t) + ;; All articles are unmarked by function + ;; parameter + nil) + (articles + ;; All articles may as well be unmarked as the + ;; unreads list already names the articles we are + ;; going to keep + nil) + (t + ;; Ticked and/or dormant articles are excluded + ;; from expiration + (nconc + (gnus-uncompress-range + (cdr (assq 'tick (gnus-info-marks info)))) + (gnus-uncompress-range + (cdr (assq 'dormant + (gnus-info-marks info)))))))) + (nov-file (concat dir ".overview")) + (cnt 0) + (completed -1) + dlist + type) + + ;; The normal article alist contains elements that look like + ;; (article# . fetch_date) I need to combine other + ;; information with this list. For example, a flag indicating + ;; that a particular article MUST BE KEPT. To do this, I'm + ;; going to transform the elements to look like (article# + ;; fetch_date keep_flag NOV_entry_marker) Later, I'll reverse + ;; the process to generate the expired article alist. + + ;; Convert the alist elements to (article# fetch_date nil + ;; nil). + (setq dlist (mapcar (lambda (e) + (list (car e) (cdr e) nil nil)) alist)) + + ;; Convert the keep lists to elements that look like (article# + ;; nil keep_flag nil) then append it to the expanded dlist + ;; These statements are sorted by ascending precidence of the + ;; keep_flag. + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'unread nil)) + unreads))) + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'marked nil)) + marked))) + (setq dlist (nconc dlist + (mapcar (lambda (e) + (list e nil 'special nil)) + specials))) + + (set-buffer overview) + (erase-buffer) + (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))))) - (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: Article %d: Kept %s article." - article-number keep) - (when fetch-date - (unless (file-exists-p - (concat dir (number-to-string - article-number))) - (setf (nth 1 entry) nil) - (gnus-agent-message 3 "gnus-agent-expire cleared \ + ;; Whether I succeeded, or failed, it doesn't matter. + ;; Move to the next line then try again. + (forward-line 1))) + + (gnus-message + 7 "gnus-agent-expire: Loading overview... Done")) + (set-buffer-modified-p nil) + + ;; At this point, all of the information is in dlist. The + ;; only problem is that much of it is spread across multiple + ;; entries. Sort then MERGE!! + (gnus-message 7 "gnus-agent-expire: Sorting entries... ") + ;; If two entries have the same article-number then sort by + ;; ascending keep_flag. + (let ((special 0) + (marked 1) + (unread 2)) + (setq dlist + (sort dlist + (lambda (a b) + (cond ((< (nth 0 a) (nth 0 b)) + t) + ((> (nth 0 a) (nth 0 b)) + nil) + (t + (let ((a (or (symbol-value (nth 2 a)) + 3)) + (b (or (symbol-value (nth 2 b)) + 3))) + (<= a b)))))))) + (gnus-message 7 "gnus-agent-expire: Sorting entries... Done") + (gnus-message 7 "gnus-agent-expire: Merging entries... ") + (let ((dlist dlist)) + (while (cdr dlist) ; I'm not at the end-of-list + (if (eq (caar dlist) (caadr dlist)) + (let ((first (cdr (car dlist))) + (secnd (cdr (cadr dlist)))) + (setcar first (or (car first) + (car secnd))) ; fetch_date + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) + (car secnd))) ; Keep_flag + (setq first (cdr first) + secnd (cdr secnd)) + (setcar first (or (car first) + (car secnd))) ; NOV_entry_marker + + (setcdr dlist (cddr dlist))) + (setq dlist (cdr dlist))))) + (gnus-message 7 "gnus-agent-expire: Merging entries... Done") + + (let* ((len (float (length dlist))) + (alist (list nil)) + (tail-alist alist)) + (while dlist + (let ((new-completed (truncate (* 100.0 + (/ (setq cnt (1+ cnt)) + len))))) + (when (> new-completed completed) + (setq completed new-completed) + (gnus-message 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: Article %d: Kept %s article." + article-number keep) + (when fetch-date + (unless (file-exists-p + (concat dir (number-to-string + article-number))) + (setf (nth 1 entry) nil) + (gnus-agent-message 3 "gnus-agent-expire cleared \ download flag on article %d as the cached article file is missing." - (caar dlist))) - (unless marker - (gnus-message 1 "gnus-agent-expire detected a \ + (caar dlist))) + (unless marker + (gnus-message 1 "gnus-agent-expire detected a \ missing NOV entry. Run gnus-agent-regenerate-group to restore it."))) - (gnus-agent-append-to-list - tail-alist - (cons article-number fetch-date))) - - ;; The following articles are READ, UNMARKED, and - ;; ORDINARY. See if they can be EXPIRED!!! - ((setq type - (cond - ((not (integerp fetch-date)) - 'read) ;; never fetched article (may expire - ;; right now) - ((not (file-exists-p - (concat dir (number-to-string - article-number)))) - (setf (nth 1 entry) nil) - 'externally-expired) ;; Can't find the cached - ;; article. Handle case - ;; as though this article - ;; was never fetched. - - ;; We now have the arrival day, so we see - ;; whether it's old enough to be expired. - ((< fetch-date day) - 'expired) - (force - 'forced))) - - ;; I found some reason to expire this entry. - - (let ((actions nil)) - (when (memq type '(forced expired)) - (ignore-errors ; Just being paranoid. - (delete-file (concat dir (number-to-string - article-number))) - (push "expired cached article" actions)) - (setf (nth 1 entry) nil) - ) - - (when marker - (push "NOV entry removed" actions) - (goto-char marker) - (gnus-delete-line)) - - ;; If considering all articles is set, I can only - ;; expire article IDs that are no longer in the - ;; active range. - (if (and gnus-agent-consider-all-articles - (>= article-number (car active))) - ;; I have to keep this ID in the alist - (gnus-agent-append-to-list - tail-alist (cons article-number fetch-date)) - (push (format "Removed %s article number from \ + (gnus-agent-append-to-list + tail-alist + (cons article-number fetch-date))) + + ;; The following articles are READ, UNMARKED, and + ;; ORDINARY. See if they can be EXPIRED!!! + ((setq type + (cond + ((not (integerp fetch-date)) + 'read) ;; never fetched article (may expire + ;; right now) + ((not (file-exists-p + (concat dir (number-to-string + article-number)))) + (setf (nth 1 entry) nil) + 'externally-expired) ;; Can't find the cached + ;; article. Handle case + ;; as though this article + ;; was never fetched. + + ;; We now have the arrival day, so we see + ;; whether it's old enough to be expired. + ((< fetch-date day) + 'expired) + (force + 'forced))) + + ;; I found some reason to expire this entry. + + (let ((actions nil)) + (when (memq type '(forced expired)) + (ignore-errors ; Just being paranoid. + (delete-file (concat dir (number-to-string + article-number))) + (push "expired cached article" actions)) + (setf (nth 1 entry) nil) + ) + + (when marker + (push "NOV entry removed" actions) + (goto-char marker) + (gnus-delete-line)) + + ;; If considering all articles is set, I can only + ;; expire article IDs that are no longer in the + ;; active range. + (if (and gnus-agent-consider-all-articles + (>= article-number (car active))) + ;; I have to keep this ID in the alist + (gnus-agent-append-to-list + tail-alist (cons article-number fetch-date)) + (push (format "Removed %s article number from \ article alist" type) actions)) - (gnus-agent-message 8 "gnus-agent-expire: Article %d: %s" - article-number - (mapconcat 'identity actions ", ")))) - (t - (gnus-agent-message - 10 "gnus-agent-expire: Article %d: Article kept as \ + (gnus-agent-message 8 "gnus-agent-expire: Article %d: %s" + article-number + (mapconcat 'identity actions ", ")))) + (t + (gnus-agent-message + 10 "gnus-agent-expire: Article %d: Article kept as \ expiration tests failed." article-number) - (gnus-agent-append-to-list - tail-alist (cons article-number fetch-date))) - ) + (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)) + ;; Clean up markers as I want to recycle this buffer + ;; over several groups. + (when marker + (set-marker marker nil)) - (setq dlist (cdr dlist)))) + (setq dlist (cdr dlist)))) - (setq alist (cdr alist)) + (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)) + (let ((inhibit-quit t)) + (unless (equal alist gnus-agent-article-alist) + (setq gnus-agent-article-alist alist) + (gnus-agent-save-alist group)) - (when (buffer-modified-p) - (gnus-make-directory dir) - (write-region-as-coding-system gnus-agent-file-coding-system - (point-min) (point-max) nov-file - nil 'silent) - ;; clear the modified flag as that I'm not confused by - ;; its status on the next pass through this routine. - (set-buffer-modified-p nil)) + (when (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))))))) + (when (eq articles t) + (gnus-summary-update-info)))))))) (defun gnus-agent-expire (&optional articles group force) "Expire all old articles. @@ -2774,6 +2781,9 @@ FORCE is equivalent to setting the expiration predicates to true." (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) gnus-command-method overview orig) (setq overview (gnus-get-buffer-create " *expire overview*")) (unwind-protect @@ -2796,8 +2806,79 @@ articles in every agentized group.")) (gnus-agent-expire-group-1 expiring-group overview active articles force))))))) (kill-buffer overview)) + (gnus-agent-expire-unagentized-dirs) (gnus-message 4 "Expiry...done"))))) +(defun gnus-agent-expire-unagentized-dirs () + (when (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) + (let ((files (directory-files d)) + file) + (while (setq file (pop files)) + (cond ((equal file ".") + nil) + ((equal file "..") + nil) + ((equal file ".overview") + (let ((d (file-name-as-directory d)) + r) + (while (not (gnus-gethash + (setq d (file-name-directory d)) keep)) + (setq r d + d (directory-file-name d))) + (if r + (push r to-remove)))) + ((file-directory-p (setq file (nnheader-concat d file))) + (funcall checker file))))))))) + (funcall checker gnus-agent-directory) + + (when (and to-remove + (gnus-y-or-n-p + "gnus-agent-expire has identified local directories that are\ + 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 () "Start Gnus, send queue and fetch session."