(eval-and-compile
(autoload 'gnus-server-update-server "gnus-srvr"))
-(defface gnus-agent-downloaded-article-face
- '((((class color) (background light)) (:foreground "Orange" :bold t))
- (((class color) (background dark)) (:foreground "Yellow" :bold t))
- (t (:inverse-video t :bold t)))
- "Face used for displaying downloaded articles"
- :group 'gnus-agent)
-
(defcustom gnus-agent-directory (nnheader-concat gnus-directory "agent/")
"Where the Gnus agent will store its files."
:group 'gnus-agent
:type 'boolean
:group 'gnus-agent)
+(defcustom gnus-agent-max-fetch-size 10000000 ;; 10 Mb
+ "gnus-agent-fetch-session is required to split its article fetches into chunks smaller than this limit."
+ :group 'gnus-agent
+ :type 'integer)
+
;;; Internal variables
(defvar gnus-agent-history-buffers nil)
(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))
(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))))
+
;;;
;;; Mode infestation
;;;
(gnus-message 1 "Ignoring disappeared server `%s'" m)
(sit-for 1))))
(gnus-agent-read-file
- (nnheader-concat gnus-agent-directory "lib/methods"))))
+ (nnheader-concat gnus-agent-directory "lib/servers"))))
(defun gnus-agent-write-servers ()
"Write the alist of covered servers."
(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))
- (new-mark gnus-downloadable-mark))
+ "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)))))
+ (gnus-summary-update-mark
(if unmark
- (let ((agent-articles gnus-agent-article-alist))
+ (progn
(setq gnus-newsgroup-downloadable
(delq article gnus-newsgroup-downloadable))
- (while (and agent-articles (< (caar agent-articles) article))
- (setq agent-articles (cdr agent-articles)))
- (if (and (eq (caar agent-articles) article)
- (cdar agent-articles))
- (setq new-mark 32)
- (progn (setq new-mark gnus-undownloaded-mark)
- (push article gnus-newsgroup-undownloaded))))
- (setq gnus-newsgroup-undownloaded
- (delq article gnus-newsgroup-undownloaded))
+ (gnus-article-mark article))
+ (progn
(setq gnus-newsgroup-downloadable
- (gnus-add-to-sorted-list gnus-newsgroup-downloadable article)))
- (gnus-summary-update-mark
- new-mark
+ (gnus-add-to-sorted-list gnus-newsgroup-downloadable article))
+ gnus-downloadable-mark)
+ )
'unread)))
-;; Check history - this may make sense if the agent is configured to pre-fetch every article.
(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 (delq nil (mapcar (lambda (header) (if (equal (mail-header-from header) "Gnus Agent")
- nil
- (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 gnus-newsgroup-headers)
+ (undownloaded (list nil))
+ (tail undownloaded))
+ (while (and alist headers)
+ (let ((a (caar alist))
+ (h (mail-header-number (car headers))))
+ (cond ((< a h)
+ (pop alist)) ; ignore IDs in the alist that are not being displayed in the summary
+ ((> a h)
+ (pop headers)) ; ignore headers that are not in the alist as these should be fictious (see nnagent-retrieve-headers).
+ ((cdar alist)
+ (pop alist)
+ (pop headers)
+ nil; ignore already downloaded
+ )
+ (t
+ (pop alist)
+ (pop headers)
+ (gnus-agent-append-to-list tail a)))))
+ (setq gnus-newsgroup-undownloaded (cdr undownloaded))))))
(defun gnus-agent-catchup ()
"Mark all undownloaded articles as read."
(unless articles
(error "No articles to download"))
(gnus-agent-with-fetch
- (gnus-agent-fetch-articles gnus-newsgroup-name articles))
+ (setq gnus-newsgroup-undownloaded
+ (gnus-sorted-ndifference gnus-newsgroup-undownloaded
+ (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)))))
+ (gnus-summary-mark-article article gnus-unread-mark))
+ (gnus-summary-update-download-mark article))))
(when (and (not state)
gnus-plugged)
(gnus-agent-toggle-plugged nil)))))
`gnus-mark-article-hook'."
(let ((gnus-command-method gnus-current-select-method))
(when (and gnus-plugged (gnus-agent-method-p gnus-command-method))
- (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-article gnus-current-article)))))
;;;
;;; Internal functions
?. ?_)
?. ?/))))
-\f
-
(defun gnus-agent-get-function (method)
(if (gnus-online method)
(car method)
(setcdr arts (cddr arts))
(setq arts (cdr arts)))))
(when articles
- (let ((dir (concat
+ (let* ((fetched-articles (list nil))
+ (tail-fetched-articles fetched-articles)
+ (dir (concat
(gnus-agent-directory)
(gnus-agent-group-path group) "/"))
(date (time-to-days (current-time)))
(case-fold-search t)
- pos crosses id elem)
+ pos crosses id)
(gnus-make-directory dir)
(gnus-message 7 "Fetching articles for %s..." group)
;; Fetch the articles from the backend.
(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 date)))
+
+ (gnus-agent-append-to-list tail-fetched-articles (caar pos)))
(widen)
(pop pos)))
- (gnus-agent-save-alist group)))))
+
+ (gnus-agent-save-alist group (cdr fetched-articles) date)
+ (cdr fetched-articles)))))
(defun gnus-agent-crosspost (crosses article &optional date)
(setq date (or date t))
"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)
- (require 'thingatpt)
+ (let ((prev-num -1))
(save-excursion
- (when buffer (set-buffer buffer))
- (save-excursion
- (save-restriction
- (let ((deactivate-mark (if (boundp 'deactivate-mark)
- deactivate-mark
- nil)))
- (widen)
- (goto-char (point-min))
- (setq prev-num (number-at-point))
- (while (and (zerop (forward-line 1))
- (not (eobp)))
- (let ((cur (number-at-point)))
- (cond ((= cur prev-num)
- (gnus-message 10
- "Duplicate overview line for %d" cur)
- (debug nil (format "Duplicate overview line for %d" cur))
- (delete-region (point) (progn (forward-line 1) (point))))
- ((< cur prev-num)
- (gnus-message 10 "Overview buffer not sorted!")
- (debug nil "Overview buffer not sorted!"))))
- (setq prev-num (number-at-point)))))))))
+ (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)))
+ (gnus-message 1
+ "Overview buffer contains garbage '%s'."
+ (buffer-substring
+ p (gnus-point-at-eol))))
+ ((= cur prev-num)
+ (gnus-message 1
+ "Duplicate overview line for %d" cur)
+ (delete-region (point) (progn (forward-line 1) (point))))
+ ((< cur 0)
+ (gnus-message 1 "Junk article number %d" cur)
+ (delete-region (point) (progn (forward-line 1) (point))))
+ ((< cur prev-num)
+ (sort-numeric-fields 1 (point-min) (point-max))
+ (goto-char (point-min))
+ (setq prev-num -1)
+ (gnus-message 1 "Overview buffer not sorted!"))
+ (t
+ (setq prev-num cur)))
+ (forward-line 1)))))))
(defun gnus-agent-flush-cache ()
(save-excursion
(pop gnus-agent-group-alist))))
(defun gnus-agent-fetch-headers (group &optional force)
+ "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.
;; that no headers need to be fetched. -- Kevin
(setq articles (gnus-list-range-intersection
articles (list (cons low high)))))))
- (when articles
- (gnus-message 7 "Fetching headers for %s..." group)
-
- ;; Fetch them.
- (gnus-make-directory (nnheader-translate-file-chars
- (file-name-directory file) t))
+ (save-excursion
+ (set-buffer nntp-server-buffer)
- (save-excursion
- (set-buffer nntp-server-buffer)
- (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-brand-nov can merge them
- ;; with the contents of FILE.
- (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))
- (gnus-agent-check-overview-buffer)
- (write-region (point-min) (point-max) file nil 'silent))
- (gnus-agent-save-alist group articles nil)
- articles)))
+ (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))
+ (when (file-exists-p file)
+ (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-save-alist group articles nil)
+ articles)
+ (ignore-errors
+ (erase-buffer)
+ (nnheader-insert-file-contents file))))
+ )
articles))
(defsubst gnus-agent-copy-nov-line (article)
(erase-buffer)
(nnheader-insert-file-contents file)
(goto-char (point-max))
+ (forward-line -1)
+ (unless (looking-at "[0-9]+\t")
+ ;; Remove corrupted lines
+ (gnus-message 1 "Overview %s is corrupted. Removing corrupted lines..." file)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (looking-at "[0-9]+\t")
+ (forward-line 1)
+ (delete-region (point) (progn (forward-line 1) (point)))))
+ (forward-line -1))
(unless (or (= (point-min) (point-max))
- (progn
- (forward-line -1)
- (< (setq last (read (current-buffer))) (car articles))))
+ (< (setq last (read (current-buffer))) (car articles)))
;; We do it the hard way.
(when (nnheader-find-nov-line (car articles))
;; Replacing existing NOV entry
(setcdr (cadr prev) state)))
(setq prev (cdr prev)))
(setq gnus-agent-article-alist (cdr all))
+ (if dir
+ (gnus-make-directory dir)
+ (gnus-make-directory (gnus-agent-article-name "" group)))
(with-temp-file (if dir
(expand-file-name ".agentview" dir)
(gnus-agent-article-name ".agentview" group))
)
(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))
-
- ;; Construct arts list with same order as gnus-newsgroup-headers
- (let* ((a (list nil))
- (b a))
- (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)
- (setq a (setcdr a (list (mail-header-number gnus-headers))))))
- (setq arts (cdr b))))
-
- ;; 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-active group)
+ (gnus-activate-group group))
+ (let ((marked-articles nil))
+ ;; Identify the articles marked for download
+ (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
+ (make-vector (length articles) 0))
+
+ (setq 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
+ (or (gnus-group-find-parameter group 'agent-predicate t)
+ (cadr category))))
+
+ ;; If the selection predicate requires scoring, score each header
+ (unless (memq predicate '(gnus-agent-true gnus-agent-false))
+ (let ((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))))
+
+ (unless (and (eq predicate 'gnus-agent-false)
+ (not marked-articles))
+ (let* ((arts (list nil))
+ (arts-tail arts)
+ (chunk-size 0)
+ (marked-articles marked-articles)
+ is-marked)
+ (while (setq gnus-headers (pop gnus-newsgroup-headers))
+ (let ((num (mail-header-number gnus-headers)))
+ ;; Determine if this article was marked for download.
+ (while (and marked-articles
+ (cond ((< num (car marked-articles))
+ nil)
+ ((= num (car marked-articles))
+ (setq is-marked t)
+ nil)
+ (t
+ (setq marked-articles
+ (cdr marked-articles))))))
+
+ ;; When this article is marked, or selected by the
+ ;; predicate, add it to the download list
+ (when (or is-marked
+ (let ((gnus-score
+ (or (cdr (assq num gnus-newsgroup-scored))
+ gnus-summary-default-score)))
+ (funcall predicate)))
+ (gnus-agent-append-to-list arts-tail num)
+
+ ;; When the expected size of the fetched articles
+ ;; exceeds gnus-agent-max-fetch-size, perform the
+ ;; fetch.
+ (when (< gnus-agent-max-fetch-size
+ (setq chunk-size
+ (+ chunk-size
+ (mail-header-chars gnus-headers))))
+ (gnus-agent-fetch-articles group (cdr arts))
+ (setcdr arts nil)
+ (setq arts-tail arts)
+ (setq chunk-size 0)))))
+
+ ;; Fetch all remaining articles
+ (when (cdr arts)
+ (gnus-agent-fetch-articles group (cdr arts)))))
+
+ ;; 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.
+
+ (when marked-articles
+ (dolist (mark gnus-agent-download-marks)
+ (when (eq mark 'download)
+ (setq arts (assq mark (gnus-info-marks
+ (setq info (gnus-get-info group)))))
+ (when (cdr arts)
+ (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)
+ ")")))))))))))
;;;
;;; Agent Category Mode
FORCE is equivalent to setting gnus-agent-expire-days to zero(0)."
(interactive)
- (if force (setq force 'forced))
-
(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
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))))))
- (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) "/")))
- (cond ((gnus-gethash-safe expiring-group; KJG (gnus-group-real-name expiring-group)
- orig)
- (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)
- changed-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
- (ignore-errors (gnus-list-of-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))))))
- ))
- (keep (sort (nconc specials unreads marked) '<))
- (nov-file (concat dir ".overview"))
- (len (length alist))
- (cnt 0)
- type)
- (when (file-exists-p nov-file)
- (set-buffer overview)
- (erase-buffer)
- (nnheader-insert-file-contents nov-file)
- (goto-char (point-min))
- (set-buffer-modified-p nil))
- (while alist
- (let ((art (caar alist)))
- (gnus-message 9 "Processing %d of %d" (setq cnt (1+ cnt)) len)
- (while (< (or (car keep) (1+ art)) art)
- (ignore-errors
- (while (let ((nov-art (read (current-buffer))))
- (cond ((< nov-art (car keep))
- (gnus-delete-line)
- t)
- ((= nov-art (car keep))
- (forward-line 1)
- nil)
- (t
- (beginning-of-line)
- nil)))))
- (setq keep (cdr keep)))
+ (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)))
+ (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))
- (cond ((eq art (car keep))
- (if (and (cdar alist)
- (not (file-exists-p (concat dir (number-to-string art)))))
- (progn (setcdr (car alist) nil)
- (gnus-message 7 "Article %d: cleared download flag as local file missing" (caar alist))
- (setq changed-alist t)))
- (setq alist (cdr alist)
- keep (cdr keep))
- (condition-case nil
- (while (let ((nov-art (read (current-buffer))))
- (cond ((< nov-art art)
- (gnus-message 7 "Article %d: NOV line removed" nov-art)
- (gnus-delete-line)
- t)
- ((= nov-art art)
- (forward-line 1)
- nil)
- (t
- (beginning-of-line)
- nil))))
- (error (forward-line 1))))
- ((setq type (let ((fetch-date (cdar alist)))
- (or
- ;; if read but not downloaded
- (if (and (numberp fetch-date)
- (file-exists-p (concat dir (number-to-string art))))
- nil
- 'read)
- ;; We now have the arrival day, so we see
- ;; whether it's old enough to be expired.
- (if (< fetch-date
- (if (numberp day)
- day
- (let (found
- (days gnus-agent-expire-days))
- (while (and (not found)
- days)
- (when (eq 0 (string-match (caar days) expiring-group))
- (setq found (cadar days)))
- (pop days))
- found)))
- 'expired)
- force)))
+ (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... ")
+ (let ((special 0) ; If two entries have the same article-number then sort by ascending keep_flag.
+ (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 (* 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
+ (if (numberp day)
+ day
+ (let (found
+ (days gnus-agent-expire-days))
+ (while (and (not found)
+ days)
+ (when (eq 0 (string-match (caar days) expiring-group))
+ (setq found (cadar days)))
+ (pop days))
+ found)))
+ 'expired)
+ (force
+ 'forced)))
- (if gnus-agent-consider-all-articles
- (setq alist (cdr alist)) ;; Iterate forward
- (gnus-message 7 "Article %d: Removed %s article from alist" art type)
- (setcar alist (cadr alist))
- (setcdr alist (cddr alist))
- (setq changed-alist t))
-
- (if (memq type '(forced expired))
- (ignore-errors
- (delete-file (concat dir (number-to-string art)))
- (gnus-message 7 "Article %d: Expired local copy" art)))
- (ignore-errors
- (let (nov-art)
- (while (<= (setq nov-art (read (current-buffer))) art)
- (gnus-message 7 "Article %d: NOV line removed" nov-art)
- (gnus-delete-line)))
- (beginning-of-line))
- )
- (t
- (setq alist (cdr alist)))
- )
- )
- )
-
- (let ((inhibit-quit t))
- (if changed-alist
- (gnus-agent-save-alist expiring-group))
- (if (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))
- )
- (if (eq articles t)
- (gnus-summary-update-info))
- ))))))))))))
+ ;; 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" article)
+ (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 ", "))))
+ )
+
+ ;; 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)
+ (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)))
+
+ (when (eq articles t)
+ (gnus-summary-update-info)))))))))))
+ (kill-buffer overview)))))
(gnus-message 4 "Expiry...done"))
;;;###autoload
(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)
+ (pop read)))))))
+ (while known
+ (gnus-agent-append-to-list tail-unread (car (pop known))))
+ (cdr unread)))
+
(defun gnus-agent-uncached-articles (articles group &optional cached-header)
"Constructs sublist of ARTICLES that excludes those articles 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.
- (when (gnus-agent-load-alist group)
+ (if (gnus-agent-load-alist group)
(let* ((ref gnus-agent-article-alist)
(arts articles)
(uncached (list nil))
- (tail uncached))
+ (tail-uncached uncached))
(while (and ref arts)
(let ((v1 (car arts))
(v2 (caar ref)))
(cond ((< v1 v2) ; the article (v1) does not appear in the reference list
- (setq tail (setcdr tail (list v1)))
+ (gnus-agent-append-to-list tail-uncached v1)
(pop arts))
((= v1 v2)
(unless (or cached-header (cdar ref)) ; the article (v1) is already cached
- (setq tail (setcdr tail (list v1))))
+ (gnus-agent-append-to-list tail-uncached v1))
(pop arts)
(pop ref))
(t ; the reference article (v2) preceeds the list being filtered
(pop ref)))))
(while arts
- (setq tail (setcdr tail (list (pop arts)))))
- (cdr uncached))))
+ (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
(set-buffer nntp-server-buffer)
(let* ((fetched-articles (list nil))
- (tail fetched-articles)
+ (tail-fetched-articles fetched-articles)
(min (cond ((numberp fetch-old)
(max 1 (- (car articles) fetch-old)))
(fetch-old
(goto-char (point-min))
(ignore-errors
(while t
- (setq tail (setcdr tail (cons (read (current-buffer)) nil)))
+ (gnus-agent-append-to-list tail-fetched-articles (read (current-buffer)))
(forward-line 1)))
;; Clip this list to the headers that will actually be returned
;; Clip the uncached articles list to exclude IDs after the last FETCHED header.
;; The excluded IDs may be fetchable using HEAD.
- (if (car tail)
+ (if (car tail-fetched-articles)
(setq uncached-articles (gnus-list-range-intersection
uncached-articles
- (cons (car uncached-articles) (car tail)))))
+ (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
(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)))
+ 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)
(setq load nil)
(goto-char (point-min))
(while (< (point) (point-max))
- (cond ((looking-at "[0-9]+\\b")
+ (cond ((looking-at "[0-9]+\t")
(push (read (current-buffer)) nov-arts)
(forward-line 1)
(let ((l1 (car nov-arts))
(cond ((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)
(pop 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))))
(if load
- (progn (sort-numeric-fields 1 (point-min) (point-max))
+ (progn
+ (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)
(or (not nov-arts)
(> (car downloaded) (car nov-arts))))
;; This entry is missing from the overview file
- (gnus-message 6 "Regenerating NOV %s %d..." group (car downloaded))
+ (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)
((< (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)
(setq gnus-agent-article-alist alist)
(when regenerated
- (gnus-agent-save-alist group))
+ (gnus-agent-save-alist group)))
+ )
(when (and reread gnus-agent-article-alist)
(gnus-make-ascending-articles-unread
(if (eq status 'offline) 'offline 'online)
(if (eq status 'offline) 'online 'offline))))
+(defun gnus-agent-group-covered-p (group)
+ (member (gnus-group-method group)
+ gnus-agent-covered-methods))
+
(provide 'gnus-agent)
;;; gnus-agent.el ends here
projects / gnus / blobdiff