procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Allow gnus-retrieve-headers to return headers directly

Browse source 
Previously, all Gnus backends returned header information by writing
nov lines into the nntp-server-buffer, which was later parsed.  This
commit allows the backends to return their header information as a
list of already-parsed headers, though so far none of the backends
actually do that.  The agent, cache, cloud etc. now operate on parsed
headers rather than nov text, ie. they use gnus-fetch-headers instead
of gnus-retrieve-headers.

* lisp/gnus/gnus-sum.el (gnus-fetch-headers): Handle the case in which
gnus-retrieve-headers returns headers directly.
* lisp/gnus/nnvirtual.el (nnvirtual-retrieve-headers): Use
gnus-fetch-headers rather than gnus-retrieve-headers to get headers,
meaning we're operating on already-parsed headers.
(nnvirtual-convert-headers): Remove now-unnecessary function.
(nnvirtual-update-xref-header): Rewrite to operate on parsed header.
* lisp/gnus/gnus-cloud.el (gnus-cloud-available-chunks): Use
gnus-fetch-headers instead of gnus-retrieve-headers.
* lisp/gnus/gnus-cache.el (gnus-cache-retrieve-headers): Use
gnus-fetch-headers.
(gnus-cache-braid-nov, gnus-cache-braid-heads): Delete unnecessary
functions -- we now do this work on a list of parsed headers.
* lisp/gnus/gnus-agent.el (gnus-agent-retrieve-headers): Use
gnus-fetch-headers.
(gnus-agent-braid-nov): Remove unnecessary function.
(gnus-agent-fetch-headers): Use gnus-fetch-headers.
This commit is contained in:
Eric Abrahamsen 2020-03-17 20:53:05 -07:00
parent 8f4b3b812a
commit 20add1cd22
8 changed files with 258 additions and 511 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

373
lisp/gnus/gnus-agent.el
View file

@ -1789,6 +1789,7 @@ 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
@ -1810,10 +1811,9 @@ 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))
(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 +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-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 +1867,52 @@ article numbers will be returned."
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)
;; 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 them.
(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)))
(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))
;; 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))
(defsubst gnus-agent-read-article-number ()
"Read the article number at point.
@ -1924,96 +1938,6 @@ 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)
@ -2386,10 +2310,9 @@ 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)
@ -2410,38 +2333,35 @@ 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 '<))
;; 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)
@ -3661,11 +3581,9 @@ has been fetched."
(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)
(file (gnus-agent-article-name ".overview" group))
uncached-articles
(file-name-coding-system nnmail-pathname-coding-system))
(let ((file (gnus-agent-article-name ".overview" group))
(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 +3594,63 @@ has been fetched."
1)
(car (last articles))))))
;; Populate temp buffer with known headers
;; 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.
(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))
(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))))))
(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.
(setq uncached-articles
(gnus-agent-uncached-articles articles group t))
(set-buffer nntp-server-buffer)
(let* ((fetched-articles (list nil))
(tail-fetched-articles fetched-articles)
(min (car articles))
(max (car (last articles))))
(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))))))
;; 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)
;; Add the new set of known headers to the overview 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)
;; 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))
(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)))
(defun gnus-agent-request-article (article group)
"Retrieve ARTICLE in GROUP from the agent cache."

9
lisp/gnus/gnus-async.el
View file

@ -357,8 +357,13 @@ that was fetched."
(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)

126
lisp/gnus/gnus-cache.el
View file

@ -294,49 +294,47 @@ 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))))
(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-retrieve-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)))))
(setq headers (and articles
(gnus-fetch-headers uncached-articles)))))
(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)))))))
;; 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))))
(defun gnus-cache-enter-article (&optional n)
"Enter the next N articles into the cache.
@ -529,70 +527,6 @@ 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.

16
lisp/gnus/gnus-cloud.el
View file

@ -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")
@ -391,8 +393,6 @@ 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,14 +407,10 @@ 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))
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))

65
lisp/gnus/gnus-sum.el
View file

@ -5658,10 +5658,21 @@ 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."
"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
@ -5671,22 +5682,34 @@ or a straight list of 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))
(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))))
(defun gnus-select-newsgroup (group &optional read-all select-articles)
"Select newsgroup GROUP.
@ -6443,6 +6466,10 @@ 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

9
lisp/gnus/gnus.el
View file

@ -2388,7 +2388,14 @@ 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)
(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-article-reply nil)
(defvar gnus-override-method nil)
(defvar gnus-opened-servers nil)

170
lisp/gnus/nnvirtual.el
View file

@ -101,15 +101,10 @@ It is computed from the marks of individual component groups.")
(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)
@ -119,69 +114,37 @@ 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))
(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)))
(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))))
;; 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)))))))
(sort all-headers (lambda (h1 h2)
(< (mail-header-number h1)
(mail-header-number h2)))))))))
(defvoo nnvirtual-last-accessed-component-group nil)
@ -372,61 +335,18 @@ It is computed from the marks of individual component groups.")
;;; 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)
(concat
(format "%s %s:%d " sysname group art-no)
(mapconcat (lambda (bit)
(concat prefix bit))
bits " ")))))
(defun nnvirtual-possibly-change-server (server)
(or (not server)

1
lisp/obsolete/nnir.el
View file

@ -504,7 +504,6 @@ 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