. 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
(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
(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
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.
(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)
(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)
(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)
(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))
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."
(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)
(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.
(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.
(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")
(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))
(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))
(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
(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.
(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
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)
(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)
;; 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)
\f
;;; 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)
,@(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
projects / emacs.git / commitdiff