From b3157dedb5c1ab28930b3314aa2e6ccf4395884a Mon Sep 17 00:00:00 2001 From: yamaoka Date: Wed, 11 Dec 2002 05:21:13 +0000 Subject: [PATCH] Synch with Oort Gnus. --- lisp/ChangeLog | 113 ++++++++++++- lisp/gnus-agent.el | 470 +++++++++++++++++++++++++++++++--------------------- lisp/gnus-art.el | 2 +- lisp/gnus-salt.el | 2 + lisp/gnus-sum.el | 132 ++++++++------- lisp/gnus.el | 15 ++ lisp/nntp.el | 397 ++++++++++++++++++++++++++------------------ 7 files changed, 709 insertions(+), 422 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 04ee738..d903c4a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,83 @@ +2002-12-11 Kevin Greiner + + * gnus.el (gnus-summary-high-uncached-face, + gnus-summary-normal-uncached-face, gnus-summary-low-uncached-face) + New faces. + + * gnus-agent.el (gnus-agent-downloaded-article-face): REMOVED. I + added this on 2002-11-23 but it just wasn't working out as + intended. The idea isn't entirely dead, three new faces + gnus-summary-*-uncached-face are being added to gnus.el to provide + the basis for an improved implementation. + (gnus-agent-read-servers): Undo the change made on 2002-11-23. The + proper file to open is lib/servers. + (gnus-summary-set-agent-mark): Expanded documentation. Unmarking + (i.e. removing the article from gnus-newsgroup-downloadable) will + now restore the article's default mark rather than simply setting + no mark. + (gnus-agent-get-undownloaded-list): Corrected documentation. + Added code to set new summary local variable, + gnus-newsgroup-agentized. Reworked impl so that it doesn't create + a temporary list. No longer sets gnus-newsgroup-downloadable. + (gnus-agent-summary-fetch-group): Keep gnus-newsgroup-undownloaded + up to date. Call new gnus-summary-update-download-mark to keep + summary buffer up-to-date. + (gnus-agent-fetch-selected-article): Keep + gnus-newsgroup-undownloaded up to date. + (gnus-agent-fetch-articles): Return list of articles that were + successfully fetched. + (gnus-agent-check-overview-buffer): No more thingatpt. + (gnus-agent-expire): No longer deletes NOV entries of unread + articles. + (gnus-agent-unread-articles): New function. + (gnus-agent-regenerate-group): The article number must be + terminated by a tab character. Added more messages to report + repairs. Inhibit quits while writing changes so it is now safe + have to quit regeneration. Renamed gnus-tmp-downloaded back to + downloaded to 1) resolve the unbound references and 2) avoid + confusing this list with the gnus-tmp-downloaded in gnus-sum.el + + * gnus-art.el (gnus-article-prepare): The agent + downloaded/undownloaded mark is no longer stored as the article's + mark. + + * gnus-salt.el (gnus-tree-highlight-node): Added uncached as + gnus-summary-highlight may use it. Added downloaded as + gnus-summary-highlight was using it. + + * gnus-sum.el (gnus-undownloaded-mark): Changed from ?@ to ?- as + the download mark now follows Kai's +/- convention. + (gnus-downloaded-mark): Added ?+ mark. + (gnus-summary-highlight): Added rules to select + gnus-summary-high-uncached-face, + gnus-summary-normal-uncached-face, and + gnus-summary-low-uncached-face. Removed the + gnus-agent-downloaded-article-face. + (gnus-summary-line-format-alist): Implemented the download flag + format (?O) as named in the manual. This implementation displays + either gnus-undownloaded-mark, gnus-downloaded-mark, or + gnus-no-mark. + (gnus-newsgroup-agentized): New local variable that identifies + which groups are agentized. While the agent is now on by default, + you don't have to agentize every server that you use. + (gnus-update-summary-mark-positions): Completed support for the + download type of mark. + (gnus-summary-insert-line): Added undownloaded to the parameters. + (gnus-summary-prepare-threads): Set gnus-tmp-downloaded for + reference by the gnus-summary-line-format-spec. + + * nntp.el (nntp-with-open-group): This macro handles dropped or + broken connections by opening a new connection and repeating the + failed command. + (nntp-retrieve-headers-with-xover): Some NNTP servers respond to + XOVER commands preceeding the active articles with the nov entry + of the first available article. When gnus connected to such a + server, the unexpected nov entry would result in duplicate lines + in the agent's overview file. This patch fixes the duplicate + lines problem and improves performance by skipping over all + articles IDs that preceed the first nov entry in the server's + reply. + 2002-12-11 Katsumi Yamaoka * gnus-sum.el (gnus-tmp-downloaded): New internal variable. @@ -193,7 +273,9 @@ (gnus-agent-article-alist): Format change. Add documentation. (gnus-agent-summary-mode-map): New keybinding `J s' for fetching process-marked articles. - (gnus-agent-summary-fetch-series): Command for `J s'. + (gnus-agent-summary-fetch-series): Command for `J s'. Articles + in the series are individually fetched to minimize lose of + content due to an error/quit. (gnus-agent-synchronize-flags-server, gnus-agent-add-server): Use gnus-message instead of message. (gnus-agent-read-servers): Use file lib/methods instead of @@ -201,13 +283,14 @@ (gnus-summary-set-agent-mark): Adapt to new agent-alist format. (gnus-agent-get-undownloaded-list): Remove articles that appear to come from the agent. This means that they are not downloaded. - TODO: Correct? (gnus-agent-fetch-selected-article): Don't use history. (gnus-agent-save-history, gnus-agent-enter-history) (gnus-agent-article-in-history-p, gnus-agent-history-path): Removed function; history is not used anymore. (gnus-agent-fetch-articles): Fix handling of crossposted articles. - (gnus-agent-crosspost): TODO: What happened here? + (gnus-agent-crosspost): Started rewrite then realized that a typo + in gnus-agent-fetch-articles ensures that this function is never + called. This will need to be fixed later. (gnus-agent-check-overview-buffer): Some sanity checks on the agent overview buffer. This is a safety net used during development. @@ -230,8 +313,20 @@ GROUP, FORCE. Do not restrict usage. (gnus-agent-uncached-articles): New function. (gnus-agent-retrieve-headers): Use it. - (gnus-agent-regenerate-group): Rewrite. TODO: Why? - (gnus-agent-regenerate): Ditto. TODO: Why? + (gnus-agent-regenerate-group): No longer needs to be called from + gnus-agent-regenerate. Individual groups may be regenerated. The + regeneration code now fixes duplicate, and mis-ordered, NOV entries. + The article fetch dates are validated in the article alist. The + article alist is pruned of entries that do not reference existing + NOV entries. All changes are computed then applied with + inhibit-quit bound to t. As a result, it is now safe to quit out of + regeneration. The optional clean parameter has been replaced with + an optional reread parameter. Clean is no longer necessary as + regeneration gets the appropriate setting from + gnus-agent-consider-all-articles. The new reread parameter will + result in fetched, or all, articles being marked as unread. + (gnus-agent-regenerate): Removed code to regenerate the history + file as it is no longer used. * gnus-start.el (gnus-make-ascending-articles-unread): New function, for efficient mass-marking. @@ -244,8 +339,12 @@ line. (gnus-summary-highlight-line): Use new face for downloaded articles. - (gnus-summary-insert-old-articles): TODO: What does this change - do? + (gnus-summary-insert-old-articles): Improved performance by + replacing the initial LIST of older articles with a compressed + RANGE of older articles. Some servers appear to lie about + their active range so the original list could contain millions + of article numbers. The range is not expanded into a list + until the optional ALL parameter has been applied. 2002-11-18 Kai Gro,A_(Bjohann diff --git a/lisp/gnus-agent.el b/lisp/gnus-agent.el index df00c31..c8c04a1 100644 --- a/lisp/gnus-agent.el +++ b/lisp/gnus-agent.el @@ -44,16 +44,6 @@ (autoload 'gnus-server-update-server "gnus-srvr") (autoload 'number-at-point "thingatpt")) -(defface gnus-agent-downloaded-article-face - '((((class color) - (background light)) - (:foreground "darkslategray" :bold nil)) - (((class color) (background dark)) - (:foreground "LightGray" :bold nil)) - (t (:inverse-video t :bold nil))) - "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 @@ -287,6 +277,9 @@ node `(gnus)Server 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 ;;; @@ -685,7 +678,7 @@ be a select method." (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." @@ -738,63 +731,53 @@ the actual number of articles toggled is returned." (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." @@ -835,13 +818,16 @@ Optional arg ALL, if non-nil, means to fetch all articles." (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))))) @@ -852,9 +838,10 @@ This can be added to `gnus-select-article-hook' or `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 + (when (gnus-agent-fetch-articles gnus-newsgroup-name - (list gnus-current-article))))) + (list gnus-current-article)) + (setq gnus-newsgroup-undownloaded (delq gnus-current-article gnus-newsgroup-undownloaded)))))) ;;; ;;; Internal functions @@ -922,7 +909,7 @@ This can be added to `gnus-select-article-hook' or (when (re-search-forward (concat "^" (regexp-quote group) " ") nil t) (save-excursion - (read (current-buffer)) ;; max + (read (current-buffer)) ;; max (setq oactive-min (read (current-buffer)))) ;; min (gnus-delete-line)) (insert (format "%S %d %d y\n" (intern group) @@ -945,8 +932,6 @@ This can be added to `gnus-select-article-hook' or ?. ?_) ?. ?/)))) - - (defun gnus-agent-get-function (method) (if (gnus-online method) (car method) @@ -998,12 +983,14 @@ This can be added to `gnus-select-article-hook' or (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. @@ -1053,11 +1040,13 @@ This can be added to `gnus-select-article-hook' or (write-region-as-coding-system gnus-agent-file-coding-system (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)) @@ -1093,7 +1082,7 @@ This can be added to `gnus-select-article-hook' or "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) + (let ((prev-num -1)) (save-excursion (when buffer (set-buffer buffer)) (save-excursion @@ -1103,18 +1092,28 @@ and that there are no duplicates." 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 + + (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 (progn (end-of-line) (point)))) + (debug nil "Overview buffer contains line that does not begin with a tab-delimited integer.")) ((= cur prev-num) - (gnus-message 10 "Duplicate overview line for %d" cur) + (gnus-message 1 + "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!")))) - (setq prev-num (number-at-point))))))))) - + (gnus-message 1 "Overview buffer not sorted!") + (debug nil "Overview buffer not sorted!")) + (t + (setq prev-num cur))) + (forward-line 1))))))))) (defun gnus-agent-flush-cache () (save-excursion @@ -1205,7 +1204,7 @@ and that there are no duplicates." (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 + ;; 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) @@ -1906,8 +1905,6 @@ Setting GROUP will limit expiration to that group. 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 @@ -1921,6 +1918,7 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." 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 @@ -1934,17 +1932,17 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (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-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) - changed-alist (specials (if alist (list (caar (last alist))))) - (unreads;; Articles that are excluded from the expiration process + (unreads ;; Articles that are excluded from the expiration process (cond (gnus-agent-expire-all ;; All articles are marked read by global decree nil) @@ -1953,11 +1951,12 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." nil) ((not articles) ;; Unread articles are marked protected from expiration - (ignore-errors (gnus-list-of-unread-articles expiring-group))) + ;; 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 + (marked ;; More articles that are exluded from the expiration process (cond (gnus-agent-expire-all ;; All articles are unmarked by global decree nil) @@ -1976,65 +1975,122 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (cdr (assq 'dormant (gnus-info-marks info)))))) )) - (keep (sort (nconc specials unreads marked) '<)) (nov-file (concat dir ".overview")) - (len (length alist)) (cnt 0) + (completed -1) + dlist type) - (when (file-exists-p nov-file) + + ;; 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)) - (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))) - (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)) + (let (p) + (while (< (setq p (point)) (point-max)) (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) + ;; 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... ") + (setq dlist + (let ((special 0) ; If two entries have the same article-number then sort by ascending keep_flag. + (marked 1) + (unread 2) + ;(nil 3) + ) + (sort dlist (function (lambda (a b) + (cond ((< (nth 0 a) (nth 0 b)) t) - ((= nov-art art) - (forward-line 1) + ((> (nth 0 a) (nth 0 b)) 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 + (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 @@ -2046,48 +2102,61 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (pop days)) found))) 'expired) - force))) + (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))) + ;; 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)) - (if changed-alist + (unless (equal alist gnus-agent-article-alist) + (setq gnus-agent-article-alist alist) (gnus-agent-save-alist expiring-group)) - (if (buffer-modified-p) - (progn - (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)) - ) - (if (eq articles t) + + (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")) ;;;###autoload @@ -2101,6 +2170,26 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (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." @@ -2112,22 +2201,22 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (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))))) + (gnus-agent-append-to-list tail-uncached (pop arts))) (cdr uncached)) ;; if gnus-agent-load-alist fails, no articles are cached. articles)) @@ -2170,7 +2259,7 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (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 @@ -2183,7 +2272,7 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (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 @@ -2193,10 +2282,10 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." ;; 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 @@ -2272,7 +2361,6 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (directory-files dir nil "^[0-9]+$" t)) '>) (progn (gnus-make-directory dir) nil))) - (gnus-tmp-downloaded downloaded) dl nov-arts alist header regenerated) @@ -2290,7 +2378,7 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (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)) @@ -2298,16 +2386,21 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (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) @@ -2318,7 +2411,7 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (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) @@ -2380,11 +2473,11 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." ((< (caar n) (caar o)) (setcdr n (list (car o))))))) + (let ((inhibit-quit t)) (if (setq regenerated (buffer-modified-p)) (write-region-as-coding-system gnus-agent-file-coding-system (point-min) (point-max) file nil 'silent)) - ) (setq regenerated (or regenerated (and reread gnus-agent-article-alist) @@ -2394,7 +2487,8 @@ FORCE is equivalent to setting gnus-agent-expire-days to zero(0)." (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 diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 30cb673..5d7bf46 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -3818,7 +3818,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (cons gnus-newsgroup-name article)) (set-buffer gnus-summary-buffer) (setq gnus-current-article article) - (if (eq (gnus-article-mark article) gnus-undownloaded-mark) + (if (memq article gnus-newsgroup-undownloaded) (progn (gnus-summary-set-agent-mark article) (message "Message marked for downloading")) diff --git a/lisp/gnus-salt.el b/lisp/gnus-salt.el index 44f45f1..3727a4f 100644 --- a/lisp/gnus-salt.el +++ b/lisp/gnus-salt.el @@ -670,6 +670,8 @@ Two predefined functions are available: (default gnus-summary-default-score) (default-high gnus-summary-default-high-score) (default-low gnus-summary-default-low-score) + (uncached (memq article gnus-newsgroup-undownloaded)) + (downloaded (not uncached)) (mark (or (gnus-summary-article-mark article) gnus-unread-mark))) ;; Eval the cars of the lists until we find a match. (while (and list diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 8109a83..5dc86dc 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -527,11 +527,16 @@ this variable specifies group names." :group 'gnus-summary-marks :type 'character) -(defcustom gnus-undownloaded-mark ?@ +(defcustom gnus-undownloaded-mark ?- "*Mark used for articles that weren't downloaded." :group 'gnus-summary-marks :type 'character) +(defcustom gnus-downloaded-mark ?+ + "*Mark used for articles that were downloaded." + :group 'gnus-summary-marks + :type 'character) + (defcustom gnus-downloadable-mark ?% "*Mark used for articles that are to be downloaded." :group 'gnus-summary-marks @@ -877,6 +882,12 @@ automatically when it is selected." (defcustom gnus-summary-highlight '(((eq mark gnus-canceled-mark) . gnus-summary-cancelled-face) + ((and uncached (> score default-high)) + . gnus-summary-high-uncached-face) + ((and uncached (< score default-low)) + . gnus-summary-low-uncached-face) + (uncached + . gnus-summary-normal-uncached-face) ((and (> score default-high) (or (eq mark gnus-dormant-mark) (eq mark gnus-ticked-mark))) @@ -894,25 +905,12 @@ automatically when it is selected." . gnus-summary-low-ancient-face) ((eq mark gnus-ancient-mark) . gnus-summary-normal-ancient-face) - (gnus-tmp-downloaded - . gnus-agent-downloaded-article-face) ((and (> score default-high) (eq mark gnus-unread-mark)) . gnus-summary-high-unread-face) ((and (< score default-low) (eq mark gnus-unread-mark)) . gnus-summary-low-unread-face) ((eq mark gnus-unread-mark) . gnus-summary-normal-unread-face) - ((and (> score default-high) (memq mark (list gnus-downloadable-mark - gnus-undownloaded-mark))) - . gnus-summary-high-unread-face) - ((and (< score default-low) (memq mark (list gnus-downloadable-mark - gnus-undownloaded-mark))) - . gnus-summary-low-unread-face) - ((and (memq mark (list gnus-downloadable-mark gnus-undownloaded-mark)) - (memq article gnus-newsgroup-unreads)) - . gnus-summary-normal-unread-face) - ((memq mark (list gnus-downloadable-mark gnus-undownloaded-mark)) - . gnus-summary-normal-read-face) ((> score default-high) . gnus-summary-high-read-face) ((< score default-low) @@ -1141,6 +1139,7 @@ the MIME-Version header is missed." (?c (or (mail-header-chars gnus-tmp-header) 0) ?d) (?k (gnus-summary-line-message-size gnus-tmp-header) ?s) (?L gnus-tmp-lines ?s) + (?O gnus-tmp-downloaded ?c) (?I gnus-tmp-indentation ?s) (?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s) (?R gnus-tmp-replied ?c) @@ -1205,6 +1204,8 @@ end position and text.") (defvar gnus-last-shell-command nil "Default shell command on article.") +(defvar gnus-newsgroup-agentized nil + "Locally bound in each summary buffer to indicate whether the server has been agentized.") (defvar gnus-newsgroup-begin nil) (defvar gnus-newsgroup-end nil) (defvar gnus-newsgroup-last-rmail nil) @@ -2860,7 +2861,6 @@ time; i.e., when generating the summary lines. After that, marks of articles." `(cond ((memq ,number gnus-newsgroup-unsendable) gnus-unsendable-mark) -;;;; ((memq ,number gnus-newsgroup-undownloaded) gnus-undownloaded-mark) ((memq ,number gnus-newsgroup-downloadable) gnus-downloadable-mark) ((memq ,number gnus-newsgroup-unreads) gnus-unread-mark) ((memq ,number gnus-newsgroup-marked) gnus-ticked-mark) @@ -3086,18 +3086,18 @@ buffer that was in action when the last article was fetched." (let ((gnus-replied-mark 129) (gnus-score-below-mark 130) (gnus-score-over-mark 130) - (gnus-download-mark 131) + (gnus-downloaded-mark 131) (spec gnus-summary-line-format-spec) gnus-visual pos) (save-excursion (gnus-set-work-buffer) (let ((gnus-summary-line-format-spec spec) - (gnus-newsgroup-downloadable '((0 . t)))) + (gnus-newsgroup-downloadable '(0))) (gnus-summary-insert-line (make-full-mail-header 0 "" "nobody" "05 Apr 2001 23:33:09 +0400" "" "" 0 0 "" nil) - 0 nil 128 t nil "" nil 1) + 0 nil nil 128 t nil "" nil 1) (goto-char (point-min)) (setq pos (list (cons 'unread (and (search-forward "\200" nil t) (- (point) (point-min) 1))))) @@ -3150,7 +3150,7 @@ buffer that was in action when the last article was fetched." (defun gnus-summary-insert-line (gnus-tmp-header gnus-tmp-level gnus-tmp-current - gnus-tmp-unread gnus-tmp-replied + undownloaded gnus-tmp-unread gnus-tmp-replied gnus-tmp-expirable gnus-tmp-subject-or-nil &optional gnus-tmp-dummy gnus-tmp-score gnus-tmp-process) @@ -3179,6 +3179,13 @@ buffer that was in action when the last article was fetched." ((memq gnus-tmp-number gnus-newsgroup-unseen) gnus-unseen-mark) (t gnus-no-mark))) + (gnus-tmp-downloaded + (cond (undownloaded + gnus-undownloaded-mark) + (gnus-newsgroup-agentized + gnus-downloaded-mark) + (t + gnus-no-mark))) (gnus-tmp-from (mail-header-from gnus-tmp-header)) (gnus-tmp-name (cond @@ -3989,7 +3996,9 @@ the id of the parent article (if any)." (level (gnus-summary-thread-level))) (gnus-delete-line) (gnus-summary-insert-line - header level nil (gnus-article-mark article) + header level nil + (memq article gnus-newsgroup-undownloaded) + (gnus-article-mark article) (memq article gnus-newsgroup-replied) (memq article gnus-newsgroup-expirable) ;; Only insert the Subject string when it's different @@ -4251,11 +4260,11 @@ If LINE, insert the rebuilt thread starting on line LINE." (if (not gnus-thread-sort-functions) threads (gnus-message 8 "Sorting threads...") - (prog1 - (gnus-sort-threads-1 + (let ((max-lisp-eval-depth 5000)) + (prog1 (gnus-sort-threads-1 threads (gnus-make-sort-function gnus-thread-sort-functions)) - (gnus-message 8 "Sorting threads...done")))) + (gnus-message 8 "Sorting threads...done"))))) (defun gnus-sort-articles (articles) "Sort ARTICLES." @@ -4489,7 +4498,7 @@ or a straight list of headers." (gnus-visual-p (gnus-visual-p 'summary-highlight 'highlight)) thread number subject stack state gnus-tmp-gathered beg-match new-roots gnus-tmp-new-adopts thread-end simp-subject - gnus-tmp-header gnus-tmp-unread + gnus-tmp-header gnus-tmp-unread gnus-tmp-downloaded gnus-tmp-replied gnus-tmp-subject-or-nil gnus-tmp-dummy gnus-tmp-indentation gnus-tmp-lines gnus-tmp-score gnus-tmp-score-char gnus-tmp-from gnus-tmp-name @@ -4693,6 +4702,13 @@ or a straight list of headers." ((memq number gnus-newsgroup-unseen) gnus-unseen-mark) (t gnus-no-mark)) + gnus-tmp-downloaded + (cond ((memq number gnus-newsgroup-undownloaded) + gnus-undownloaded-mark) + (gnus-newsgroup-agentized + gnus-downloaded-mark) + (t + gnus-no-mark)) gnus-tmp-from (mail-header-from gnus-tmp-header) gnus-tmp-name (cond @@ -4781,6 +4797,7 @@ or a straight list of headers." gnus-newsgroup-data) (gnus-summary-insert-line header 0 number + (memq number gnus-newsgroup-undownloaded) mark (memq number gnus-newsgroup-replied) (memq number gnus-newsgroup-expirable) (mail-header-subject header) nil @@ -5017,7 +5034,8 @@ If SELECT-ARTICLES, only select those articles from GROUP." (gnus-get-predicate display))) ;; Uses the dynamically bound `number' variable. -(defvar number) +(eval-when-compile + (defvar number)) (defun gnus-article-marked-p (type &optional article) (let ((article (or article number))) (cond @@ -5943,8 +5961,7 @@ If EXCLUDE-GROUP, do not go to this group." (progn (while arts (when (or (and undownloaded - (eq gnus-undownloaded-mark - (gnus-data-mark (car arts)))) + (memq (car arts) gnus-newsgroup-undownloaded)) (gnus-data-unread-p (car arts))) (setq result (car arts) arts nil)) @@ -6655,8 +6672,7 @@ Returns the article selected or nil if there are no unread articles." (let ((data gnus-newsgroup-data)) (while (and data (and (not (and undownloaded - (eq gnus-undownloaded-mark - (gnus-data-mark (car data))))) + (memq (car data) gnus-newsgroup-undownloaded))) (if unseen (or (not (memq (gnus-data-number (car data)) @@ -7677,7 +7693,8 @@ fetch-old-headers verbiage, and so on." ;; will really go down to a leaf article first, before slowly ;; working its way up towards the root. (when thread - (let ((children + (let* ((max-lisp-eval-depth 5000) + (children (if (cdr thread) (apply '+ (mapcar 'gnus-summary-limit-children (cdr thread))) @@ -9674,6 +9691,19 @@ If NO-EXPIRE, auto-expiry will be inhibited." (gnus-run-hooks 'gnus-summary-update-hook)) t) +(defun gnus-summary-update-download-mark (article) + "Update the secondary (read, process, cache) mark." + (gnus-summary-update-mark + (cond ((memq article gnus-newsgroup-undownloaded) + gnus-undownloaded-mark) + (gnus-newsgroup-agentized + gnus-downloaded-mark) + (t + gnus-no-mark)) + 'download) + (gnus-summary-update-line t) + t) + (defun gnus-summary-update-mark (mark type) (let ((forward (cdr (assq type gnus-summary-mark-positions))) (buffer-read-only nil)) @@ -10962,6 +10992,7 @@ If REVERSE, save parts that do not match TYPE." (defvar gnus-summary-highlight-line-cached nil) (defvar gnus-summary-highlight-line-trigger nil) + (defun gnus-summary-highlight-line-0 () (if (and (eq gnus-summary-highlight-line-trigger gnus-summary-highlight) @@ -10978,17 +11009,17 @@ If REVERSE, save parts that do not match TYPE." list (cdr list))) (gnus-byte-compile (list 'lambda nil cond)))))) +(eval-when-compile (defvar gnus-summary-highlight-line-downloaded-alist nil) -(defvar gnus-summary-highlight-line-downloaded-cached nil) + (defvar gnus-summary-highlight-line-downloaded-cached nil)) -;; New implementation by Christian Limpach . (defun gnus-summary-highlight-line () "Highlight current line according to `gnus-summary-highlight'." (let* ((list gnus-summary-highlight) (beg (gnus-point-at-bol)) - (article (gnus-summary-article-number)) - (score (or (cdr (assq (or article gnus-current-article) + (article (or (gnus-summary-article-number) gnus-current-article)) + (score (or (cdr (assq article gnus-newsgroup-scored)) gnus-summary-default-score 0)) (mark (or (gnus-summary-article-mark) gnus-unread-mark)) @@ -10996,32 +11027,9 @@ If REVERSE, save parts that do not match TYPE." (default gnus-summary-default-score) (default-high gnus-summary-default-high-score) (default-low gnus-summary-default-low-score) - (gnus-tmp-downloaded - (and - (boundp 'gnus-agent-article-alist) - gnus-agent-article-alist - (gnus-agent-group-covered-p gnus-newsgroup-name) - ;; Optimized for when gnus-summary-highlight-line is - ;; called multiple times for articles in ascending - ;; order (i.e. initial generation of summary buffer). - (progn - (unless (and - (eq gnus-summary-highlight-line-downloaded-alist - gnus-agent-article-alist) - (<= (caar gnus-summary-highlight-line-downloaded-cached) - article)) - (setq gnus-summary-highlight-line-downloaded-alist - gnus-agent-article-alist) - (setq gnus-summary-highlight-line-downloaded-cached - gnus-agent-article-alist)) - (let (n) - (while (and (< (caar gnus-summary-highlight-line-downloaded-cached) - article) - (setq n (cdr gnus-summary-highlight-line-downloaded-cached))) - (setq gnus-summary-highlight-line-downloaded-cached n))) - (and (eq (caar gnus-summary-highlight-line-downloaded-cached) - article) - (cdar gnus-summary-highlight-line-downloaded-cached)))))) + (uncached (memq article gnus-newsgroup-undownloaded)) + (downloaded (not uncached)) + ) (let ((face (funcall (gnus-summary-highlight-line-0)))) (unless (eq face (get-text-property beg 'face)) (gnus-put-text-property-excluding-characters-with-faces @@ -11535,8 +11543,8 @@ If ALL is a number, fetch this number of articles." (let ((old (sort (mapcar 'car gnus-newsgroup-data) '<)) older len) (setq older - ;; Some nntp servers lie about their active range. When this happens, the active - ;; range can be in the millions. + ;; Some nntp servers lie about their active range. When + ;; this happens, the active range can be in the millions. ;; Use a compressed range to avoid creating a huge list. (gnus-range-difference (list gnus-newsgroup-active) old)) (setq len (gnus-range-length older)) diff --git a/lisp/gnus.el b/lisp/gnus.el index e0413d4..675d388 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -666,6 +666,21 @@ be set in `.emacs' instead." ())) "Face used for normal interest ancient articles.") +(defface gnus-summary-high-uncached-face + '((((class color)) + (:bold t :background "Wheat1"))) + "Face used for high interest uncached articles.") + +(defface gnus-summary-low-uncached-face + '((((class color)) + (:italic t :background "Wheat1"))) + "Face used for low interest uncached articles.") + +(defface gnus-summary-normal-uncached-face + '((((class color)) + (:background "Wheat1"))) + "Face used for normal interest uncached articles.") + (defface gnus-summary-high-unread-face '((t (:bold t))) diff --git a/lisp/nntp.el b/lisp/nntp.el index d06c234..97f01bb 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -327,7 +327,7 @@ noticing asynchronous data.") (nntp-snarf-error-message) nil)) ((not (memq (process-status process) '(open run))) - (nnheader-report 'nntp "Server closed connection")) + (nntp-report "Server closed connection")) (t (goto-char (point-max)) (let ((limit (point-min)) @@ -552,67 +552,121 @@ noticing asynchronous data.") (t nil))) +(eval-when-compile + (defvar nntp-with-open-group-first-pass nil)) + +(defmacro nntp-with-open-group (group server &optional connectionless &rest forms) + "Protect against servers that don't like clients that keep idle connections opens. The problem +being that these servers may either close a connection or simply ignore any further requests on a +connection. Closed connections are not detected until accept-process-output has updated the +process-status. Dropped connections are not detected until the connection timeouts (which may be +several minutes) or nntp-connection-timeout has expired. When these occur nntp-with-open-group, +opens a new connection then re-issues the NNTP command whose response triggered the error." + (when (and (listp connectionless) + (not (eq connectionless nil))) + (setq forms (cons connectionless forms) + connectionless)) + `(let ((nntp-with-open-group-first-pass t) + nntp-with-open-group-internal) + (while (catch 'nntp-with-open-group-error + ;; Open the connection to the server + ;; NOTE: Existing connections are NOT tested. + (nntp-possibly-change-group ,group ,server ,connectionless) + + (let ((timer + (and nntp-connection-timeout + (nnheader-run-at-time + nntp-connection-timeout nil + '(lambda () + (let ((process (nntp-find-connection nntp-server-buffer)) + (buffer (and process (process-buffer process)))) + ; when I an able to identify the connection to the server AND I've received NO + ; reponse for nntp-connection-timeout seconds. + (when (and buffer (eq 0 (buffer-size buffer))) + ; Close the connection. Take no other action as the accept input code will + ; handle the closed connection. + (nntp-kill-buffer buffer)))))))) + (unwind-protect + (setq nntp-with-open-group-internal (progn ,@forms)) + (when timer + (nnheader-cancel-timer timer))) + nil)) + (setq nntp-with-open-group-first-pass nil)) + nntp-with-open-group-internal)) + +(defsubst nntp-report (&rest args) + "Report an error from the nntp backend. +The first string in ARGS can be a format string. +For some commands, the failed command may be retried once before actually displaying the error report." + + (if nntp-with-open-group-first-pass + (throw 'nntp-with-open-group-error t)) + + (nnheader-report 'nntp args) + ) + (deffoo nntp-retrieve-headers (articles &optional group server fetch-old) "Retrieve the headers of ARTICLES." - (nntp-possibly-change-group group server) - (save-excursion - (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) - (erase-buffer) - (if (and (not gnus-nov-is-evil) - (not nntp-nov-is-evil) - (nntp-retrieve-headers-with-xover articles fetch-old)) - ;; We successfully retrieved the headers via XOVER. - 'nov - ;; XOVER didn't work, so we do it the hard, slow and inefficient - ;; way. - (let ((number (length articles)) - (count 0) - (received 0) - (last-point (point-min)) - (buf (nntp-find-connection-buffer nntp-server-buffer)) - (nntp-inhibit-erase t) - article) - ;; Send HEAD commands. - (while (setq article (pop articles)) - (nntp-send-command - nil - "HEAD" (if (numberp article) - (int-to-string article) - ;; `articles' is either a list of article numbers - ;; or a list of article IDs. - article)) - (incf count) - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (nntp-accept-response) - (while (progn - (set-buffer buf) - (goto-char last-point) - ;; Count replies. - (while (nntp-next-result-arrived-p) - (setq last-point (point)) - (incf received)) - (< received count)) - ;; If number of headers is greater than 100, give - ;; informative messages. - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (zerop (% received 20)) - (nnheader-message 6 "NNTP: Receiving headers... %d%%" - (/ (* received 100) number))) - (nntp-accept-response)))) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (nnheader-message 6 "NNTP: Receiving headers...done")) - - ;; Now all of replies are received. Fold continuation lines. - (nnheader-fold-continuation-lines) - ;; Remove all "\r"'s. - (nnheader-strip-cr) - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) - 'headers)))) + (nntp-with-open-group + group server + (save-excursion + (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) + (erase-buffer) + (if (and (not gnus-nov-is-evil) + (not nntp-nov-is-evil) + (nntp-retrieve-headers-with-xover articles fetch-old)) + ;; We successfully retrieved the headers via XOVER. + 'nov + ;; XOVER didn't work, so we do it the hard, slow and inefficient + ;; way. + (let ((number (length articles)) + (count 0) + (received 0) + (last-point (point-min)) + (buf (nntp-find-connection-buffer nntp-server-buffer)) + (nntp-inhibit-erase t) + article) + ;; Send HEAD commands. + (while (setq article (pop articles)) + (nntp-send-command + nil + "HEAD" (if (numberp article) + (int-to-string article) + ;; `articles' is either a list of article numbers + ;; or a list of article IDs. + article)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (progn + (set-buffer buf) + (goto-char last-point) + ;; Count replies. + (while (nntp-next-result-arrived-p) + (setq last-point (point)) + (incf received)) + (< received count)) + ;; If number of headers is greater than 100, give + ;; informative messages. + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% received 20)) + (nnheader-message 6 "NNTP: Receiving headers... %d%%" + (/ (* received 100) number))) + (nntp-accept-response)))) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (nnheader-message 6 "NNTP: Receiving headers...done")) + + ;; Now all of replies are received. Fold continuation lines. + (nnheader-fold-continuation-lines) + ;; Remove all "\r"'s. + (nnheader-strip-cr) + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + 'headers))))) (deffoo nntp-retrieve-groups (groups &optional server) "Retrieve group info on GROUPS." @@ -703,72 +757,73 @@ noticing asynchronous data.") 'active)))))) (deffoo nntp-retrieve-articles (articles &optional group server) - (nntp-possibly-change-group group server) - (save-excursion - (let ((number (length articles)) - (count 0) - (received 0) - (last-point (point-min)) - (buf (nntp-find-connection-buffer nntp-server-buffer)) - (nntp-inhibit-erase t) - (map (apply 'vector articles)) - (point 1) - article) - (set-buffer buf) - (erase-buffer) - ;; Send ARTICLE command. - (while (setq article (pop articles)) - (nntp-send-command - nil - "ARTICLE" (if (numberp article) - (int-to-string article) - ;; `articles' is either a list of article numbers - ;; or a list of article IDs. - article)) - (incf count) - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (nntp-accept-response) - (while (progn - (set-buffer buf) - (goto-char last-point) - ;; Count replies. - (while (nntp-next-result-arrived-p) - (aset map received (cons (aref map received) (point))) - (setq last-point (point)) - (incf received)) - (< received count)) - ;; If number of headers is greater than 100, give - ;; informative messages. - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (zerop (% received 20)) - (nnheader-message 6 "NNTP: Receiving articles... %d%%" - (/ (* received 100) number))) - (nntp-accept-response)))) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (nnheader-message 6 "NNTP: Receiving articles...done")) - - ;; Now we have all the responses. We go through the results, - ;; wash it and copy it over to the server buffer. - (set-buffer nntp-server-buffer) - (erase-buffer) - (setq last-point (point-min)) - (mapcar - (lambda (entry) - (narrow-to-region - (setq point (goto-char (point-max))) - (progn - (insert-buffer-substring buf last-point (cdr entry)) - (point-max))) - (setq last-point (cdr entry)) - (nntp-decode-text) - (widen) - (cons (car entry) point)) - map)))) + (nntp-with-open-group + group server + (save-excursion + (let ((number (length articles)) + (count 0) + (received 0) + (last-point (point-min)) + (buf (nntp-find-connection-buffer nntp-server-buffer)) + (nntp-inhibit-erase t) + (map (apply 'vector articles)) + (point 1) + article) + (set-buffer buf) + (erase-buffer) + ;; Send ARTICLE command. + (while (setq article (pop articles)) + (nntp-send-command + nil + "ARTICLE" (if (numberp article) + (int-to-string article) + ;; `articles' is either a list of article numbers + ;; or a list of article IDs. + article)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null articles) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (progn + (set-buffer buf) + (goto-char last-point) + ;; Count replies. + (while (nntp-next-result-arrived-p) + (aset map received (cons (aref map received) (point))) + (setq last-point (point)) + (incf received)) + (< received count)) + ;; If number of headers is greater than 100, give + ;; informative messages. + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% received 20)) + (nnheader-message 6 "NNTP: Receiving articles... %d%%" + (/ (* received 100) number))) + (nntp-accept-response)))) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (nnheader-message 6 "NNTP: Receiving articles...done")) + + ;; Now we have all the responses. We go through the results, + ;; wash it and copy it over to the server buffer. + (set-buffer nntp-server-buffer) + (erase-buffer) + (setq last-point (point-min)) + (mapcar + (lambda (entry) + (narrow-to-region + (setq point (goto-char (point-max))) + (progn + (insert-buffer-substring buf last-point (cdr entry)) + (point-max))) + (setq last-point (cdr entry)) + (nntp-decode-text) + (widen) + (cons (car entry) point)) + map))))) (defun nntp-try-list-active (group) (nntp-list-active-group group) @@ -792,17 +847,18 @@ noticing asynchronous data.") (nntp-send-command "^\\.*\r?\n" "LISTGROUP" group)) (deffoo nntp-request-article (article &optional group server buffer command) - (nntp-possibly-change-group group server) - (when (nntp-send-command-and-decode - "\r?\n\\.\r?\n" "ARTICLE" - (if (numberp article) (int-to-string article) article)) - (if (and buffer - (not (equal buffer nntp-server-buffer))) - (save-excursion - (set-buffer nntp-server-buffer) - (copy-to-buffer buffer (point-min) (point-max)) - (nntp-find-group-and-number group)) - (nntp-find-group-and-number group)))) + (nntp-with-open-group + group server + (when (nntp-send-command-and-decode + "\r?\n\\.\r?\n" "ARTICLE" + (if (numberp article) (int-to-string article) article)) + (if (and buffer + (not (equal buffer nntp-server-buffer))) + (save-excursion + (set-buffer nntp-server-buffer) + (copy-to-buffer buffer (point-min) (point-max)) + (nntp-find-group-and-number group)) + (nntp-find-group-and-number group))))) (deffoo nntp-request-head (article &optional group server) (nntp-possibly-change-group group server) @@ -820,10 +876,11 @@ noticing asynchronous data.") (if (numberp article) (int-to-string article) article))) (deffoo nntp-request-group (group &optional server dont-check) - (nntp-possibly-change-group nil server) - (when (nntp-send-command "^[245].*\n" "GROUP" group) - (let ((entry (nntp-find-connection-entry nntp-server-buffer))) - (setcar (cddr entry) group)))) + (nntp-with-open-group + nil server + (when (nntp-send-command "^[245].*\n" "GROUP" group) + (let ((entry (nntp-find-connection-entry nntp-server-buffer))) + (setcar (cddr entry) group))))) (deffoo nntp-close-group (group &optional server) t) @@ -1244,7 +1301,12 @@ password contained in '~/.nntp-authinfo'." (unless (< len 10) (setq nntp-have-messaged t) (nnheader-message 7 "nntp read: %dk" len))) - (accept-process-output process (or timeout 1)))) + (accept-process-output process (or timeout 1)) + ;; accept-process-output may update status of process to indicate that the server has closed the + ;; connection. This MUST be handled here as the buffer restored by the save-excursion may be the + ;; process's former output buffer (i.e. now killed) + (or (memq (process-status process) '(open run)) + (nntp-report "Server closed connection")))) (defun nntp-accept-response () "Wait for output from the process that outputs to BUFFER." @@ -1355,7 +1417,8 @@ password contained in '~/.nntp-authinfo'." in-process-buffer-p (buf nntp-server-buffer) (process-buffer (nntp-find-connection-buffer nntp-server-buffer)) - first) + first + last) ;; We have to check `nntp-server-xover'. If it gets set to nil, ;; that means that the server does not understand XOVER, but we ;; won't know that until we try. @@ -1368,8 +1431,8 @@ password contained in '~/.nntp-authinfo'." (setq articles (cdr articles))) (setq in-process-buffer-p (stringp nntp-server-xover)) - (nntp-send-xover-command first (car articles)) - (setq articles (cdr articles)) + (nntp-send-xover-command first (setq last (car articles))) + (setq articles (cdr articles)) (when (and nntp-server-xover in-process-buffer-p) ;; Don't count tried request. @@ -1378,7 +1441,7 @@ password contained in '~/.nntp-authinfo'." ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) + (= 1 (% count nntp-maximum-request))) (nntp-accept-response) ;; On some Emacs versions the preceding function has a @@ -1392,27 +1455,33 @@ password contained in '~/.nntp-authinfo'." (while (re-search-forward "^[0-9][0-9][0-9] .*\n" nil t) (incf received)) (setq last-point (point)) - (< received count)) + (or (< received count) ;; I haven't started reading the final response + (progn + (goto-char (point-max)) + (forward-line -1) + (not (looking-at "^\\.\r?\n"))) ;; I haven't read the end of the final response + )) (nntp-accept-response) - (set-buffer process-buffer)) - (set-buffer buf)))) + (set-buffer process-buffer)))) + + ;; Some nntp servers seem to have an extension to the XOVER extension. On these + ;; servers, requesting an article range preceeding the active range does not return an + ;; error as specified in the RFC. What we instead get is the NOV entry for the first + ;; available article. Obviously, a client can use that entry to avoid making unnecessary + ;; requests. The only problem is for a client that assumes that the response will always be + ;; within the requested ranage. For such a client, we can get N copies of the same entry + ;; (one for each XOVER command sent to the server). + + (when (<= count 1) + (goto-char (point-min)) + (when (re-search-forward "^[0-9][0-9][0-9] .*\n\\([0-9]+\\)" nil t) + (let ((low-limit (string-to-int (buffer-substring (match-beginning 1) (match-end 1))))) + (while (and articles (<= (car articles) low-limit)) + (setq articles (cdr articles)))))) + (set-buffer buf)) (when nntp-server-xover (when in-process-buffer-p - (set-buffer process-buffer) - ;; Wait for the reply from the final command. - (goto-char (point-max)) - (while (not (re-search-backward "^[0-9][0-9][0-9] " nil t)) - (nntp-accept-response) - (set-buffer process-buffer) - (goto-char (point-max))) - (when (looking-at "^[23]") - (while (progn - (goto-char (point-max)) - (forward-line -1) - (not (looking-at "^\\.\r?\n"))) - (nntp-accept-response) - (set-buffer process-buffer))) (set-buffer buf) (goto-char (point-max)) (insert-buffer-substring process-buffer) @@ -1465,7 +1534,7 @@ password contained in '~/.nntp-authinfo'." (set-buffer nntp-server-buffer) (erase-buffer) (setq nntp-server-xover nil))) - nntp-server-xover)))) + nntp-server-xover)))) (defun nntp-find-group-and-number (&optional group) (save-excursion -- 1.7.10.4