From: Eric Abrahamsen <eric@ericabrahamsen.net>
To: Lars Ingebrigtsen <larsi@gnus.org>
Cc: 38011@debbugs.gnu.org
Subject: bug#38011: 27.0.50; [PATCH] WIP on allowing Gnus backends to return header data directly
Date: Fri, 01 Jan 2021 19:18:20 -0800 [thread overview]
Message-ID: <87zh1sowlf.fsf@ericabrahamsen.net> (raw)
In-Reply-To: <87h7rikcsq.fsf@ericabrahamsen.net> (Eric Abrahamsen's message of "Sun, 27 Sep 2020 16:41:41 -0700")
[-- Attachment #1: Type: text/plain, Size: 2740 bytes --]
Eric Abrahamsen <eric@ericabrahamsen.net> writes:
> Lars Ingebrigtsen <larsi@gnus.org> writes:
>
>> Eric Abrahamsen <eric@ericabrahamsen.net> writes:
>>
>>>> Xref: reader01.eternal-september.org foo.bar:2523 gnu.emacs.help:57603 zot.bar:3242
>>
>> [...]
>>
>>> Slowly, slowly, I'm getting this done. I'm still a bit confused here,
>>> though. The xref elements look like they're not supposed to have spaces
>>> in them, but the existing code does this:
>>>
>>> (insert "Xref: " sysname " " group ":")
>>> (princ article (current-buffer))
>>>
>>> Which leaves a space between sysname and group.
>>
>> I'm not quite sure I understand the question? The sysname is just a
>> part of the syntax of the Xref header and isn't used for anything by
>> Gnus, as far as I know. So there has to be a space? It's certainly not
>> part of the group name.
>
> TBH I only just went and read the RFC for this -- something I'd been
> trying to avoid!
>
>>> You say the existing xrefs should be left as they are, but the code adds
>>> "prefix" to them. Should this be added unconditionally?
>>
>> Uhm... I think so? But I'm not sure.
>
> Looking over the code again, I think it's best to only add if the prefix
> isn't already there.
>
>>> Here's the new version of the function, operating on a header struct.
>>> Does this look right to you?
>>>
>>> Thanks,
>>> Eric
>>>
>>> (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)))
>>> (setq bits
>>> (mapcar (lambda (bit)
>>> (concat prefix bit))
>>> bits))
>>> (setf (mail-header-xref header)
>>> (mapconcat #'identity
>>> (cons (format "%s %s:%d"
>>> sysname group art-no)
>>> bits)
>>> " "))))
>>
>> I think so. The body of the let form is perhaps more easily expressed
>> as
>>
>> (setf (mail-header-xref header)
>> (concat (format "%s %s:%d " sysname group art-no)
>> (mapconcat (lambda (bit)
>> (concat prefix bit))
>> bits " ")))
>>
>> ?
>
> Sure, this was just my halfway-there muddle.
>
> I've cleaned this branch, squashed it, and am preparing to test for a
> while. I'm attaching the full diff in case anyone wants to read it :)
>
> A net removal of 562 lines with, I hope, no change in behavior.
I revisit this every few months, and have to completely relearn all the
code each time. With any luck that means that I've looked over these
diffs sufficiently to have caught more bugs.
At any rate, I think this is finally ready to go.
Eric
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Allow-gnus-retrieve-headers-to-return-headers-direct.patch --]
[-- Type: text/x-patch, Size: 40521 bytes --]
From 0aaf6030b95a6da74fb7f78344ddbc03d12dee94 Mon Sep 17 00:00:00 2001
From: Eric Abrahamsen <eric@ericabrahamsen.net>
Date: Tue, 17 Mar 2020 20:53:05 -0700
Subject: [PATCH] Allow gnus-retrieve-headers to return headers directly
---
lisp/gnus/gnus-agent.el | 385 +++++++++++++---------------------------
lisp/gnus/gnus-async.el | 9 +-
lisp/gnus/gnus-cache.el | 132 ++++----------
lisp/gnus/gnus-cloud.el | 14 +-
lisp/gnus/gnus-sum.el | 70 ++++++--
lisp/gnus/gnus.el | 9 +-
lisp/gnus/nnvirtual.el | 172 +++++-------------
lisp/obsolete/nnir.el | 1 -
8 files changed, 273 insertions(+), 519 deletions(-)
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el
index 56640ea830..514e7bf293 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 ()
"Read the article number at point.
@@ -1924,96 +1934,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)
@@ -2386,10 +2306,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)
@@ -2410,38 +2329,35 @@ 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)
@@ -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,61 @@ gnus-agent-retrieve-headers
1)
(car (last articles))))))
- ;; 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)))))
-
- (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)
+ ;; 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.
+ (if (file-exists-p file)
+ (with-current-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 ((nnheader-file-coding-system
+ gnus-agent-file-coding-system))
+ (nnheader-insert-nov-file file (car articles))
+ (goto-char (point-min))
+ ;; We're assuming both ARTICLES and the overview buffer
+ ;; are sorted in ascending order.
+ (dolist (art-no articles)
+ (if (re-search-forward
+ (format "^%d\\>" art-no)
+ (point-max) t)
+ (progn
+ (beginning-of-line)
+ (push (nnheader-parse-nov) headers)
+ (forward-line))
+ (push art-no uncached-articles)))
+ (setq headers (nreverse headers))))
+ (setq uncached-articles 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 fetched-headers)
+ (lambda (l r)
+ (< (mail-header-number l)
+ (mail-header-number r))))))
+
+ ;; 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
+ (goto-char (point-max))
+ (mapc #'nnheader-insert-nov fetched-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)))
+ 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 fefd02c7bf..ed948a26c0 100644
--- a/lisp/gnus/gnus-async.el
+++ b/lisp/gnus/gnus-async.el
@@ -357,8 +357,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 36657e4621..d46eb39ace 100644
--- a/lisp/gnus/gnus-cache.el
+++ b/lisp/gnus/gnus-cache.el
@@ -294,49 +294,51 @@ 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-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)))))
- (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 (and headers gnus-cache-buffer)
+ (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))
+ (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 +531,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 f7c71f43ce..8d1d0c6f65 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 b0f9ed4c6f..f9851726bf 100644
--- a/lisp/gnus/gnus-sum.el
+++ b/lisp/gnus/gnus-sum.el
@@ -4590,6 +4590,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)))
@@ -5658,10 +5663,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
@@ -5671,22 +5687,34 @@ 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))
+ (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 +6471,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 3b172db211..b00f66b1d4 100644
--- a/lisp/gnus/gnus.el
+++ b/lisp/gnus/gnus.el
@@ -2388,7 +2388,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/nnvirtual.el b/lisp/gnus/nnvirtual.el
index 1e2feda636..c17ac02380 100644
--- a/lisp/gnus/nnvirtual.el
+++ b/lisp/gnus/nnvirtual.el
@@ -101,15 +101,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)
@@ -119,69 +114,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)
@@ -372,61 +335,18 @@ nnvirtual-request-expire-articles
\f
;;; 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 (mapcar (lambda (bit)
+ (concat prefix bit))
+ bits " "))))))
(defun nnvirtual-possibly-change-server (server)
(or (not server)
diff --git a/lisp/obsolete/nnir.el b/lisp/obsolete/nnir.el
index 147efed005..0b7d1e454c 100644
--- a/lisp/obsolete/nnir.el
+++ b/lisp/obsolete/nnir.el
@@ -504,7 +504,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
--
2.30.0
next prev parent reply other threads:[~2021-01-02 3:18 UTC|newest]
Thread overview: 29+ messages / expand[flat|nested] mbox.gz Atom feed top
2019-10-31 21:34 bug#38011: 27.0.50; [PATCH] WIP on allowing Gnus backends to return header data directly Eric Abrahamsen
2019-11-01 14:12 ` Lars Ingebrigtsen
2019-11-01 18:41 ` Eric Abrahamsen
2019-11-01 20:52 ` Eric Abrahamsen
2019-11-02 14:49 ` Lars Ingebrigtsen
2019-11-07 23:21 ` Eric Abrahamsen
2019-11-08 21:03 ` Lars Ingebrigtsen
2019-11-08 21:43 ` Eric Abrahamsen
2019-11-08 21:58 ` Lars Ingebrigtsen
2020-03-29 19:50 ` Eric Abrahamsen
2020-04-30 4:50 ` Lars Ingebrigtsen
2020-09-27 4:13 ` Eric Abrahamsen
2020-09-27 12:16 ` Lars Ingebrigtsen
2020-09-27 23:41 ` Eric Abrahamsen
2021-01-02 3:18 ` Eric Abrahamsen [this message]
2021-01-02 5:59 ` Lars Ingebrigtsen
2021-01-02 20:49 ` Eric Abrahamsen
2021-01-03 7:45 ` Lars Ingebrigtsen
2021-01-03 19:53 ` Eric Abrahamsen
2021-01-04 9:05 ` Lars Ingebrigtsen
2021-01-04 18:09 ` Eric Abrahamsen
2021-01-05 8:47 ` Lars Ingebrigtsen
2021-01-05 17:02 ` Eric Abrahamsen
2021-01-17 5:00 ` Eric Abrahamsen
2021-01-18 10:48 ` Robert Pluim
2021-01-18 21:12 ` Eric Abrahamsen
2021-01-18 16:37 ` Lars Ingebrigtsen
2021-01-03 19:54 ` Eric Abrahamsen
2021-01-03 21:38 ` Eric Abrahamsen
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87zh1sowlf.fsf@ericabrahamsen.net \
--to=eric@ericabrahamsen.net \
--cc=38011@debbugs.gnu.org \
--cc=larsi@gnus.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).