Function: gnus-agent-expire-group-1
gnus-agent-expire-group-1 is a byte-compiled function defined in
gnus-agent.el.gz.
Signature
(gnus-agent-expire-group-1 GROUP OVERVIEW ACTIVE ARTICLES FORCE)
Source Code
;; Defined in /usr/src/emacs/lisp/gnus/gnus-agent.el.gz
(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))
(file-name-coding-system nnmail-pathname-coding-system))
(gnus-agent-with-refreshed-group
group
(when (boundp 'gnus-agent-expire-current-dirs)
(push dir 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 nil)
(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
(range-uncompress
(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
(range-uncompress
(cdr (assq 'tick (gnus-info-marks info))))
(range-uncompress
(cdr (assq 'dormant
(gnus-info-marks info))))))))
(nov-file (concat dir ".overview"))
(cnt 0)
(completed -1)
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_position) Later, I'll reverse
;; the process to generate the expired article alist.
(dlist
(nconc
;; Convert the alist elements to (article# fetch_date nil nil).
(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 precedence of the
;; keep_flag.
(mapcar (lambda (e)
(list e nil 'unread nil))
unreads)
(mapcar (lambda (e)
(list e nil 'marked nil))
marked)
(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), append the position
;; to the list
(push (list (+ 0 (read (current-buffer))) nil nil
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... ")
(setq dlist
(sort dlist
(lambda (a b)
(cond ((< (nth 0 a) (nth 0 b))
t)
((> (nth 0 a) (nth 0 b))
nil)
(t
;; If two entries have the same article-number
;; then sort by ascending keep_flag.
(let* ((kf-score '((special . 0)
(marked . 1)
(unread . 2)))
(a (or (cdr (assq (nth 2 a) kf-score))
3))
(b (or (cdr (assq (nth 2 b) kf-score))
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_position
(setcdr dlist (cddr dlist)))
(setq dlist (cdr dlist)))))
;; Check the order of the entry positions. They should be in
;; ascending order. If they aren't, the positions must be
;; converted to markers.
(when (catch 'sort-results
(let ((dlist dlist)
(prev-pos -1)
pos)
(while dlist
(if (setq pos (nth 3 (pop dlist)))
(if (< pos prev-pos)
(throw 'sort-results 'unsorted)
(setq prev-pos pos))))))
(gnus-message 7 "gnus-agent-expire: Unsorted overview; inserting markers to compensate.")
(mapc (lambda (entry)
(let ((pos (nth 3 entry)))
(if pos
(setf (nth 3 entry)
(set-marker (make-marker)
pos)))))
dlist))
(gnus-message 7 "gnus-agent-expire: Merging entries... Done")
(let* ((len (float (length dlist)))
(alist (list nil))
(tail-alist alist)
(position-offset 0)
)
(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 (file-attribute-size
(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 (if (markerp marker)
marker
(- marker position-offset)))
(incf nov-entries-deleted)
(let* ((from (line-beginning-position))
(to (progn (forward-line 1) (point)))
(freed (- to from)))
(incf bytes-freed freed)
(incf position-offset freed)
(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 precede 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)))
)
;; Remove markers as I intend to reuse this buffer again.
(when (and marker
(markerp 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 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)))))))