+2002-12-11 Kevin Greiner <kgreiner@xpediantsolutions.com>
+
+ * 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 <yamaoka@jpl.org>
* gnus-sum.el (gnus-tmp-downloaded): New internal variable.
(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
(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.
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.
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\e,A_\e(Bjohann <kai.grossjohann@uni-duisburg.de>
(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
(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
+ (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
(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)
?. ?_)
?. ?/))))
-\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-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))
"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
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
(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)
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*"))
+ (unwind-protect
(while (setq gnus-command-method (pop methods))
(when (file-exists-p (gnus-agent-lib-file "active"))
(with-temp-buffer
(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)
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)
(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
(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
(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."
(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))
(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
(directory-files dir nil "^[0-9]+$" t))
'>)
(progn (gnus-make-directory dir) nil)))
- (gnus-tmp-downloaded downloaded)
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))
(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)
(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
(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"))
(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
: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
(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)))
. 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)
(?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)
(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)
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)
(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)))))
(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)
((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
(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
(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."
(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
((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
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
(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
(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))
(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))
;; 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)))
(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))
(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)
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 <Christian.Limpach@nice.ch>.
(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))
(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
(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))
()))
"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)))
(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))
(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."
'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)
(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)
(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)
(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."
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.
(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.
;; 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
(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)
(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
projects / elisp / gnus.git- / commitdiff