diff options
Diffstat (limited to 'lisp/gnus/nnvirtual.el')
| -rw-r--r-- | lisp/gnus/nnvirtual.el | 214 |
1 files changed, 147 insertions, 67 deletions
diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index ba2934351d6..b3b701e4126 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -1,4 +1,4 @@ -;;; nnvirtual.el --- virtual newsgroups access for Gnus +;;; nnvirtual.el --- virtual newsgroups access for Gnus -*- lexical-binding: t; -*- ;; Copyright (C) 1994-2021 Free Software Foundation, Inc. @@ -94,17 +94,22 @@ It is computed from the marks of individual component groups.") (nnoo-define-basics nnvirtual) -(deffoo nnvirtual-retrieve-headers (articles &optional newsgroup - server fetch-old) +(deffoo nnvirtual-retrieve-headers (articles &optional _newsgroup + server _fetch-old) (when (nnvirtual-possibly-change-server server) (with-current-buffer nntp-server-buffer (erase-buffer) (if (stringp (car articles)) 'headers - (let ((carticles (nnvirtual-partition-sequence articles)) + (let ((vbuf (nnheader-set-temp-buffer + (gnus-get-buffer-create " *virtual headers*"))) + (carticles (nnvirtual-partition-sequence articles)) (sysname (system-name)) - cgroup headers all-headers article prefix) - (pcase-dolist (`(,cgroup . ,articles) carticles) + cgroup carticle article result prefix) + (while carticles + (setq cgroup (caar carticles)) + (setq articles (cdar carticles)) + (pop carticles) (when (and articles (gnus-check-server (gnus-find-method-for-group cgroup) t) @@ -114,42 +119,74 @@ It is computed from the marks of individual component groups.") ;; This is probably evil if people have set ;; gnus-use-cache to nil themselves, but I ;; have no way of finding the true value of it. - (let ((gnus-use-cache t) - (gnus-newsgroup-name cgroup) - (gnus-fetch-old-headers nil)) - (setq headers (gnus-fetch-headers articles)))) - (erase-buffer) - ;; Remove all header article numbers from `articles'. - ;; If there's anything left, those are expired or - ;; canceled articles, so we update the component group - ;; below. - (dolist (h headers) - (setq articles (delq (mail-header-number h) articles) - article (nnvirtual-reverse-map-article - cgroup (mail-header-number h))) - ;; Update all the header numbers according to their - ;; reverse mapping, and drop any with no such mapping. - (when article - ;; Do this first, before we re-set the header's - ;; article number. - (nnvirtual-update-xref-header - h cgroup prefix sysname) - (setf (mail-header-number h) article) - (push h all-headers))) - ;; Anything left in articles is expired or canceled. - ;; Could be smart and not tell it about articles already - ;; known? - (when articles - (gnus-group-make-articles-read cgroup articles)))) - - (sort all-headers (lambda (h1 h2) - (< (mail-header-number h1) - (mail-header-number h2))))))))) + (let ((gnus-use-cache t)) + (setq result (gnus-retrieve-headers + articles cgroup nil)))) + (set-buffer nntp-server-buffer) + ;; If we got HEAD headers, we convert them into NOV + ;; headers. This is slow, inefficient and, come to think + ;; of it, downright evil. So sue me. I couldn't be + ;; bothered to write a header parse routine that could + ;; parse a mixed HEAD/NOV buffer. + (when (eq result 'headers) + (nnvirtual-convert-headers)) + (goto-char (point-min)) + (while (not (eobp)) + (delete-region (point) + (progn + (setq carticle (read nntp-server-buffer)) + (point))) + + ;; We remove this article from the articles list, if + ;; anything is left in the articles list after going through + ;; the entire buffer, then those articles have been + ;; expired or canceled, so we appropriately update the + ;; component group below. They should be coming up + ;; generally in order, so this shouldn't be slow. + (setq articles (delq carticle articles)) + + (setq article (nnvirtual-reverse-map-article cgroup carticle)) + (if (null article) + ;; This line has no reverse mapping, that means it + ;; was an extra article reference returned by nntp. + (progn + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point)))) + ;; Otherwise insert the virtual article number, + ;; and clean up the xrefs. + (princ article nntp-server-buffer) + (nnvirtual-update-xref-header cgroup carticle + prefix sysname) + (forward-line 1)) + ) + + (set-buffer vbuf) + (goto-char (point-max)) + (insert-buffer-substring nntp-server-buffer)) + ;; Anything left in articles is expired or canceled. + ;; Could be smart and not tell it about articles already known? + (when articles + (gnus-group-make-articles-read cgroup articles)) + ) + + ;; The headers are ready for reading, so they are inserted into + ;; the nntp-server-buffer, which is where Gnus expects to find + ;; them. + (prog1 + (with-current-buffer nntp-server-buffer + (erase-buffer) + (insert-buffer-substring vbuf) + ;; FIX FIX FIX, we should be able to sort faster than + ;; this if needed, since each cgroup is sorted, we just + ;; need to merge + (sort-numeric-fields 1 (point-min) (point-max)) + 'nov) + (kill-buffer vbuf))))))) (defvoo nnvirtual-last-accessed-component-group nil) -(deffoo nnvirtual-request-article (article &optional group server buffer) +(deffoo nnvirtual-request-article (article &optional _group server buffer) (when (nnvirtual-possibly-change-server server) (if (stringp article) ;; This is a fetch by Message-ID. @@ -213,7 +250,7 @@ It is computed from the marks of individual component groups.") t))) -(deffoo nnvirtual-request-group (group &optional server dont-check info) +(deffoo nnvirtual-request-group (group &optional server dont-check _info) (nnvirtual-possibly-change-server server) (setq nnvirtual-component-groups (delete (nnvirtual-current-group) nnvirtual-component-groups)) @@ -232,7 +269,7 @@ It is computed from the marks of individual component groups.") nnvirtual-mapping-len nnvirtual-mapping-len group)))) -(deffoo nnvirtual-request-type (group &optional article) +(deffoo nnvirtual-request-type (_group &optional article) (if (not article) 'unknown (if (numberp article) @@ -242,7 +279,7 @@ It is computed from the marks of individual component groups.") (gnus-request-type nnvirtual-last-accessed-component-group nil)))) -(deffoo nnvirtual-request-update-mark (group article mark) +(deffoo nnvirtual-request-update-mark (_group article mark) (let* ((nart (nnvirtual-map-article article)) (cgroup (car nart))) (when (and nart @@ -254,22 +291,22 @@ It is computed from the marks of individual component groups.") mark) -(deffoo nnvirtual-close-group (group &optional server) +(deffoo nnvirtual-close-group (_group &optional server) (when (and (nnvirtual-possibly-change-server server) (not (gnus-ephemeral-group-p (nnvirtual-current-group)))) (nnvirtual-update-read-and-marked t t)) t) -(deffoo nnvirtual-request-newgroups (date &optional server) +(deffoo nnvirtual-request-newgroups (_date &optional _server) (nnheader-report 'nnvirtual "NEWGROUPS is not supported.")) -(deffoo nnvirtual-request-list-newsgroups (&optional server) +(deffoo nnvirtual-request-list-newsgroups (&optional _server) (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented.")) -(deffoo nnvirtual-request-update-info (group info &optional server) +(deffoo nnvirtual-request-update-info (_group info &optional server) (when (and (nnvirtual-possibly-change-server server) (not nnvirtual-info-installed)) ;; Install the precomputed lists atomically, so the virtual group @@ -284,7 +321,7 @@ It is computed from the marks of individual component groups.") t)) -(deffoo nnvirtual-catchup-group (group &optional server all) +(deffoo nnvirtual-catchup-group (_group &optional server all) (when (and (nnvirtual-possibly-change-server server) (not (gnus-ephemeral-group-p (nnvirtual-current-group)))) ;; copy over existing marks first, in case they set anything @@ -302,12 +339,12 @@ It is computed from the marks of individual component groups.") (gnus-group-catchup-current nil all))))) -(deffoo nnvirtual-find-group-art (group article) +(deffoo nnvirtual-find-group-art (_group article) "Return the real group and article for virtual GROUP and ARTICLE." (nnvirtual-map-article article)) -(deffoo nnvirtual-request-post (&optional server) +(deffoo nnvirtual-request-post (&optional _server) (if (not gnus-message-group-art) (nnheader-report 'nnvirtual "Can't post to an nnvirtual group") (let ((group (car (nnvirtual-find-group-art @@ -316,8 +353,8 @@ It is computed from the marks of individual component groups.") (gnus-request-post (gnus-find-method-for-group group))))) -(deffoo nnvirtual-request-expire-articles (articles group - &optional server force) +(deffoo nnvirtual-request-expire-articles ( _articles _group + &optional server _force) (nnvirtual-possibly-change-server server) (setq nnvirtual-component-groups (delete (nnvirtual-current-group) nnvirtual-component-groups)) @@ -330,23 +367,66 @@ It is computed from the marks of individual component groups.") group article)) (gnus-uncompress-range (gnus-group-expire-articles-1 group)))))) - (sort (delq nil unexpired) '<))) + (sort (delq nil unexpired) #'<))) ;;; 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) @@ -422,7 +502,7 @@ If UPDATE-P is not nil, call gnus-group-update-group on the components." "Merge many sorted lists of numbers." (if (null (cdr lists)) (car lists) - (sort (apply 'nconc lists) '<))) + (sort (apply #'nconc lists) #'<))) ;; We map between virtual articles and real articles in a manner @@ -568,7 +648,7 @@ numbers has no corresponding component article, then it is left out of the result." (when (numberp (cdr-safe articles)) (setq articles (list articles))) - (let ((carticles (mapcar 'list nnvirtual-component-groups)) + (let ((carticles (mapcar #'list nnvirtual-component-groups)) a i j article entry) (while (setq a (pop articles)) (if (atom a) @@ -670,7 +750,7 @@ based on the marks on the component groups." ;; Now that the mapping tables are generated, we can convert ;; and combine the separate component unreads and marks lists ;; into single lists of virtual article numbers. - (setq unreads (apply 'nnvirtual-merge-sorted-lists + (setq unreads (apply #'nnvirtual-merge-sorted-lists (mapcar (lambda (x) (nnvirtual-reverse-map-sequence (car x) (cdr x))) @@ -680,7 +760,7 @@ based on the marks on the component groups." (cons (cdr type) (gnus-compress-sequence (apply - 'nnvirtual-merge-sorted-lists + #'nnvirtual-merge-sorted-lists (mapcar (lambda (x) (nnvirtual-reverse-map-sequence (car x) |