>From d770ff468bb6b4a12a4219d8456b8a35ebb5ab44 Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Tue, 17 Mar 2020 20:53:05 -0700 Subject: [PATCH] Allow gnus-retrieve-headers to return headers directly --- lisp/gnus/gnus-agent.el | 462 ++++++++++++++++------------------------ lisp/gnus/gnus-async.el | 9 +- lisp/gnus/gnus-cache.el | 127 +++-------- lisp/gnus/gnus-cloud.el | 14 +- lisp/gnus/gnus-sum.el | 65 ++++-- lisp/gnus/gnus.el | 9 +- lisp/gnus/nnir.el | 1 - lisp/gnus/nnvirtual.el | 176 +++++---------- 8 files changed, 329 insertions(+), 534 deletions(-) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index f748996acc..4f8caf9278 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -1789,6 +1789,7 @@ gnus-agent-find-parameter . gnus-agent-enable-expiration) (agent-predicate . gnus-agent-predicate))))))) +;; FIXME: This looks an awful lot like `gnus-agent-retrieve-headers'. (defun gnus-agent-fetch-headers (group) "Fetch interesting headers into the agent. The group's overview file will be updated to include the headers while a list of available @@ -1810,10 +1811,11 @@ gnus-agent-fetch-headers (cdr active)))) (gnus-uncompress-range (gnus-active group))) (gnus-list-of-unread-articles group))) - (gnus-decode-encoded-word-function 'identity) - (gnus-decode-encoded-address-function 'identity) + (gnus-decode-encoded-word-function #'identity) + (gnus-decode-encoded-address-function #'identity) (file (gnus-agent-article-name ".overview" group)) - (file-name-coding-system nnmail-pathname-coding-system)) + (file-name-coding-system nnmail-pathname-coding-system) + headers fetched-headers) (unless fetch-all ;; Add articles with marks to the list of article headers we want to @@ -1824,7 +1826,7 @@ gnus-agent-fetch-headers (dolist (arts (gnus-info-marks (gnus-get-info group))) (unless (memq (car arts) '(seen recent killed cache)) (setq articles (gnus-range-add articles (cdr arts))))) - (setq articles (sort (gnus-uncompress-sequence articles) '<))) + (setq articles (sort (gnus-uncompress-range articles) '<))) ;; At this point, I have the list of articles to consider for ;; fetching. This is the list that I'll return to my caller. Some @@ -1867,38 +1869,46 @@ gnus-agent-fetch-headers 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'" (gnus-compress-sequence articles t))) - (with-current-buffer nntp-server-buffer - (if articles - (progn - (gnus-message 8 "Fetching headers for %s..." group) - - ;; Fetch them. - (gnus-make-directory (nnheader-translate-file-chars - (file-name-directory file) t)) - - (unless (eq 'nov (gnus-retrieve-headers articles group)) - (nnvirtual-convert-headers)) - (gnus-agent-check-overview-buffer) - ;; Move these headers to the overview buffer so that - ;; gnus-agent-braid-nov can merge them with the contents - ;; of FILE. - (copy-to-buffer - gnus-agent-overview-buffer (point-min) (point-max)) - ;; NOTE: Call g-a-brand-nov even when the file does not - ;; exist. As a minimum, it will validate the article - ;; numbers already in the buffer. - (gnus-agent-braid-nov articles file) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (gnus-agent-check-overview-buffer) - (write-region (point-min) (point-max) file nil 'silent)) - (gnus-agent-update-view-total-fetched-for group t) - (gnus-agent-save-alist group articles nil) - articles) - (ignore-errors - (erase-buffer) - (nnheader-insert-file-contents file))))) - articles)) + ;; Parse known headers from FILE. + (if (file-exists-p file) + (with-current-buffer gnus-agent-overview-buffer + (erase-buffer) + (let ((nnheader-file-coding-system + gnus-agent-file-coding-system)) + (nnheader-insert-nov-file file (car articles)) + (while (not (eobp)) + (push (nnheader-parse-nov) headers) + (forward-line 1)) + (setq headers (nreverse headers)))) + (gnus-make-directory (nnheader-translate-file-chars + (file-name-directory file) t))) + + ;; Fetch our new headers. + (gnus-message 8 "Fetching headers for %s..." group) + (if articles + (setq fetched-headers (gnus-fetch-headers articles))) + + ;; Merge two sets of headers. + (setq headers + (if (and headers fetched-headers) + (delete-dups + (sort (append headers fetched-headers) + (lambda (l r) + (< (mail-header-number l) + (mail-header-number r))))) + (or headers fetched-headers))) + + ;; Save the new set of headers to FILE. + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (with-current-buffer gnus-agent-overview-buffer + (erase-buffer) + (mapc #'nnheader-insert-nov headers) + (gnus-agent-check-overview-buffer) + (write-region (point-min) (point-max) file nil 'silent))) + (gnus-agent-update-view-total-fetched-for group t) + (gnus-agent-save-alist group articles nil)) + headers)) (defsubst gnus-agent-read-article-number () "Reads the article number at point. Returns nil when a valid article number can not be read." @@ -1923,96 +1933,6 @@ gnus-agent-copy-nov-line (set-buffer nntp-server-buffer) (insert-buffer-substring gnus-agent-overview-buffer b e)))) -(defun gnus-agent-braid-nov (articles file) - "Merge agent overview data with given file. -Takes unvalidated headers for ARTICLES from -`gnus-agent-overview-buffer' and validated headers from the given -FILE and places the combined valid headers into -`nntp-server-buffer'. This function can be used, when file -doesn't exist, to valid the overview buffer." - (let (start last) - (set-buffer gnus-agent-overview-buffer) - (goto-char (point-min)) - (set-buffer nntp-server-buffer) - (erase-buffer) - (when (file-exists-p file) - (nnheader-insert-file-contents file)) - (goto-char (point-max)) - (forward-line -1) - - (unless (or (= (point-min) (point-max)) - (< (setq last (read (current-buffer))) (car articles))) - ;; Old and new overlap -- We do it the hard way. - (when (nnheader-find-nov-line (car articles)) - ;; Replacing existing NOV entry - (delete-region (point) (progn (forward-line 1) (point)))) - (gnus-agent-copy-nov-line (pop articles)) - - (ignore-errors - (while articles - (while (let ((art (read (current-buffer)))) - (cond ((< art (car articles)) - (forward-line 1) - t) - ((= art (car articles)) - (beginning-of-line) - (delete-region - (point) (progn (forward-line 1) (point))) - nil) - (t - (beginning-of-line) - nil)))) - - (gnus-agent-copy-nov-line (pop articles))))) - - (goto-char (point-max)) - - ;; Append the remaining lines - (when articles - (when last - (set-buffer gnus-agent-overview-buffer) - (setq start (point)) - (set-buffer nntp-server-buffer)) - - (let ((p (point))) - (insert-buffer-substring gnus-agent-overview-buffer start) - (goto-char p)) - - (setq last (or last -134217728)) - (while (catch 'problems - (let (sort art) - (while (not (eobp)) - (setq art (gnus-agent-read-article-number)) - (cond ((not art) - ;; Bad art num - delete this line - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point)))) - ((< art last) - ;; Art num out of order - enable sort - (setq sort t) - (forward-line 1)) - ((= art last) - ;; Bad repeat of art number - delete this line - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point)))) - (t - ;; Good art num - (setq last art) - (forward-line 1)))) - (when sort - ;; something is seriously wrong as we simply shouldn't see out-of-order data. - ;; First, we'll fix the sort. - (sort-numeric-fields 1 (point-min) (point-max)) - - ;; but now we have to consider that we may have duplicate rows... - ;; so reset to beginning of file - (goto-char (point-min)) - (setq last -134217728) - - ;; and throw a code that restarts this scan - (throw 'problems t)) - nil)))))) - ;; Keeps the compiler from warning about the free variable in ;; gnus-agent-read-agentview. (defvar gnus-agent-read-agentview) @@ -2385,10 +2305,9 @@ gnus-agent-fetch-group-1 (gnus-orphan-score gnus-orphan-score) ;; Maybe some other gnus-summary local variables should also ;; be put here. - + fetched-headers gnus-headers gnus-score - articles predicate info marks ) (unless (gnus-check-group group) @@ -2409,47 +2328,44 @@ gnus-agent-fetch-group-1 (setq info (gnus-get-info group))))))) (when arts (setq marked-articles (nconc (gnus-uncompress-range arts) - marked-articles)) - )))) + marked-articles)))))) (setq marked-articles (sort marked-articles '<)) - ;; Fetch any new articles from the server - (setq articles (gnus-agent-fetch-headers group)) + (setq gnus-newsgroup-dependencies + (or gnus-newsgroup-dependencies + (gnus-make-hashtable))) - ;; Merge new articles with marked - (setq articles (sort (append marked-articles articles) '<)) + ;; Fetch headers for any new articles from the server. + (setq fetched-headers (gnus-agent-fetch-headers group)) - (when articles - ;; Parse them and see which articles we want to fetch. - (setq gnus-newsgroup-dependencies - (or gnus-newsgroup-dependencies - (gnus-make-hashtable (length articles)))) + (when fetched-headers (setq gnus-newsgroup-headers - (or gnus-newsgroup-headers - (gnus-get-newsgroup-headers-xover articles nil nil - group))) - ;; `gnus-agent-overview-buffer' may be killed for - ;; timeout reason. If so, recreate it. + (or gnus-newsgroup-headers + fetched-headers))) + (when marked-articles + ;; `gnus-agent-overview-buffer' may be killed for timeout + ;; reason. If so, recreate it. (gnus-agent-create-buffer) (setq predicate - (gnus-get-predicate - (gnus-agent-find-parameter group 'agent-predicate))) + (gnus-get-predicate + (gnus-agent-find-parameter group 'agent-predicate))) + + ;; If the selection predicate requires scoring, score each header. - ;; If the selection predicate requires scoring, score each header (unless (memq predicate '(gnus-agent-true gnus-agent-false)) (let ((score-param (gnus-agent-find-parameter group 'agent-score-file))) - ;; Translate score-param into real one + ;; Translate score-param into real one. (cond ((not score-param)) ((eq score-param 'file) - (setq score-param (gnus-all-score-files group))) + (setq score-param (gnus-all-score-files group))) ((stringp (car score-param))) (t - (setq score-param (list (list score-param))))) + (setq score-param (list (list score-param))))) (when score-param - (gnus-score-headers score-param)))) + (gnus-score-headers score-param)))) (unless (and (eq predicate 'gnus-agent-false) (not marked-articles)) @@ -2458,50 +2374,50 @@ gnus-agent-fetch-group-1 (alist (gnus-agent-load-alist group)) (marked-articles marked-articles) (gnus-newsgroup-headers gnus-newsgroup-headers)) - (while (setq gnus-headers (pop gnus-newsgroup-headers)) + (while (setq gnus-headers (pop gnus-newsgroup-headers)) (let ((num (mail-header-number gnus-headers))) ;; Determine if this article is already in the cache (while (and alist - (> num (caar alist))) + (> num (caar alist))) (setq alist (cdr alist))) (unless (and (eq num (caar alist)) - (cdar alist)) + (cdar alist)) ;; Determine if this article was marked for download. (while (and marked-articles (> num (car marked-articles))) - (setq marked-articles + (setq marked-articles (cdr marked-articles))) ;; When this article is marked, or selected by the ;; predicate, add it to the download list (when (or (eq num (car marked-articles)) - (let ((gnus-score + (let ((gnus-score (or (cdr (assq num gnus-newsgroup-scored)) gnus-summary-default-score)) (gnus-agent-long-article (gnus-agent-find-parameter - group 'agent-long-article)) + group 'agent-long-article)) (gnus-agent-short-article (gnus-agent-find-parameter - group 'agent-short-article)) + group 'agent-short-article)) (gnus-agent-low-score (gnus-agent-find-parameter - group 'agent-low-score)) + group 'agent-low-score)) (gnus-agent-high-score (gnus-agent-find-parameter - group 'agent-high-score)) + group 'agent-high-score)) (gnus-agent-expire-days (gnus-agent-find-parameter - group 'agent-days-until-old))) + group 'agent-days-until-old))) (funcall predicate))) - (gnus-agent-append-to-list arts-tail num)))))) + (gnus-agent-append-to-list arts-tail num)))))) (let (fetched-articles) - ;; Fetch all selected articles - (setq gnus-newsgroup-undownloaded + ;; Fetch all selected articles + (setq gnus-newsgroup-undownloaded (gnus-sorted-ndifference gnus-newsgroup-undownloaded (setq fetched-articles @@ -2509,14 +2425,14 @@ gnus-agent-fetch-group-1 (gnus-agent-fetch-articles group (cdr arts)) nil)))) - (let ((unfetched-articles + (let ((unfetched-articles (gnus-sorted-ndifference (cdr arts) fetched-articles))) (if gnus-newsgroup-active ;; Update the summary buffer (progn - (dolist (article marked-articles) + (dolist (article marked-articles) (gnus-summary-set-agent-mark article t)) - (dolist (article fetched-articles) + (dolist (article fetched-articles) (when gnus-agent-mark-unread-after-downloaded (setq gnus-newsgroup-downloadable (delq article gnus-newsgroup-downloadable)) @@ -2524,7 +2440,7 @@ gnus-agent-fetch-group-1 article gnus-unread-mark)) (when (gnus-summary-goto-subject article nil t) (gnus-summary-update-download-mark article))) - (dolist (article unfetched-articles) + (dolist (article unfetched-articles) (gnus-summary-mark-article article gnus-canceled-mark))) @@ -2537,7 +2453,7 @@ gnus-agent-fetch-group-1 (dolist (mark gnus-agent-download-marks) (when (eq mark 'download) - (let ((marked-arts + (let ((marked-arts (assq mark (gnus-info-marks (setq info (gnus-get-info group)))))) (when (cdr marked-arts) @@ -3661,11 +3577,11 @@ gnus-agent-uncached-articles (defun gnus-agent-retrieve-headers (articles group &optional fetch-old) (save-excursion (gnus-agent-create-buffer) - (let ((gnus-decode-encoded-word-function 'identity) - (gnus-decode-encoded-address-function 'identity) + (let ((gnus-decode-encoded-word-function #'identity) + (gnus-decode-encoded-address-function #'identity) (file (gnus-agent-article-name ".overview" group)) - uncached-articles - (file-name-coding-system nnmail-pathname-coding-system)) + (file-name-coding-system nnmail-pathname-coding-system) + uncached-articles headers fetched-headers) (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) @@ -3676,122 +3592,108 @@ gnus-agent-retrieve-headers 1) (car (last articles)))))) - ;; Populate temp buffer with known headers + ;; Parse known headers from FILE. (when (file-exists-p file) (with-current-buffer gnus-agent-overview-buffer (erase-buffer) (let ((nnheader-file-coding-system gnus-agent-file-coding-system)) - (nnheader-insert-nov-file file (car articles))))) + (nnheader-insert-nov-file file (car articles)) + (while (not (eobp)) + (push (nnheader-parse-nov) headers) + (forward-line 1)) + (setq headers (nreverse headers))))) + + (when (setq uncached-articles (gnus-agent-uncached-articles + articles group t)) + (let ((gnus-newsgroup-name group) + gnus-agent) ; Prevent loop. + (when (eq 'nntp (car gnus-current-select-method)) + ;; The author of gnus-get-newsgroup-headers-xover + ;; reports that the XOVER command is commonly + ;; unreliable. The problem is that recently + ;; posted articles may not be entered into the + ;; NOV database in time to respond to my XOVER + ;; query. + ;; + ;; I'm going to use his assumption that the NOV + ;; database is updated in order of ascending + ;; article ID. Therefore, a response containing + ;; article ID N implies that all articles from 1 + ;; to N-1 are up-to-date. Therefore, missing + ;; articles in that range have expired. + + (let* ((fetched-articles + (mapcar #'mail-header-number headers)) + (min (car articles)) + (max (car (last articles)))) + + ;; Clip the list of fetched articles to the headers that + ;; will actually be returned + (setq fetched-articles (gnus-list-range-intersection + fetched-articles + (cons min max))) + + ;; Clip the uncached articles list to exclude + ;; IDs after the last FETCHED header. The + ;; excluded IDs may be fetchable using HEAD. + (when (car (last fetched-articles)) + (setq uncached-articles + (gnus-list-range-intersection + uncached-articles + (cons (car uncached-articles) + (car (last 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 an expired + ;; article, the header will not be fetched. + (setq uncached-articles + (gnus-sorted-nunion fetched-articles + uncached-articles)))) + + ;; Fetch additional headers for the uncached articles. + (setq fetched-headers (gnus-fetch-headers uncached-articles)) + ;; Merge headers we got from `file' with our newly-fetched + ;; headers. We need to sort and delete dups; perhaps this + ;; could be done more efficiently, but for now just do it + ;; the dumb way. Assume that the headers from `file' are + ;; prior to the newly-fetched headers. + (when fetched-headers + (setq headers + (delete-dups + (sort (append headers fetched-headers) + (lambda (l r) + (< (mail-header-number l) + (mail-header-number r))))))) + + ;; Save the new set of known headers to FILE + (let ((coding-system-for-write + gnus-agent-file-coding-system)) + (with-current-buffer gnus-agent-overview-buffer + (erase-buffer) + (mapc #'nnheader-insert-nov headers) + (gnus-agent-check-overview-buffer) + (write-region (point-min) (point-max) file nil 'silent))) - (if (setq uncached-articles (gnus-agent-uncached-articles articles group - t)) - (progn - ;; Populate nntp-server-buffer with uncached headers - (set-buffer nntp-server-buffer) - (erase-buffer) - (cond ((not (eq 'nov (let (gnus-agent) ; Turn off agent - (gnus-retrieve-headers - uncached-articles group)))) - (nnvirtual-convert-headers)) - ((eq 'nntp (car gnus-current-select-method)) - ;; The author of gnus-get-newsgroup-headers-xover - ;; reports that the XOVER command is commonly - ;; unreliable. The problem is that recently - ;; posted articles may not be entered into the - ;; NOV database in time to respond to my XOVER - ;; query. - ;; - ;; I'm going to use his assumption that the NOV - ;; database is updated in order of ascending - ;; article ID. Therefore, a response containing - ;; article ID N implies that all articles from 1 - ;; to N-1 are up-to-date. Therefore, missing - ;; articles in that range have expired. - - (set-buffer nntp-server-buffer) - (let* ((fetched-articles (list nil)) - (tail-fetched-articles fetched-articles) - (min (car articles)) - (max (car (last articles)))) - - ;; Get the list of articles that were fetched - (goto-char (point-min)) - (let ((pm (point-max)) - art) - (while (< (point) pm) - (when (setq art (gnus-agent-read-article-number)) - (gnus-agent-append-to-list tail-fetched-articles art)) - (forward-line 1))) - - ;; Clip this list to the headers that will - ;; actually be returned - (setq fetched-articles (gnus-list-range-intersection - (cdr fetched-articles) - (cons min max))) - - ;; Clip the uncached articles list to exclude - ;; IDs after the last FETCHED header. The - ;; excluded IDs may be fetchable using HEAD. - (if (car tail-fetched-articles) - (setq uncached-articles - (gnus-list-range-intersection - uncached-articles - (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 an expired - ;; article, the header will not be fetched. - (setq uncached-articles - (gnus-sorted-nunion fetched-articles - uncached-articles)) - ))) - - ;; Erase the temp buffer - (set-buffer gnus-agent-overview-buffer) - (erase-buffer) + (gnus-agent-update-view-total-fetched-for group t) - ;; Copy the nntp-server-buffer to the temp buffer - (set-buffer nntp-server-buffer) - (copy-to-buffer gnus-agent-overview-buffer (point-min) (point-max)) + ;; Update the group's article alist to include the newly + ;; fetched articles. + (gnus-agent-load-alist group) + (gnus-agent-save-alist group uncached-articles nil))) - ;; Merge the temp buffer with the known headers (found on - ;; disk in FILE) into the nntp-server-buffer - (when uncached-articles - (gnus-agent-braid-nov uncached-articles file)) + (unless (and fetch-old + (not (numberp fetch-old))) + ;; Drop headers that are not within the range of `articles'. + (setq headers (seq-remove + (lambda (h) + (or (< (mail-header-number h) (car articles)) + (> (mail-header-number h) (car (last articles))))) + headers))) - ;; Save the new set of known headers to FILE - (set-buffer nntp-server-buffer) - (let ((coding-system-for-write - gnus-agent-file-coding-system)) - (gnus-agent-check-overview-buffer) - (write-region (point-min) (point-max) file nil 'silent)) - - (gnus-agent-update-view-total-fetched-for group t) - - ;; Update the group's article alist to include the newly - ;; fetched articles. - (gnus-agent-load-alist group) - (gnus-agent-save-alist group uncached-articles nil) - ) - - ;; Copy the temp buffer to the nntp-server-buffer - (set-buffer nntp-server-buffer) - (erase-buffer) - (insert-buffer-substring gnus-agent-overview-buffer))) - - (if (and fetch-old - (not (numberp fetch-old))) - t ; Don't remove anything. - (nnheader-nov-delete-outside-range - (car articles) - (car (last articles))) - t) - - 'nov)) + headers))) (defun gnus-agent-request-article (article group) "Retrieve ARTICLE in GROUP from the agent cache." diff --git a/lisp/gnus/gnus-async.el b/lisp/gnus/gnus-async.el index 9bcb6c33a6..39b5e43837 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -350,8 +350,13 @@ gnus-async-prefetch-headers (let ((nntp-server-buffer (current-buffer)) (nnheader-callback-function (lambda (_arg) - (setq gnus-async-header-prefetched - (cons group unread))))) + (setq gnus-async-header-prefetched + (cons group unread))))) + ;; FIXME: If header prefetch is ever put into use, we'll + ;; have to handle the possibility that + ;; `gnus-retrieve-headers' might return a list of header + ;; vectors directly, rather than writing them into the + ;; current buffer. (gnus-retrieve-headers unread group gnus-fetch-old-headers)))))) (defun gnus-async-retrieve-fetched-headers (articles group) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index c31d97d41c..483ee06296 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -294,49 +294,46 @@ gnus-cache-possibly-alter-active (defun gnus-cache-retrieve-headers (articles group &optional fetch-old) "Retrieve the headers for ARTICLES in GROUP." (let ((cached - (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))) + (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))) + (gnus-newsgroup-name group) + (gnus-fetch-old-headers fetch-old)) (if (not cached) ;; No cached articles here, so we just retrieve them ;; the normal way. (let ((gnus-use-cache nil)) - (gnus-retrieve-headers articles group fetch-old)) + (gnus-fetch-headers articles group)) (let ((uncached-articles (gnus-sorted-difference articles cached)) (cache-file (gnus-cache-file-name group ".overview")) - type - (file-name-coding-system nnmail-pathname-coding-system)) + (file-name-coding-system nnmail-pathname-coding-system) + headers) ;; We first retrieve all the headers that we don't have in ;; the cache. (let ((gnus-use-cache nil)) (when uncached-articles - (setq type (and articles - (gnus-retrieve-headers - uncached-articles group fetch-old))))) - (gnus-cache-save-buffers) - ;; Then we insert the cached headers. - (save-excursion - (cond - ((not (file-exists-p cache-file)) - ;; There are no cached headers. - type) - ((null type) - ;; There were no uncached headers (or retrieval was - ;; unsuccessful), so we use the cached headers exclusively. - (set-buffer nntp-server-buffer) - (erase-buffer) - (let ((coding-system-for-read - gnus-cache-overview-coding-system)) - (insert-file-contents cache-file)) - 'nov) - ((eq type 'nov) - ;; We have both cached and uncached NOV headers, so we - ;; braid them. - (gnus-cache-braid-nov group cached) - type) - (t - ;; We braid HEADs. - (gnus-cache-braid-heads group (gnus-sorted-intersection - cached articles)) - type))))))) + (setq headers (and articles + (gnus-fetch-headers uncached-articles))))) + (when headers + (with-current-buffer (cdr gnus-cache-buffer) + (goto-char (point-min)) + (mapc #'nnheader-insert-nov headers) + (gnus-cache-save-buffers))) + ;; Then we include the cached headers. + (when (file-exists-p cache-file) + (setq headers + (delete-dups + (sort + (append headers + (let ((coding-system-for-read + gnus-cache-overview-coding-system) + (gnus-read-all-available-headers t)) + (set-buffer nntp-server-buffer) + (erase-buffer) + (insert-file-contents cache-file) + (gnus-get-newsgroup-headers-xover nil))) + (lambda (l r) + (< (mail-header-number l) + (mail-header-number r))))))) + headers)))) (defun gnus-cache-enter-article (&optional n) "Enter the next N articles into the cache. @@ -529,70 +526,6 @@ gnus-cache-articles-in-group (setq gnus-cache-active-altered t))) articles))) -(defun gnus-cache-braid-nov (group cached &optional file) - (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*")) - beg end) - (gnus-cache-save-buffers) - (with-current-buffer cache-buf - (erase-buffer) - (let ((coding-system-for-read gnus-cache-overview-coding-system) - (file-name-coding-system nnmail-pathname-coding-system)) - (insert-file-contents - (or file (gnus-cache-file-name group ".overview")))) - (goto-char (point-min)) - (insert "\n") - (goto-char (point-min))) - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (while cached - (while (and (not (eobp)) - (< (read (current-buffer)) (car cached))) - (forward-line 1)) - (beginning-of-line) - (set-buffer cache-buf) - (if (search-forward (concat "\n" (int-to-string (car cached)) "\t") - nil t) - (setq beg (point-at-bol) - end (progn (end-of-line) (point))) - (setq beg nil)) - (set-buffer nntp-server-buffer) - (when beg - (insert-buffer-substring cache-buf beg end) - (insert "\n")) - (setq cached (cdr cached))) - (kill-buffer cache-buf))) - -(defun gnus-cache-braid-heads (group cached) - (let ((cache-buf (gnus-get-buffer-create " *gnus-cache*"))) - (with-current-buffer cache-buf - (erase-buffer)) - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (dolist (entry cached) - (while (and (not (eobp)) - (looking-at "2.. +\\([0-9]+\\) ") - (< (progn (goto-char (match-beginning 1)) - (read (current-buffer))) - entry)) - (search-forward "\n.\n" nil 'move)) - (beginning-of-line) - (set-buffer cache-buf) - (erase-buffer) - (let ((coding-system-for-read gnus-cache-coding-system) - (file-name-coding-system nnmail-pathname-coding-system)) - (insert-file-contents (gnus-cache-file-name group entry))) - (goto-char (point-min)) - (insert "220 ") - (princ (pop cached) (current-buffer)) - (insert " Article retrieved.\n") - (search-forward "\n\n" nil 'move) - (delete-region (point) (point-max)) - (forward-char -1) - (insert ".") - (set-buffer nntp-server-buffer) - (insert-buffer-substring cache-buf)) - (kill-buffer cache-buf))) - ;;;###autoload (defun gnus-jog-cache () "Go through all groups and put the articles into the cache. diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index 3e23e26326..92677029b9 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -30,6 +30,8 @@ (require 'parse-time) (require 'nnimap) +(declare-function gnus-fetch-headers "gnus-sum") +(defvar gnus-alter-header-function) (eval-when-compile (require 'epg)) ;; setf-method for `epg-context-armor' (autoload 'epg-make-context "epg") @@ -407,14 +409,10 @@ gnus-cloud-available-chunks (gnus-activate-group gnus-cloud-group-name nil nil gnus-cloud-method) (let* ((group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method)) (active (gnus-active group)) - headers head) - (when (gnus-retrieve-headers (gnus-uncompress-range active) group) - (with-current-buffer nntp-server-buffer - (goto-char (point-min)) - (while (setq head (nnheader-parse-head)) - (when gnus-alter-header-function - (funcall gnus-alter-header-function head)) - (push head headers)))) + (gnus-newsgroup-name group) + (headers (gnus-fetch-headers (gnus-uncompress-range active)))) + (when gnus-alter-header-function + (mapc #'gnus-alter-header-function headers)) (sort (nreverse headers) (lambda (h1 h2) (> (gnus-cloud-chunk-sequence (mail-header-subject h1)) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index b3ed5cb664..629692eb26 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -4548,6 +4548,11 @@ gnus-nov-parse-line (forward-char)) (setq header (nnheader-parse-nov number)) (widen)) + ;; (when (and (string= references "") + ;; (setq in-reply-to (mail-header-extra header)) + ;; (setq in-reply-to (cdr (assq 'In-Reply-To in-reply-to)))) + ;; (setf (mail-header-references header) + ;; (gnus-extract-message-id-from-in-reply-to in-reply-to))) (when gnus-alter-header-function (funcall gnus-alter-header-function header)) (gnus-dependencies-add-header header dependencies force-new))) @@ -5616,10 +5621,21 @@ gnus-summary-remove-list-identifiers (setf (mail-header-subject header) subject)))))) (defun gnus-fetch-headers (articles &optional limit force-new dependencies) - "Fetch headers of ARTICLES." + "Fetch headers of ARTICLES. +This calls the `gnus-retrieve-headers' function of the current +group's backend server. The server can do one of two things: + +1. Write the headers for ARTICLES into the + `nntp-server-buffer' (the current buffer) in a parseable format, or +2. Return the headers directly as a list of vectors. + +In the first case, `gnus-retrieve-headers' returns a symbol +value, either `nov' or `headers'. This value determines which +parsing function is used to read the headers. It is also stored +into the variable `gnus-headers-retrieved-by', which is consulted +later when possibly building full threads." (gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name) - (prog1 - (pcase (setq gnus-headers-retrieved-by + (let ((res (setq gnus-headers-retrieved-by (gnus-retrieve-headers articles gnus-newsgroup-name (or limit @@ -5629,22 +5645,29 @@ gnus-fetch-headers (not (eq gnus-fetch-old-headers 'some)) (not (numberp gnus-fetch-old-headers))) (> (length articles) 1)) - gnus-fetch-old-headers)))) - ('nov - (gnus-get-newsgroup-headers-xover - articles force-new dependencies gnus-newsgroup-name t)) - ('headers - (gnus-get-newsgroup-headers dependencies force-new)) - ((pred listp) - (let ((dependencies - (or dependencies - (with-current-buffer gnus-summary-buffer - gnus-newsgroup-dependencies)))) - (delq nil (mapcar #'(lambda (header) - (gnus-dependencies-add-header - header dependencies force-new)) - gnus-headers-retrieved-by))))) - (gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name))) + gnus-fetch-old-headers)))))) + (prog1 + (pcase res + ('nov + (gnus-get-newsgroup-headers-xover + articles force-new dependencies gnus-newsgroup-name t)) + ;; For now, assume that any backend returning its own + ;; headers takes some effort to do so, so return `headers'. + ((pred listp) + (setq gnus-headers-retrieved-by 'headers) + (let ((dependencies + (or dependencies + (buffer-local-value + gnus-newsgroup-dependencies gnus-summary-buffer)))) + (when (functionp gnus-alter-header-function) + (mapc gnus-alter-header-function res)) + (delq nil (mapcar (lambda (header) + (gnus-dependencies-add-header + header dependencies force-new)) + res)))) + (_ (gnus-get-newsgroup-headers dependencies force-new))) + (gnus-message 7 "Fetching headers for %s...done" + gnus-newsgroup-name)))) (defun gnus-select-newsgroup (group &optional read-all select-articles) "Select newsgroup GROUP. @@ -6399,6 +6422,10 @@ gnus-group-make-articles-read (unless (gnus-ephemeral-group-p group) (gnus-group-update-group group t)))))) +;; FIXME: Refactor this with `gnus-get-newsgroup-headers-xover' and +;; extract the necessary bits for the direct-header-return case. Also +;; look at this and see how similar it is to +;; `nnheader-parse-naked-head'. (defun gnus-get-newsgroup-headers (&optional dependencies force-new) (let ((dependencies (or dependencies diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index cb534260a6..dc4f780245 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -2384,7 +2384,14 @@ gnus-article-unpropagated-mark-lists such as a mark that says whether an article is stored in the cache \(which doesn't make sense in a standalone back end).") -(defvar gnus-headers-retrieved-by nil) +(defvar gnus-headers-retrieved-by nil + "Holds the return value of `gnus-retrieve-headers'. +This is either the symbol `nov' or the symbol `headers'. This +value is checked during the summary creation process, when +building threads. A value of `nov' indicates that header +retrieval is relatively cheap and threading is encouraged to +include more old articles. A value of `headers' indciates that +retrieval is expensive and should be minimized.") (defvar gnus-article-reply nil) (defvar gnus-override-method nil) (defvar gnus-opened-servers nil) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index 20f82e5cbd..c0fb865d51 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -503,7 +503,6 @@ nnir-method-default-engines ,@(mapcar (lambda (elem) (list 'const (car elem))) nnir-engines))))) - (defmacro nnir-add-result (dirnam artno score prefix server artlist) "Construct a result vector and add it to ARTLIST. DIRNAM, ARTNO, SCORE, PREFIX and SERVER are passed to diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index 54c2f7be82..10e8be7f2d 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -96,15 +96,10 @@ nnvirtual-retrieve-headers (erase-buffer) (if (stringp (car articles)) 'headers - (let ((vbuf (nnheader-set-temp-buffer - (gnus-get-buffer-create " *virtual headers*"))) - (carticles (nnvirtual-partition-sequence articles)) + (let ((carticles (nnvirtual-partition-sequence articles)) (sysname (system-name)) - cgroup carticle article result prefix) - (while carticles - (setq cgroup (caar carticles)) - (setq articles (cdar carticles)) - (pop carticles) + cgroup headers all-headers article prefix) + (pcase-dolist (`(,cgroup . ,articles) carticles) (when (and articles (gnus-check-server (gnus-find-method-for-group cgroup) t) @@ -114,69 +109,37 @@ nnvirtual-retrieve-headers ;; This is probably evil if people have set ;; gnus-use-cache to nil themselves, but I ;; have no way of finding the true value of it. - (let ((gnus-use-cache t)) - (setq result (gnus-retrieve-headers - articles cgroup nil)))) - (set-buffer nntp-server-buffer) - ;; If we got HEAD headers, we convert them into NOV - ;; headers. This is slow, inefficient and, come to think - ;; of it, downright evil. So sue me. I couldn't be - ;; bothered to write a header parse routine that could - ;; parse a mixed HEAD/NOV buffer. - (when (eq result 'headers) - (nnvirtual-convert-headers)) - (goto-char (point-min)) - (while (not (eobp)) - (delete-region (point) - (progn - (setq carticle (read nntp-server-buffer)) - (point))) - - ;; We remove this article from the articles list, if - ;; anything is left in the articles list after going through - ;; the entire buffer, then those articles have been - ;; expired or canceled, so we appropriately update the - ;; component group below. They should be coming up - ;; generally in order, so this shouldn't be slow. - (setq articles (delq carticle articles)) - - (setq article (nnvirtual-reverse-map-article cgroup carticle)) - (if (null article) - ;; This line has no reverse mapping, that means it - ;; was an extra article reference returned by nntp. - (progn - (beginning-of-line) - (delete-region (point) (progn (forward-line 1) (point)))) - ;; Otherwise insert the virtual article number, - ;; and clean up the xrefs. - (princ article nntp-server-buffer) - (nnvirtual-update-xref-header cgroup carticle - prefix sysname) - (forward-line 1)) - ) - - (set-buffer vbuf) - (goto-char (point-max)) - (insert-buffer-substring nntp-server-buffer)) - ;; Anything left in articles is expired or canceled. - ;; Could be smart and not tell it about articles already known? - (when articles - (gnus-group-make-articles-read cgroup articles)) - ) - - ;; The headers are ready for reading, so they are inserted into - ;; the nntp-server-buffer, which is where Gnus expects to find - ;; them. - (prog1 - (with-current-buffer nntp-server-buffer - (erase-buffer) - (insert-buffer-substring vbuf) - ;; FIX FIX FIX, we should be able to sort faster than - ;; this if needed, since each cgroup is sorted, we just - ;; need to merge - (sort-numeric-fields 1 (point-min) (point-max)) - 'nov) - (kill-buffer vbuf))))))) + (let ((gnus-use-cache t) + (gnus-newsgroup-name cgroup) + (gnus-fetch-old-headers nil)) + (setq headers (gnus-fetch-headers articles)))) + (erase-buffer) + ;; Remove all header article numbers from `articles'. + ;; If there's anything left, those are expired or + ;; canceled articles, so we update the component group + ;; below. + (dolist (h headers) + (setq articles (delq (mail-header-number h) articles) + article (nnvirtual-reverse-map-article + cgroup (mail-header-number h))) + ;; Update all the header numbers according to their + ;; reverse mapping, and drop any with no such mapping. + (when article + ;; Do this first, before we re-set the header's + ;; article number. + (nnvirtual-update-xref-header + h cgroup prefix sysname) + (setf (mail-header-number h) article) + (push h all-headers))) + ;; Anything left in articles is expired or canceled. + ;; Could be smart and not tell it about articles already + ;; known? + (when articles + (gnus-group-make-articles-read cgroup articles)))) + + (sort all-headers (lambda (h1 h2) + (< (mail-header-number h1) + (mail-header-number h2))))))))) (defvoo nnvirtual-last-accessed-component-group nil) @@ -367,61 +330,22 @@ nnvirtual-request-expire-articles ;;; Internal functions. -(defun nnvirtual-convert-headers () - "Convert HEAD headers into NOV headers." - (with-current-buffer nntp-server-buffer - (let* ((dependencies (make-hash-table :test #'equal)) - (headers (gnus-get-newsgroup-headers dependencies))) - (erase-buffer) - (mapc 'nnheader-insert-nov headers)))) - - -(defun nnvirtual-update-xref-header (group article prefix sysname) - "Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines." - ;; Move to beginning of Xref field, creating a slot if needed. - (beginning-of-line) - (looking-at - "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t") - (goto-char (match-end 0)) - (unless (search-forward "\t" (point-at-eol) 'move) - (insert "\t")) - - ;; Remove any spaces at the beginning of the Xref field. - (while (eq (char-after (1- (point))) ? ) - (forward-char -1) - (delete-char 1)) - - (insert "Xref: " sysname " " group ":") - (princ article (current-buffer)) - (insert " ") - - ;; If there were existing xref lines, clean them up to have the correct - ;; component server prefix. - (save-restriction - (narrow-to-region (point) - (or (search-forward "\t" (point-at-eol) t) - (point-at-eol))) - (goto-char (point-min)) - (when (re-search-forward "Xref: *[^\n:0-9 ]+ *" nil t) - (replace-match "" t t)) - (goto-char (point-min)) - (when (re-search-forward - (concat (regexp-quote (gnus-group-real-name group)) ":[0-9]+") - nil t) - (replace-match "" t t)) - (unless (eobp) - (insert " ") - (when (not (string= "" prefix)) - (while (re-search-forward "[^ ]+:[0-9]+" nil t) - (save-excursion - (goto-char (match-beginning 0)) - (insert prefix)))))) - - ;; Ensure a trailing \t. - (end-of-line) - (or (eq (char-after (1- (point))) ?\t) - (insert ?\t))) - +(defun nnvirtual-update-xref-header (header group prefix sysname) + "Add xref to component GROUP to HEADER. +Also add a server PREFIX any existing xref lines." + (let ((bits (split-string (mail-header-xref header) + nil t "[[:blank:]]")) + (art-no (mail-header-number header))) + (setf (mail-header-xref header) + (mapconcat #'identity + (cons (format "%s %s:%d" + sysname group art-no) + (mapcar (lambda (bit) + (if (string-prefix-p prefix bit) + bit + (concat prefix bit))) + bits)) + " ")))) (defun nnvirtual-possibly-change-server (server) (or (not server) -- 2.28.0