From 046db04e3da4afa7c6eb05af8c7ceb048689521a Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Tue, 26 Jan 2021 08:47:07 -0800 Subject: [PATCH] Revert "Allow gnus-retrieve-headers to return headers directly" This reverts commit 20add1cd22f9775a4475148b300cf2a4de4bd54a. This needs more work before it's ready to merge. --- lisp/gnus/gnus-agent.el | 383 +++++++++++++++++++++++++++------------- lisp/gnus/gnus-async.el | 9 +- lisp/gnus/gnus-cache.el | 126 +++++++++---- lisp/gnus/gnus-cloud.el | 16 +- lisp/gnus/gnus-sum.el | 65 ++----- lisp/gnus/gnus.el | 9 +- lisp/gnus/nnvirtual.el | 172 +++++++++++++----- lisp/obsolete/nnir.el | 1 + 8 files changed, 517 insertions(+), 264 deletions(-) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 686623029ed..56640ea8302 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -1789,7 +1789,6 @@ variables. Returns the first non-nil value found." . 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 @@ -1811,9 +1810,10 @@ article numbers will be returned." (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) (file (gnus-agent-article-name ".overview" group)) - (file-name-coding-system nnmail-pathname-coding-system) - headers fetched-headers) + (file-name-coding-system nnmail-pathname-coding-system)) (unless fetch-all ;; Add articles with marks to the list of article headers we want to @@ -1824,7 +1824,7 @@ article numbers will be returned." (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-range articles) '<))) + (setq articles (sort (gnus-uncompress-sequence 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,52 +1867,38 @@ article numbers will be returned." 10 "gnus-agent-fetch-headers: undownloaded articles are `%s'" (gnus-compress-sequence articles t))) - ;; 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)) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (insert-buffer-substring gnus-agent-overview-buffer) - (setq headers - (gnus-get-newsgroup-headers-xover - articles nil (buffer-local-value - 'gnus-newsgroup-dependencies - gnus-summary-buffer) - gnus-newsgroup-name))))) - (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 (copy-sequence 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 - (goto-char (point-max)) - (mapc #'nnheader-insert-nov fetched-headers) - (sort-numeric-fields 1 (point-min) (point-max)) - (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)) + (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)) (defsubst gnus-agent-read-article-number () "Read the article number at point. @@ -1938,6 +1924,96 @@ Return nil when a valid article number can not be read." (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) @@ -2310,9 +2386,10 @@ modified) original contents, they are first saved to their own file." (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) @@ -2333,35 +2410,38 @@ modified) original contents, they are first saved to their own file." (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 '<)) - (setq gnus-newsgroup-dependencies - (or gnus-newsgroup-dependencies - (gnus-make-hashtable))) + ;; Fetch any new articles from the server + (setq articles (gnus-agent-fetch-headers group)) - ;; Fetch headers for any new articles from the server. - (setq fetched-headers (gnus-agent-fetch-headers group)) + ;; Merge new articles with marked + (setq articles (sort (append marked-articles articles) '<)) - (when fetched-headers + (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)))) (setq gnus-newsgroup-headers - (or gnus-newsgroup-headers - fetched-headers))) - (when marked-articles - ;; `gnus-agent-overview-buffer' may be killed for timeout - ;; reason. If so, recreate it. + (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. (gnus-agent-create-buffer) (setq predicate - (gnus-get-predicate - (gnus-agent-find-parameter group 'agent-predicate))) - - ;; If the selection predicate requires scoring, score each header. + (gnus-get-predicate + (gnus-agent-find-parameter group 'agent-predicate))) + ;; 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) @@ -3581,9 +3661,11 @@ has been fetched." (defun gnus-agent-retrieve-headers (articles group &optional fetch-old) (save-excursion (gnus-agent-create-buffer) - (let ((file (gnus-agent-article-name ".overview" group)) - (file-name-coding-system nnmail-pathname-coding-system) - uncached-articles headers fetched-headers) + (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)) (gnus-make-directory (nnheader-translate-file-chars (file-name-directory file) t)) @@ -3594,63 +3676,122 @@ has been fetched." 1) (car (last articles)))))) - ;; See if we've got cached headers for ARTICLES and put them in - ;; HEADERS. Articles with no cached headers go in - ;; UNCACHED-ARTICLES to be fetched from the server. + ;; Populate temp buffer with known headers (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)) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (insert-buffer-substring gnus-agent-overview-buffer) - (setq headers - (gnus-get-newsgroup-headers-xover - articles nil (buffer-local-value - 'gnus-newsgroup-dependencies - gnus-summary-buffer) - gnus-newsgroup-name)))))) - - (setq uncached-articles - (gnus-agent-uncached-articles articles group t)) - - (when uncached-articles - (let ((gnus-newsgroup-name group) - gnus-agent) ; Prevent loop. - ;; Fetch additional headers for the uncached articles. - (setq fetched-headers (gnus-fetch-headers uncached-articles)) - ;; Merge headers we got from the overview file with our - ;; newly-fetched headers. - (when fetched-headers - (setq headers - (delete-dups - (sort (append headers (copy-sequence fetched-headers)) - (lambda (l r) - (< (mail-header-number l) - (mail-header-number r)))))) - - ;; Add the new set of known headers to the overview file. + (nnheader-insert-nov-file file (car articles))))) + + (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) + + ;; 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)) + + ;; 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)) + + ;; Save the new set of known headers to FILE + (set-buffer nntp-server-buffer) (let ((coding-system-for-write gnus-agent-file-coding-system)) - (with-current-buffer gnus-agent-overview-buffer - ;; We stick the new headers in at the end, then - ;; re-sort the whole buffer with - ;; `sort-numeric-fields'. If this turns out to be - ;; slow, we could consider a loop to add the headers - ;; in sorted order to begin with. - (goto-char (point-max)) - (mapc #'nnheader-insert-nov fetched-headers) - (sort-numeric-fields 1 (point-min) (point-max)) - (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)))))) - headers))) + (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)) (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 ed948a26c0b..fefd02c7bfb 100644 --- a/lisp/gnus/gnus-async.el +++ b/lisp/gnus/gnus-async.el @@ -357,13 +357,8 @@ that was fetched." (let ((nntp-server-buffer (current-buffer)) (nnheader-callback-function (lambda (_arg) - (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. + (setq gnus-async-header-prefetched + (cons group unread))))) (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 9423d9f2f6b..36657e46219 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -294,47 +294,49 @@ it's not cached." (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))) - (gnus-newsgroup-name group) - (gnus-fetch-old-headers fetch-old)) + (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group)))) (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)) + (gnus-retrieve-headers articles group fetch-old)) (let ((uncached-articles (gnus-sorted-difference articles cached)) (cache-file (gnus-cache-file-name group ".overview")) - (file-name-coding-system nnmail-pathname-coding-system) - headers) + type + (file-name-coding-system nnmail-pathname-coding-system)) ;; We first retrieve all the headers that we don't have in ;; the cache. (let ((gnus-use-cache nil)) (when uncached-articles - (setq headers (and articles - (gnus-fetch-headers uncached-articles))))) + (setq type (and articles + (gnus-retrieve-headers + uncached-articles group fetch-old))))) (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)) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (insert-file-contents cache-file) - (gnus-get-newsgroup-headers-xover - (gnus-sorted-difference - cached uncached-articles) - nil (buffer-local-value - 'gnus-newsgroup-dependencies - gnus-summary-buffer) - group)))) - (lambda (l r) - (< (mail-header-number l) - (mail-header-number r))))))) - headers)))) + ;; 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))))))) (defun gnus-cache-enter-article (&optional n) "Enter the next N articles into the cache. @@ -527,6 +529,70 @@ Returns the list of articles removed." (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 00b85f546c2..f7c71f43ce8 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -30,8 +30,6 @@ (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") @@ -393,6 +391,8 @@ When FULL is t, upload everything, not just a difference from the last full." (gnus-group-refresh-group group)) (gnus-error 2 "Failed to upload Gnus Cloud data to %s" group))))) +(defvar gnus-alter-header-function) + (defun gnus-cloud-add-timestamps (elems) (dolist (elem elems) (let* ((file-name (plist-get elem :file-name)) @@ -407,10 +407,14 @@ When FULL is t, upload everything, not just a difference from the last full." (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)) - (gnus-newsgroup-name group) - (headers (gnus-fetch-headers (gnus-uncompress-range active)))) - (when gnus-alter-header-function - (mapc gnus-alter-header-function headers)) + 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)))) (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 5bd58b690af..b0f9ed4c6f0 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -5658,21 +5658,10 @@ or a straight list of headers." (setf (mail-header-subject header) subject)))))) (defun gnus-fetch-headers (articles &optional limit force-new dependencies) - "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." + "Fetch headers of ARTICLES." (gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name) - (let ((res (setq gnus-headers-retrieved-by + (prog1 + (pcase (setq gnus-headers-retrieved-by (gnus-retrieve-headers articles gnus-newsgroup-name (or limit @@ -5682,34 +5671,22 @@ later when possibly building full threads." (not (eq gnus-fetch-old-headers 'some)) (not (numberp gnus-fetch-old-headers))) (> (length articles) 1)) - 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)) - (mapc (lambda (header) - ;; The agent or the cache may have already - ;; registered this header in the dependency - ;; table. - (unless (gethash (mail-header-id header) dependencies) - (gnus-dependencies-add-header - header dependencies force-new))) - res) - res)) - (_ (gnus-get-newsgroup-headers dependencies force-new))) - (gnus-message 7 "Fetching headers for %s...done" - gnus-newsgroup-name)))) + 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))) (defun gnus-select-newsgroup (group &optional read-all select-articles) "Select newsgroup GROUP. @@ -6466,10 +6443,6 @@ The resulting hash table is returned, or nil if no Xrefs were found." (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 2e9ee7189d2..3b172db2111 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -2388,14 +2388,7 @@ Typical marks are those that make no sense in a standalone back end, 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 - "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' indicates that -retrieval is expensive and should be minimized.") +(defvar gnus-headers-retrieved-by nil) (defvar gnus-article-reply nil) (defvar gnus-override-method nil) (defvar gnus-opened-servers nil) diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index ba2934351d6..1e2feda6365 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -101,10 +101,15 @@ It is computed from the marks of individual component groups.") (erase-buffer) (if (stringp (car articles)) 'headers - (let ((carticles (nnvirtual-partition-sequence articles)) + (let ((vbuf (nnheader-set-temp-buffer + (gnus-get-buffer-create " *virtual headers*"))) + (carticles (nnvirtual-partition-sequence articles)) (sysname (system-name)) - cgroup headers all-headers article prefix) - (pcase-dolist (`(,cgroup . ,articles) carticles) + cgroup carticle article result prefix) + (while carticles + (setq cgroup (caar carticles)) + (setq articles (cdar carticles)) + (pop carticles) (when (and articles (gnus-check-server (gnus-find-method-for-group cgroup) t) @@ -114,37 +119,69 @@ It is computed from the marks of individual component groups.") ;; 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) - (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))))))))) + (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))))))) (defvoo nnvirtual-last-accessed-component-group nil) @@ -335,18 +372,61 @@ It is computed from the marks of individual component groups.") ;;; Internal functions. -(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) - (concat - (format "%s %s:%d " sysname group art-no) - (mapconcat (lambda (bit) - (concat prefix bit)) - bits " "))))) +(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-possibly-change-server (server) (or (not server) diff --git a/lisp/obsolete/nnir.el b/lisp/obsolete/nnir.el index 0b7d1e454c3..147efed0057 100644 --- a/lisp/obsolete/nnir.el +++ b/lisp/obsolete/nnir.el @@ -504,6 +504,7 @@ Add an entry here when adding a new search engine.") ,@(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 -- 2.39.2