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

Introduce nnselect backend for gnus

Browse source 
This new backend allows gnus to handle arbitrary sets of messages
spanning multiple groups, even when these groups are from different
backends and different servers. All gnus glue is removed from
nnir (leaving only the backend search functions) and gnus
search-related processing is done through nnselect. In appropriate
places 'nnir' has been replaced by 'nnselect' or 'search'.

* etc/NEWS: Document the change.
* doc/misc/gnus.texi: New  documentation for nnselect and update
searching and thread-referral  sections.
* lisp/gnus/nnselect.el: New file.
* lisp/gnus/nnir.el: Remove all gnus glue, leaving only searching
capability. Improve documentation strings.
* lisp/gnus/gnus-group.el (gnus-group-read-ephemeral-search-group,
gnus-group-make-search-group): New functions.
* lisp/gnus/gnus-msg.el (gnus-setup-message, gnus-group-news,
gnus-summary-news-other-window): Update to work for nnselect. Fix
gnus-newsgroup-name wrangling.
*lisp/gnus/gnus-registry.el
(gnus-registry-action,gnus-registry-ignore-group-p): Make work from nnselect.
* lisp/gnus/nnheader.el (nnheader-parse-head, nnheader-parse-nov):
Rework and consolidate header parsing.
* lisp/gnus/gnus-agent.el (gnus-agent-regenerate-group):
* lisp/gnus/gnus-cache.el (gnus-possibly-enter-article):
* lisp/gnus/gnus-cloud.el (gnus-cloud-available-chunks):
* lisp/gnus/gnus-msg.el (gnus-inews-yank-articles):
* lisp/gnus/gnus-sum. (gnus-get-newsgroup-headers):
* lisp/gnus/nndiary.el (nndiary-parse-head):
* lisp/gnus/nnfolder.el (nnfolder-parse-head):
* lisp/gnus/nnmaildir.el (nnmaildir--update-nov):
* lisp/gnus/nnml.el (nnml-parse-head):
* lisp/gnus/nnspool.el (nnspool-insert-nov-head):
Use new header parsing.
* lisp/gnus/gnus-start.el (gnus-read-active-for-groups): Rescan on
activation by default.
* lisp/gnus/gnus-sum.el (gnus-summary-line-format-alist): New specs
for virtual groups.
(gnus-article-sort-by-rsv, gnus-thread-sort-by-rsv):  New functions to
allow sorting by search RSV.
This commit is contained in:
Andrew G Cohen 2020-09-05 08:46:43 +08:00
parent f450798cb0
commit ecfc13e416
21 changed files with 1650 additions and 1221 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

257
doc/misc/gnus.texi
View file

@ -641,7 +641,7 @@ Select Methods
* Getting Mail:: Reading your personal mail with Gnus.
* Browsing the Web:: Getting messages from a plethora of Web sources.
* Other Sources:: Reading directories, files.
* Combined Groups:: Combining groups into one group.
* Virtual Groups:: Combining articles from multiple sources.
* Email Based Diary:: Using mails to manage diary events in Gnus.
* Gnus Unplugged:: Reading news and mail offline.
@ -716,9 +716,10 @@ Document Groups
* Document Server Internals:: How to add your own document types.
Combined Groups
Virtual Groups
* Virtual Groups:: Combining articles from many groups.
* Selection Groups:: Articles selected from many places.
* Combined Groups:: Combining multiple groups.
Email Based Diary
@ -10407,12 +10408,20 @@ article (@code{gnus-summary-refer-references}).
@findex gnus-summary-refer-thread
@kindex A T @r{(Summary)}
Display the full thread where the current article appears
(@code{gnus-summary-refer-thread}). This command has to fetch all the
headers in the current group to work, so it usually takes a while. If
you do it often, you may consider setting @code{gnus-fetch-old-headers}
to @code{invisible} (@pxref{Filling In Threads}). This won't have any
visible effects normally, but it'll make this command work a whole lot
faster. Of course, it'll make group entry somewhat slow.
(@code{gnus-summary-refer-thread}). By default this command looks for
articles only in the current group. Some backends (currently only
'nnimap) know how to find articles in the thread directly. In other
cases each header in the current group must be fetched and examined,
so it usually takes a while. If you do it often, you may consider
setting @code{gnus-fetch-old-headers} to @code{invisible}
(@pxref{Filling In Threads}). This won't have any visible effects
normally, but it'll make this command work a whole lot faster. Of
course, it'll make group entry somewhat slow.
@vindex gnus-refer-thread-use-search
If @code{gnus-refer-thread-use-search} is non-nil then those backends
that know how to find threads directly will search not just in the
current group but all groups on the same server.
@vindex gnus-refer-thread-limit
The @code{gnus-refer-thread-limit} variable says how many old (i.e.,
@ -10421,6 +10430,15 @@ fetch when doing this command. The default is 200. If @code{t}, all
the available headers will be fetched. This variable can be overridden
by giving the @kbd{A T} command a numerical prefix.
@vindex gnus-refer-thread-limit-to-thread
In most cases @code{gnus-refer-thread} adds any articles it finds to
the current summary buffer. (When @code{gnus-refer-thread-use-search}
is true and the initial referral starts from a summary buffer for a
non-virtual group this may not be possible. In this case a new summary
buffer is created holding a virtual group with the result of the thread
search). If @code{gnus-refer-thread-limit-to-thread} is non-nil then
the summary buffer will be limited to articles in the thread.
@item M-^ (Summary)
@findex gnus-summary-refer-article
@kindex M-^ @r{(Summary)}
@ -13262,7 +13280,7 @@ The different methods all have their peculiarities, of course.
* Getting Mail:: Reading your personal mail with Gnus.
* Browsing the Web:: Getting messages from a plethora of Web sources.
* Other Sources:: Reading directories, files.
* Combined Groups:: Combining groups into one group.
* Virtual Groups:: Combining articles and groups together.
* Email Based Diary:: Using mails to manage diary events in Gnus.
* Gnus Unplugged:: Reading news and mail offline.
@end menu
@ -17834,19 +17852,133 @@ methods, but want to only use secondary ones:
@end lisp
@node Combined Groups
@section Combined Groups
@node Virtual Groups
@section Virtual Groups
Gnus allows combining a mixture of all the other group types into bigger
groups.
Gnus allows combining articles from many sources, and combinations of
whole groups together into virtual groups.
@menu
* Virtual Groups:: Combining articles from many groups.
* Selection Groups:: Combining articles from many groups.
* Combined Groups:: Combining multiple groups.
@end menu
@node Virtual Groups
@subsection Virtual Groups
@node Selection Groups
@subsection Select Groups
@cindex nnselect
@cindex select groups
@cindex selecting articles
Gnus provides the @dfn{nnselect} method for creating virtual groups
composed of collections of messages, even when these messages come
from groups that span multiple servers and backends. For the most part
these virtual groups behave like any other group: messages may be
threaded, marked, moved, deleted, copied, etc.; groups may be
ephemeral or persistent; groups may be created via
@code{gnus-group-make-group} or browsed as foreign via
@code{gnus-group-browse-foreign-server}.
The key to using an nnselect group is specifying the messages to
include. Each nnselect group has a group parameter
@code{nnselect-specs} which is an alist with two elements: a function
@code{nnselect-function}; and arguments @code{nnselect-args} to be
passed to the function, if any.
The function @code{nnselect-function} must return a vector. Each
element of this vector is in turn a 3-element vector corresponding to
one message. The 3 elements are: the fully-qualified group name; the
message number; and a "score" that can be used for additional
sorting. The values for the score are arbitrary, and are not used
directly by the nnselect method---they may, for example, all be set to
100.
Here is an example:
@lisp
(nnselect-specs
(nnselect-function . identity)
(nnselect-args .
[["nnimap+work:mail" 595 100]
["nnimap+home:sent" 223 100]
["nntp+news.gmane.org:gmane.emacs.gnus.general" 23666 100]]))
@end lisp
The function is the identity and the argument is just the list of
messages to include in the virtual group.
Or we may wish to create a group from the results of a search query:
@lisp
(nnselect-specs
(nnselect-function . nnir-run-query)
(nnselect-args
(nnir-query-spec
(query . "FLAGGED")
(criteria . ""))
(nnir-group-spec
("nnimap:home")
("nnimap:work"))))
@end lisp
This creates a group including all flagged messages from all groups on
two imap servers, "home" and "work".
And one last example. Here is a function that runs a search query to
find all message that have been received recently from certain groups:
@lisp
(defun my-recent-email (args)
(let ((query-spec
(list
(cons 'query
(format-time-string "SENTSINCE %d-%b-%Y"
(time-subtract (current-time)
(days-to-time (car args)))))
(cons 'criteria "")))
(group-spec (cadr args)))
(nnir-run-query (cons 'nnir-specs
(list (cons 'nnir-query-spec query-spec)
(cons 'nnir-group-spec group-spec))))))
@end lisp
Then an nnselect-specs
@lisp
(nnselect-specs
(nnselect-function . my-recent-email)
(nnselect-args . (7 (("nnimap:home") ("nnimap:work")))))
@end lisp
will provide a group composed of all messages on the home and work
servers received in the last 7 days.
Refreshing the selection of an nnselect group by running the
@code{nnselect-function} may take a long time to
complete. Consequently nnselect groups are not refreshed by default
when @code{gnus-group-get-new-news} is invoked. In those cases where
running the function is not too time-consuming, a non-nil group
parameter of @code{nnselect-rescan} will allow automatic refreshing. A
refresh can always be invoked manually through
@code{gnus-group-get-new-news-this-group}.
The nnir interface (@pxref{nnir}) includes engines for searching a
variety of backends. While the details of each search engine vary, the
result of an nnir search is always a vector of the sort used by the
nnselect method, and the results of nnir queries are usually viewed
using an nnselect group. Indeed the standard search function
@code{gnus-group-read-ephemeral-search-group} just creates an
ephemeral nnselect group with the appropriate nnir query as the
@code{nnselect-specs}. nnir originally included both the search
engines and the glue to connect search results to gnus. Over time this
glue evolved into the nnselect method. The two had
a mostly amicable parting so that nnselect could pursue its dream of
becoming a fully functioning backend, but occasional conflicts may
still linger.
@node Combined Groups
@subsection Combined Groups
@cindex nnvirtual
@cindex virtual groups
@cindex merging groups
@ -21238,14 +21370,26 @@ four days, Gnus will decay the scores four times, for instance.
@chapter Searching
@cindex searching
FIXME: Add a brief overview of Gnus search capabilities. A brief
comparison of nnir, nnmairix, contrib/gnus-namazu would be nice
as well.
FIXME: A brief comparison of nnir, nnmairix, contrib/gnus-namazu would
be nice.
This chapter describes tools for searching groups and servers for
articles matching a query and then retrieving those articles. Gnus
provides a simpler mechanism for searching through articles in a summary buffer
to find those matching a pattern. @xref{Searching for Articles}.
Gnus has various ways of finding articles that match certain criteria
(from a particular author, on a certain subject, etc). The simplest
method is to enter a group and then either "limit" the summary buffer
to the desired articles using the limiting commands (@xref{Limiting}),
or searching through messages in the summary buffer (@xref{Searching
for Articles}).
Limiting commands and summary buffer searching work on subsets of the
articles already fetched from the servers, and these commands won’t
query the server for additional articles. While simple, these methods
are therefore inadequate if the desired articles span multiple groups,
or if the group is so large that fetching all articles is
impractical. Many backends (such as imap, notmuch, namazu, etc.)
provide their own facilities to search for articles directly on the
server and gnus can take advantage of these methods. This chapter
describes tools for searching groups and servers for articles matching
a query.
@menu
* nnir:: Searching with various engines.
@ -21275,7 +21419,7 @@ through mail and news repositories. Different backends (like
interface.
The @code{nnimap} search engine should work with no configuration.
Other engines require a local index that needs to be created and
Other engines may require a local index that needs to be created and
maintained outside of Gnus.
@ -21283,23 +21427,19 @@ maintained outside of Gnus.
@subsection Basic Usage
In the group buffer typing @kbd{G G} will search the group on the
current line by calling @code{gnus-group-make-nnir-group}. This prompts
for a query string, creates an ephemeral @code{nnir} group containing
current line by calling @code{gnus-group-make-search-group}. This prompts
for a query string, creates an ephemeral @code{nnselect} group containing
the articles that match this query, and takes you to a summary buffer
showing these articles. Articles may then be read, moved and deleted
using the usual commands.
The @code{nnir} group made in this way is an @code{ephemeral} group,
and some changes are not permanent: aside from reading, moving, and
deleting, you can't act on the original article. But there is an
alternative: you can @emph{warp} (i.e., jump) to the original group
for the article on the current line with @kbd{A W}, aka
@code{gnus-warp-to-article}. Even better, the function
@code{gnus-summary-refer-thread}, bound by default in summary buffers
to @kbd{A T}, will first warp to the original group before it works
its magic and includes all the articles in the thread. From here you
can read, move and delete articles, but also copy them, alter article
marks, whatever. Go nuts.
The @code{nnselect} group made in this way is an @code{ephemeral}
group, and will disappear upon exit from the group. However changes
made in the group are permanently reflected in the real groups from
which the articles are drawn. It is occasionally convenient to view
articles found through searching in their original group. You can
@emph{warp} (i.e., jump) to the original group for the article on the
current line with @kbd{A W}, aka @code{gnus-warp-to-article}.
You say you want to search more than just the group on the current line?
No problem: just process-mark the groups you want to search. You want
@ -21307,14 +21447,14 @@ even more? Calling for an nnir search with the cursor on a topic heading
will search all the groups under that heading.
Still not enough? OK, in the server buffer
@code{gnus-group-make-nnir-group} (now bound to @kbd{G}) will search all
groups from the server on the current line. Too much? Want to ignore
certain groups when searching, like spam groups? Just customize
@code{nnir-ignored-newsgroups}.
@code{gnus-group-make-search-group} (now bound to @kbd{G}) will search
all groups from the server on the current line. Too much? Want to
ignore certain groups when searching, like spam groups? Just
customize @code{nnir-ignored-newsgroups}.
One more thing: individual search engines may have special search
features. You can access these special features by giving a prefix-arg
to @code{gnus-group-make-nnir-group}. If you are searching multiple
to @code{gnus-group-make-search-group}. If you are searching multiple
groups with different search engines you will be prompted for the
special search features for each engine separately.
@ -21371,8 +21511,7 @@ variable is set to use the @code{imap} engine for all servers using the
your servers with an @code{nnimap} backend you could change this to
@lisp
'((nnimap . namazu)
(nntp . gmane))
'((nnimap . namazu))
@end lisp
@node The imap Engine
@ -21575,7 +21714,7 @@ This engine is obsolete.
@item nnir-method-default-engines
Alist of pairs of server backends and search engines. The default
associations are
association is
@example
(nnimap . imap)
@end example
@ -21584,32 +21723,6 @@ associations are
A regexp to match newsgroups in the active file that should be skipped
when searching all groups on a server.
@item nnir-summary-line-format
The format specification to be used for lines in an nnir summary buffer.
All the items from @code{gnus-summary-line-format} are available, along with
three items unique to nnir summary buffers:
@example
%Z Search retrieval score value (integer)
%G Article original full group name (string)
%g Article original short group name (string)
@end example
If @code{nil} (the default) this will use @code{gnus-summary-line-format}.
@item nnir-retrieve-headers-override-function
If non-@code{nil}, a function that retrieves article headers rather than using
the gnus built-in function. This function takes an article list and
group as arguments and populates the @code{nntp-server-buffer} with the
retrieved headers. It should then return either 'nov or 'headers
indicating the retrieved header format. Failure to retrieve headers
should return @code{nil}.
If this variable is @code{nil}, or if the provided function returns
@code{nil} for a search result, @code{gnus-retrieve-headers} will be
called instead."
@end table

19
etc/NEWS
View file

@ -317,7 +317,24 @@ tags to be considered as well.
** Gnus
+++
*** New user option 'gnus-dbus-close-on-sleep'.
*** New backend 'nnselect'
The newly added nnselect backend allows creating groups from an
arbitrary list of articles that may come from multiple groups and
servers. These groups generally behave like any other group: they may
be ephemeral or persistent, and allow article marking, moving,
deletion, etc. Nnselect groups may be created like any other group,
but there is also a convenience function for the common case of
obtaining the list of articles as a result of a search:
'gnus-group-make-search-group' (G g) that will prompt for an nnir
search query and create a dedicated group for that search. As part of
this addition, the variable 'nnir-summary-line-format' has been
removed; it's functionality is now available directly in the
'gnus-summary-line-format' 'G' and 'g' specs. The variable
'gnus-refer-thread-use-nnir' has been renamed
'gnus-refer-thread-use-search'.
+++
*** New user option 'gnus-dbus-close-on-sleep'
On systems with D-Bus support, it is now possible to register a signal
to close all Gnus servers before the system sleeps.

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

@ -3934,7 +3934,7 @@ If REREAD is not nil, downloaded articles are marked as unread."
(mm-with-unibyte-buffer
(nnheader-insert-file-contents file)
(nnheader-remove-body)
(setq header (nnheader-parse-naked-head)))
(setq header (nnheader-parse-head t)))
(setf (mail-header-number header) (car downloaded))
(if nov-arts
(let ((key (concat "^" (int-to-string (car nov-arts))

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

@ -186,7 +186,7 @@ it's not cached."
(gnus-cache-update-file-total-fetched-for group file))
(setq lines-chars (nnheader-get-lines-and-char))
(nnheader-remove-body)
(setq headers (nnheader-parse-naked-head))
(setq headers (nnheader-parse-head t))
(setf (mail-header-number headers) number)
(setf (mail-header-lines headers) (car lines-chars))
(setf (mail-header-chars headers) (cadr lines-chars))

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

@ -391,6 +391,8 @@ When FULL is t, upload everything, not just a difference from the last full."
(gnus-group-refresh-group group))
(gnus-error 2 "Failed to upload Gnus Cloud data to %s" group)))))
(defvar gnus-alter-header-function)
(defun gnus-cloud-add-timestamps (elems)
(dolist (elem elems)
(let* ((file-name (plist-get elem :file-name))
@ -409,9 +411,11 @@ When FULL is t, upload everything, not just a difference from the last full."
(when (gnus-retrieve-headers (gnus-uncompress-range active) group)
(with-current-buffer nntp-server-buffer
(goto-char (point-min))
(while (and (not (eobp))
(setq head (nnheader-parse-head)))
(push head headers))))
(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))

54
lisp/gnus/gnus-group.el
View file

@ -49,8 +49,6 @@
(autoload 'gnus-agent-total-fetched-for "gnus-agent")
(autoload 'gnus-cache-total-fetched-for "gnus-cache")
(autoload 'gnus-group-make-nnir-group "nnir")
(autoload 'gnus-cloud-upload-all-data "gnus-cloud")
(autoload 'gnus-cloud-download-all-data "gnus-cloud")
@ -663,7 +661,8 @@ simple manner."
"D" gnus-group-enter-directory
"f" gnus-group-make-doc-group
"w" gnus-group-make-web-group
"G" gnus-group-make-nnir-group
"G" gnus-group-read-ephemeral-search-group
"g" gnus-group-make-search-group
"M" gnus-group-read-ephemeral-group
"r" gnus-group-rename-group
"R" gnus-group-make-rss-group
@ -909,7 +908,8 @@ simple manner."
["Add the help group" gnus-group-make-help-group t]
["Make a doc group..." gnus-group-make-doc-group t]
["Make a web group..." gnus-group-make-web-group t]
["Make a search group..." gnus-group-make-nnir-group t]
["Read a search group..." gnus-group-read-ephemeral-search-group t]
["Make a search group..." gnus-group-make-search-group t]
["Make a virtual group..." gnus-group-make-empty-virtual t]
["Add a group to a virtual..." gnus-group-add-to-virtual t]
["Make an ephemeral group..." gnus-group-read-ephemeral-group t]
@ -3166,6 +3166,52 @@ mail messages or news articles in files that have numeric names."
(gnus-group-real-name group)
(list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir)))))
(autoload 'nnir-make-specs "nnir")
(autoload 'gnus-group-topic-name "gnus-topic")
;; Temporary to make group creation easier
(defun gnus-group-make-search-group (nnir-extra-parms &optional specs)
(interactive "P")
(let ((name (gnus-read-group "Group name: ")))
(with-current-buffer gnus-group-buffer
(gnus-group-make-group
name
(list 'nnselect "nnselect")
nil
(list
(cons 'nnselect-specs
(list
(cons 'nnselect-function 'nnir-run-query)
(cons 'nnselect-args
(nnir-make-specs nnir-extra-parms specs)))))))))
(defun gnus-group-read-ephemeral-search-group (nnir-extra-parms &optional specs)
"Create an nnselect group based on a search. Prompt for a
search query and determine the groups to search as follows: if
called from the *Server* buffer search all groups belonging to
the server on the current line; if called from the *Group* buffer
search any marked groups, or the group on the current line, or
all the groups under the current topic. Calling with a prefix-arg
prompts for additional search-engine specific constraints. A
non-nil `specs' arg must be an alist with `nnir-query-spec' and
`nnir-group-spec' keys, and skips all prompting."
(interactive "P")
(gnus-group-read-ephemeral-group
(concat "nnselect-" (message-unique-id))
(list 'nnselect "nnselect")
nil
(cons (current-buffer) gnus-current-window-configuration)
; nil
nil nil
(list
(cons 'nnselect-specs
(list
(cons 'nnselect-function 'nnir-run-query)
(cons 'nnselect-args
(nnir-make-specs nnir-extra-parms specs))))
(cons 'nnselect-artlist nil))))
(defun gnus-group-add-to-virtual (n vgroup)
"Add the current group to a virtual group."
(interactive

120
lisp/gnus/gnus-msg.el
View file

@ -393,10 +393,9 @@ only affect the Gcc copy, but not the original message."
(gnus-inews-make-draft-meta-information
,gnus-newsgroup-name ',articles)))
(autoload 'nnir-article-number "nnir" nil nil 'macro)
(autoload 'nnir-article-group "nnir" nil nil 'macro)
(autoload 'gnus-nnir-group-p "nnir")
(autoload 'nnselect-article-number "nnselect" nil nil 'macro)
(autoload 'nnselect-article-group "nnselect" nil nil 'macro)
(autoload 'gnus-nnselect-group-p "nnselect")
(defvar gnus-article-reply nil)
(defmacro gnus-setup-message (config &rest forms)
@ -404,22 +403,24 @@ only affect the Gcc copy, but not the original message."
(winconf-name (make-symbol "gnus-setup-message-winconf-name"))
(buffer (make-symbol "gnus-setup-message-buffer"))
(article (make-symbol "gnus-setup-message-article"))
(oarticle (make-symbol "gnus-setup-message-oarticle"))
(yanked (make-symbol "gnus-setup-yanked-articles"))
(group (make-symbol "gnus-setup-message-group")))
`(let ((,winconf (current-window-configuration))
(,winconf-name gnus-current-window-configuration)
(,buffer (buffer-name (current-buffer)))
(,article (if (and (gnus-nnir-group-p gnus-newsgroup-name)
gnus-article-reply)
(nnir-article-number (or (car-safe gnus-article-reply)
gnus-article-reply))
gnus-article-reply))
(,article (when gnus-article-reply
(or (nnselect-article-number
(or (car-safe gnus-article-reply)
gnus-article-reply))
gnus-article-reply)))
(,oarticle gnus-article-reply)
(,yanked gnus-article-yanked-articles)
(,group (if (and (gnus-nnir-group-p gnus-newsgroup-name)
gnus-article-reply)
(nnir-article-group (or (car-safe gnus-article-reply)
gnus-article-reply))
gnus-newsgroup-name))
(,group (when gnus-article-reply
(or (nnselect-article-group
(or (car-safe gnus-article-reply)
gnus-article-reply))
gnus-newsgroup-name)))
(message-header-setup-hook
(copy-sequence message-header-setup-hook))
(mbl mml-buffer-list)
@ -460,24 +461,23 @@ only affect the Gcc copy, but not the original message."
(unwind-protect
(progn
,@forms)
(gnus-inews-add-send-actions ,winconf ,buffer ,article ,config
(gnus-inews-add-send-actions ,winconf ,buffer ,oarticle ,config
,yanked ,winconf-name)
(setq gnus-message-buffer (current-buffer))
(set (make-local-variable 'gnus-message-group-art)
(cons ,group ,article))
(set (make-local-variable 'gnus-newsgroup-name) ,group)
;; Enable highlighting of different citation levels
(when gnus-message-highlight-citation
(gnus-message-citation-mode 1))
(gnus-run-hooks 'gnus-message-setup-hook)
(if (eq major-mode 'message-mode)
(let ((mbl1 mml-buffer-list))
(setq mml-buffer-list mbl) ;; Global value
(set (make-local-variable 'mml-buffer-list) mbl1);; Local value
(add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t)
(add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
(mml-destroy-buffers)
(setq mml-buffer-list mbl)))
;; Enable highlighting of different citation levels
(when gnus-message-highlight-citation
(gnus-message-citation-mode 1))
(gnus-run-hooks 'gnus-message-setup-hook)
(if (eq major-mode 'message-mode)
(let ((mbl1 mml-buffer-list))
(setq mml-buffer-list mbl) ;; Global value
(set (make-local-variable 'mml-buffer-list) mbl1);; Local value
(add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t)
(add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
(mml-destroy-buffers)
(setq mml-buffer-list mbl)))
(message-hide-headers)
(gnus-add-buffer)
(gnus-configure-windows ,config t)
@ -521,12 +521,10 @@ instead."
mail-buf)
(unwind-protect
(progn
(setq gnus-newsgroup-name "")
(let ((gnus-newsgroup-name ""))
(gnus-setup-message 'message
(message-mail to subject other-headers continue
nil yank-action send-actions return-action)))
(with-current-buffer buf
(setq gnus-newsgroup-name group-name)))
nil yank-action send-actions return-action)))))
(when switch-action
(setq mail-buf (current-buffer))
(switch-to-buffer buf)
@ -617,18 +615,15 @@ If ARG is 1, prompt for a group name to find the posting style."
(buffer (current-buffer)))
(unwind-protect
(progn
(setq gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(gnus-group-completing-read
"Use posting style of group"
nil (gnus-read-active-file-p))
(gnus-group-group-name))
""))
;; #### see comment in gnus-setup-message -- drv
(gnus-setup-message 'message (message-mail)))
(with-current-buffer buffer
(setq gnus-newsgroup-name group)))))
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(gnus-group-completing-read
"Use posting style of group"
nil (gnus-read-active-file-p))
(gnus-group-group-name))
"")))
(gnus-setup-message 'message (message-mail)))))))
(defun gnus-group-news (&optional arg)
"Start composing a news.
@ -647,19 +642,16 @@ network. The corresponding back end must have a `request-post' method."
(buffer (current-buffer)))
(unwind-protect
(progn
(setq gnus-newsgroup-name
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(gnus-group-completing-read "Use group"
nil
(gnus-read-active-file-p))
(gnus-group-group-name))
""))
;; #### see comment in gnus-setup-message -- drv
"")))
(gnus-setup-message 'message
(message-news (gnus-group-real-name gnus-newsgroup-name))))
(with-current-buffer buffer
(setq gnus-newsgroup-name group)))))
(message-news (gnus-group-real-name gnus-newsgroup-name))))))))
(defun gnus-group-post-news (&optional arg)
"Start composing a message (a news by default).
@ -694,18 +686,15 @@ posting style."
(buffer (current-buffer)))
(unwind-protect
(progn
(setq gnus-newsgroup-name
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(gnus-group-completing-read "Use group"
nil
(gnus-read-active-file-p))
"")
gnus-newsgroup-name))
;; #### see comment in gnus-setup-message -- drv
(gnus-setup-message 'message (message-mail)))
(with-current-buffer buffer
(setq gnus-newsgroup-name group)))))
gnus-newsgroup-name)))
(gnus-setup-message 'message (message-mail)))))))
(defun gnus-summary-news-other-window (&optional arg)
"Start composing a news in another window.
@ -724,24 +713,21 @@ network. The corresponding back end must have a `request-post' method."
(buffer (current-buffer)))
(unwind-protect
(progn
(setq gnus-newsgroup-name
(let ((gnus-newsgroup-name
(if arg
(if (= 1 (prefix-numeric-value arg))
(gnus-group-completing-read "Use group"
nil
(gnus-read-active-file-p))
"")
gnus-newsgroup-name))
;; #### see comment in gnus-setup-message -- drv
gnus-newsgroup-name)))
(gnus-setup-message 'message
(progn
(message-news (gnus-group-real-name gnus-newsgroup-name))
(set (make-local-variable 'gnus-discouraged-post-methods)
(remove
(car (gnus-find-method-for-group gnus-newsgroup-name))
gnus-discouraged-post-methods)))))
(with-current-buffer buffer
(setq gnus-newsgroup-name group)))))
gnus-discouraged-post-methods)))))))))
(defun gnus-summary-post-news (&optional arg)
"Start composing a message. Post to the current group by default.
@ -823,7 +809,7 @@ active, the entire article will be yanked."
(with-current-buffer gnus-article-copy
(save-restriction
(nnheader-narrow-to-headers)
(nnheader-parse-naked-head)))))
(nnheader-parse-head t)))))
(message-yank-original)
(message-exchange-point-and-mark)
(setq beg (or beg (mark t))))
@ -1993,10 +1979,10 @@ process-mark several articles, they will all be attached."
(gnus-summary-iterate n
(gnus-summary-select-article)
(with-current-buffer destination
;; Attach at the end of the buffer.
(save-excursion
(goto-char (point-max))
(message-forward-make-body-mime gnus-original-article-buffer))))
;; Attach at the end of the buffer.
(save-excursion
(goto-char (point-max))
(message-forward-make-body-mime gnus-original-article-buffer))))
(gnus-configure-windows 'message t)))
(provide 'gnus-msg)

13
lisp/gnus/gnus-registry.el
View file

@ -427,6 +427,8 @@ This is not required after changing `gnus-registry-cache-file'."
(gnus-message 4 "Removed %d ignored entries from the Gnus registry"
(- old-size (registry-size db)))))
(declare-function gnus-nnselect-group-p "nnselect" (group))
(declare-function nnselect-article-group "nnselect" (article))
;; article move/copy/spool/delete actions
(defun gnus-registry-action (action data-header from &optional to method)
(let* ((id (mail-header-id data-header))
@ -437,7 +439,10 @@ This is not required after changing `gnus-registry-cache-file'."
(or (cdr-safe (assq 'To extra)) "")))
(sender (nth 0 (gnus-registry-extract-addresses
(mail-header-from data-header))))
(from (gnus-group-guess-full-name-from-command-method from))
(from (gnus-group-guess-full-name-from-command-method
(if (gnus-nnselect-group-p from)
(nnselect-article-group (mail-header-number data-header))
from)))
(to (if to (gnus-group-guess-full-name-from-command-method to) nil)))
(gnus-message 7 "Gnus registry: article %s %s from %s to %s"
id (if method "respooling" "going") from to)
@ -788,7 +793,7 @@ Consults `gnus-registry-unfollowed-groups' and
Consults `gnus-registry-ignored-groups' and
`nnmail-split-fancy-with-parent-ignore-groups'."
(and group
(or (gnus-grep-in-list
(or (gnus-virtual-group-p group) (gnus-grep-in-list
group
(delq nil (mapcar (lambda (g)
(cond
@ -1218,7 +1223,7 @@ is `ask', ask the user; or if `gnus-registry-install' is non-nil, enable it."
(gnus-registry-initialize)))
gnus-registry-enabled)
;; largely based on nnir-warp-to-article
;; largely based on nnselect-warp-to-article
(defun gnus-try-warping-via-registry ()
"Try to warp via the registry.
This will be done via the current article's source group based on
@ -1242,7 +1247,7 @@ data stored in the registry."
(gnus-ephemeral-group-p group) ;; any ephemeral group
(memq (car (gnus-find-method-for-group group))
;; Specific methods; this list may need to expand.
'(nnir)))
'(nnselect)))
;; remember that we've seen this group already
(push group seen-groups)

5
lisp/gnus/gnus-srvr.el
View file

@ -34,7 +34,8 @@
(require 'gnus-range)
(require 'gnus-cloud)
(autoload 'gnus-group-make-nnir-group "nnir")
(autoload 'gnus-group-read-ephemeral-search-group "nnselect")
;;(autoload 'gnus-group-make-permanent-search-group "nnselect")
(defcustom gnus-server-exit-hook nil
"Hook run when exiting the server buffer."
@ -176,7 +177,7 @@ If nil, a faster, but more primitive, buffer is used instead."
"g" gnus-server-regenerate-server
"G" gnus-group-make-nnir-group
"G" gnus-group-read-ephemeral-search-group
"z" gnus-server-compact-server

2
lisp/gnus/gnus-start.el
View file

@ -1802,7 +1802,7 @@ backend check whether the group actually exists."
;; by one.
(t
(dolist (info infos)
(gnus-activate-group (gnus-info-group info) nil nil method t))))))
(gnus-activate-group (gnus-info-group info) t nil method t))))))
(defun gnus-make-hashtable-from-newsrc-alist ()
"Create a hash table from `gnus-newsrc-alist'.

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

@ -85,8 +85,8 @@
(autoload 'gnus-article-outlook-unwrap-lines "deuglify" nil t)
(autoload 'gnus-article-outlook-repair-attribution "deuglify" nil t)
(autoload 'gnus-article-outlook-rearrange-citation "deuglify" nil t)
(autoload 'nnir-article-rsv "nnir" nil nil 'macro)
(autoload 'nnir-article-group "nnir" nil nil 'macro)
(autoload 'nnselect-article-rsv "nnselect" nil nil)
(autoload 'nnselect-article-group "nnselect" nil nil)
(defcustom gnus-kill-summary-on-exit t
"If non-nil, kill the summary buffer when you exit from it.
@ -144,9 +144,9 @@ If t, fetch all the available old headers."
:type '(choice number
(sexp :menu-tag "other" t)))
(defcustom gnus-refer-thread-use-nnir nil
"Use nnir to search an entire server when referring threads.
A nil value will only search for thread-related articles in the
(defcustom gnus-refer-thread-use-search nil
"Search an entire server when referring threads. A
nil value will only search for thread-related articles in the
current group."
:version "24.1"
:group 'gnus-thread
@ -884,6 +884,7 @@ controls how articles are sorted."
(function-item gnus-article-sort-by-subject)
(function-item gnus-article-sort-by-date)
(function-item gnus-article-sort-by-score)
(function-item gnus-article-sort-by-rsv)
(function-item gnus-article-sort-by-random)
(function :tag "other"))
(boolean :tag "Reverse order"))))
@ -927,6 +928,7 @@ subthreads, customize `gnus-subthread-sort-functions'."
(function-item gnus-thread-sort-by-subject)
(function-item gnus-thread-sort-by-date)
(function-item gnus-thread-sort-by-score)
(function-item gnus-thread-sort-by-rsv)
(function-item gnus-thread-sort-by-most-recent-number)
(function-item gnus-thread-sort-by-most-recent-date)
(function-item gnus-thread-sort-by-random)
@ -1433,16 +1435,13 @@ the normal Gnus MIME machinery."
(?c (or (mail-header-chars gnus-tmp-header) 0) ?d)
(?k (gnus-summary-line-message-size gnus-tmp-header) ?s)
(?L gnus-tmp-lines ?s)
(?Z (or (nnir-article-rsv (mail-header-number gnus-tmp-header))
0)
?d)
(?G (or (nnir-article-group (mail-header-number gnus-tmp-header))
"")
?s)
(?Z (or (nnselect-article-rsv (mail-header-number gnus-tmp-header))
0) ?d)
(?G (or (nnselect-article-group (mail-header-number gnus-tmp-header))
"") ?s)
(?g (or (gnus-group-short-name
(nnir-article-group (mail-header-number gnus-tmp-header)))
"")
?s)
(nnselect-article-group (mail-header-number gnus-tmp-header)))
"") ?s)
(?O gnus-tmp-downloaded ?c)
(?I gnus-tmp-indentation ?s)
(?T (if (= gnus-tmp-level 0) "" (make-string (frame-width) ? )) ?s)
@ -1619,6 +1618,8 @@ This list will always be a subset of gnus-newsgroup-undownloaded.")
(defvar gnus-newsgroup-sparse nil)
(defvar gnus-newsgroup-selection nil)
(defvar gnus-current-article nil)
(defvar gnus-article-current nil)
(defvar gnus-current-headers nil)
@ -1653,6 +1654,8 @@ This list will always be a subset of gnus-newsgroup-undownloaded.")
gnus-newsgroup-undownloaded
gnus-newsgroup-unsendable
gnus-newsgroup-selection
gnus-newsgroup-begin gnus-newsgroup-end
gnus-newsgroup-last-rmail gnus-newsgroup-last-mail
gnus-newsgroup-last-folder gnus-newsgroup-last-file
@ -4532,48 +4535,14 @@ Returns HEADER if it was entered in the DEPENDENCIES. Returns nil otherwise."
;; This function has to be called with point after the article number
;; on the beginning of the line.
(defsubst gnus-nov-parse-line (number dependencies &optional force-new)
(let ((eol (point-at-eol))
header references in-reply-to)
(let (header)
;; overview: [num subject from date id refs chars lines misc]
(unwind-protect
(let (x)
(narrow-to-region (point) eol)
(unless (eobp)
(forward-char))
(setq header
(make-full-mail-header
number ; number
(condition-case () ; subject
(gnus-remove-odd-characters
(funcall gnus-decode-encoded-word-function
(setq x (nnheader-nov-field))))
(error x))
(condition-case () ; from
(gnus-remove-odd-characters
(funcall gnus-decode-encoded-address-function
(setq x (nnheader-nov-field))))
(error x))
(nnheader-nov-field) ; date
(nnheader-nov-read-message-id number) ; id
(setq references (nnheader-nov-field)) ; refs
(nnheader-nov-read-integer) ; chars
(nnheader-nov-read-integer) ; lines
(unless (eobp)
(if (looking-at "Xref: ")
(goto-char (match-end 0)))
(nnheader-nov-field)) ; Xref
(nnheader-nov-parse-extra)))) ; extra
(narrow-to-region (point) (point-at-eol))
(unless (eobp)
(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)))
@ -5104,6 +5073,17 @@ using some other form will lead to serious barfage."
(gnus-article-sort-by-date
(gnus-thread-header h1) (gnus-thread-header h2)))
(defsubst gnus-article-sort-by-rsv (h1 h2)
"Sort articles by rsv."
(when gnus-newsgroup-selection
(< (nnselect-article-rsv (mail-header-number h1))
(nnselect-article-rsv (mail-header-number h2)))))
(defun gnus-thread-sort-by-rsv (h1 h2)
"Sort threads by root article rsv."
(gnus-article-sort-by-rsv
(gnus-thread-header h1) (gnus-thread-header h2)))
(defsubst gnus-article-sort-by-score (h1 h2)
"Sort articles by root article score.
Unscored articles will be counted as having a score of zero."
@ -5634,22 +5614,32 @@ or a straight list of headers."
"Fetch headers of ARTICLES."
(gnus-message 7 "Fetching headers for %s..." gnus-newsgroup-name)
(prog1
(if (eq 'nov
(setq gnus-headers-retrieved-by
(gnus-retrieve-headers
articles gnus-newsgroup-name
(or limit
;; We might want to fetch old headers, but
;; not if there is only 1 article.
(and (or (and
(not (eq gnus-fetch-old-headers 'some))
(not (numberp gnus-fetch-old-headers)))
(> (length articles) 1))
gnus-fetch-old-headers)))))
(gnus-get-newsgroup-headers-xover
articles force-new dependencies gnus-newsgroup-name t)
(gnus-get-newsgroup-headers dependencies force-new))
(gnus-message 7 "Fetching headers for %s...done" gnus-newsgroup-name)))
(pcase (setq gnus-headers-retrieved-by
(gnus-retrieve-headers
articles gnus-newsgroup-name
(or limit
;; We might want to fetch old headers, but
;; not if there is only 1 article.
(and (or (and
(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)))
(defun gnus-select-newsgroup (group &optional read-all select-articles)
"Select newsgroup GROUP.
@ -6405,12 +6395,11 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(gnus-group-update-group group t))))))
(defun gnus-get-newsgroup-headers (&optional dependencies force-new)
(let ((cur nntp-server-buffer)
(dependencies
(let ((dependencies
(or dependencies
(with-current-buffer gnus-summary-buffer
gnus-newsgroup-dependencies)))
headers id end ref number
headers
(mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
(save-current-buffer (condition-case nil
@ -6418,146 +6407,15 @@ The resulting hash table is returned, or nil if no Xrefs were found."
(error))
gnus-newsgroup-ignored-charsets)))
(with-current-buffer nntp-server-buffer
;; Translate all TAB characters into SPACE characters.
(subst-char-in-region (point-min) (point-max) ?\t ? t)
(subst-char-in-region (point-min) (point-max) ?\r ? t)
(ietf-drums-unfold-fws)
(gnus-run-hooks 'gnus-parse-headers-hook)
(let ((case-fold-search t)
in-reply-to header p lines chars)
(let ((nnmail-extra-headers gnus-extra-headers)
header)
(goto-char (point-min))
;; Search to the beginning of the next header. Error messages
;; do not begin with 2 or 3.
(while (re-search-forward "^[23][0-9]+ " nil t)
(setq id nil
ref nil)
;; This implementation of this function, with nine
;; search-forwards instead of the one re-search-forward and
;; a case (which basically was the old function) is actually
;; about twice as fast, even though it looks messier. You
;; can't have everything, I guess. Speed and elegance
;; doesn't always go hand in hand.
(setq
header
(make-full-mail-header
;; Number.
(prog1
(setq number (read cur))
(end-of-line)
(setq p (point))
(narrow-to-region (point)
(or (and (search-forward "\n.\n" nil t)
(- (point) 2))
(point))))
;; Subject.
(progn
(goto-char p)
(if (search-forward "\nsubject:" nil t)
(funcall gnus-decode-encoded-word-function
(nnheader-header-value))
"(none)"))
;; From.
(progn
(goto-char p)
(if (search-forward "\nfrom:" nil t)
(funcall gnus-decode-encoded-address-function
(nnheader-header-value))
"(nobody)"))
;; Date.
(progn
(goto-char p)
(if (search-forward "\ndate:" nil t)
(nnheader-header-value) ""))
;; Message-ID.
(progn
(goto-char p)
(setq id (if (re-search-forward
"^message-id: *\\(<[^\n\t> ]+>\\)" nil t)
;; We do it this way to make sure the Message-ID
;; is (somewhat) syntactically valid.
(buffer-substring (match-beginning 1)
(match-end 1))
;; If there was no message-id, we just fake one
;; to make subsequent routines simpler.
(nnheader-generate-fake-message-id number))))
;; References.
(progn
(goto-char p)
(if (search-forward "\nreferences:" nil t)
(progn
(setq end (point))
(prog1
(nnheader-header-value)
(setq ref
(buffer-substring
(progn
(end-of-line)
(search-backward ">" end t)
(1+ (point)))
(progn
(search-backward "<" end t)
(point))))))
;; Get the references from the in-reply-to header if there
;; were no references and the in-reply-to header looks
;; promising.
(if (and (search-forward "\nin-reply-to:" nil t)
(setq in-reply-to (nnheader-header-value))
(string-match "<[^>]+>" in-reply-to))
(let (ref2)
(setq ref (substring in-reply-to (match-beginning 0)
(match-end 0)))
(while (string-match "<[^>]+>" in-reply-to (match-end 0))
(setq ref2 (substring in-reply-to (match-beginning 0)
(match-end 0)))
(when (> (length ref2) (length ref))
(setq ref ref2)))
ref)
(setq ref nil))))
;; Chars.
(progn
(goto-char p)
(if (search-forward "\nchars: " nil t)
(if (numberp (setq chars (ignore-errors (read cur))))
chars -1)
-1))
;; Lines.
(progn
(goto-char p)
(if (search-forward "\nlines: " nil t)
(if (numberp (setq lines (ignore-errors (read cur))))
lines -1)
-1))
;; Xref.
(progn
(goto-char p)
(and (search-forward "\nxref:" nil t)
(nnheader-header-value)))
;; Extra.
(when gnus-extra-headers
(let ((extra gnus-extra-headers)
out)
(while extra
(goto-char p)
(when (search-forward
(concat "\n" (symbol-name (car extra)) ":") nil t)
(push (cons (car extra) (nnheader-header-value))
out))
(pop extra))
out))))
(when (equal id ref)
(setq ref nil))
(when gnus-alter-header-function
(funcall gnus-alter-header-function header)
(setq id (mail-header-id header)
ref (gnus-parent-id (mail-header-references header))))
(while (setq header (nnheader-parse-head))
(when (setq header
(gnus-dependencies-add-header
header dependencies force-new))
(push header headers))
(goto-char (point-max))
(widen))
(push header headers)))
(nreverse headers)))))
;; Goes through the xover lines and returns a list of vectors
@ -8702,7 +8560,8 @@ SCORE."
When called interactively, ID is the Message-ID of the current
article. If thread-only is non-nil limit the summary buffer to
these articles."
(interactive (list (mail-header-id (gnus-summary-article-header))))
(interactive (list (mail-header-id (gnus-summary-article-header))
current-prefix-arg))
(let ((articles (gnus-articles-in-thread
(gnus-id-to-thread (gnus-root-id id))))
;;we REALLY want the whole thread---this prevents cut-threads
@ -9125,13 +8984,13 @@ Return the number of articles fetched."
result))
(defun gnus-summary-refer-thread (&optional limit)
"Fetch all articles in the current thread. For backends
that know how to search for threads (currently only 'nnimap)
a non-numeric prefix arg will use nnir to search the entire
"Fetch all articles in the current thread. For backends that
know how to search for threads (currently only 'nnimap) a
non-numeric prefix arg will search the entire
server; without a prefix arg only the current group is
searched. If the variable `gnus-refer-thread-use-nnir' is
non-nil the prefix arg has the reverse meaning. If no
backend-specific `request-thread' function is available fetch
searched. If the variable `gnus-refer-thread-use-search' is
non-nil the prefix arg has the reverse meaning. If no
backend-specific 'request-thread function is available fetch
LIMIT (the numerical prefix) old headers. If LIMIT is
non-numeric or nil fetch the number specified by the
`gnus-refer-thread-limit' variable."
@ -9141,9 +9000,9 @@ non-numeric or nil fetch the number specified by the
(gnus-inhibit-demon t)
(gnus-summary-ignore-duplicates t)
(gnus-read-all-available-headers t)
(gnus-refer-thread-use-nnir
(gnus-refer-thread-use-search
(if (and (not (null limit)) (listp limit))
(not gnus-refer-thread-use-nnir) gnus-refer-thread-use-nnir))
(not gnus-refer-thread-use-search) gnus-refer-thread-use-search))
(new-headers
(if (gnus-check-backend-function
'request-thread gnus-newsgroup-name)
@ -9284,9 +9143,9 @@ non-numeric or nil fetch the number specified by the
(dolist (method gnus-refer-article-method)
(push (if (eq 'current method)
gnus-current-select-method
(if (eq 'nnir (car method))
(if (eq 'nnselect (car method))
(list
'nnir
'nnselect
(or (cadr method)
(gnus-method-to-server gnus-current-select-method)))
method))

7
lisp/gnus/gnus.el
View file

@ -1607,7 +1607,7 @@ total number of articles in the group.")
:variable-default (mapcar
(lambda (g) (list g t))
'("delayed$" "drafts$" "queue$" "INBOX$"
"^nnmairix:" "^nnir:" "archive"))
"^nnmairix:" "^nnselect:" "archive"))
:variable-document
"Groups in which the registry should be turned off."
:variable-group gnus-registry
@ -3153,7 +3153,10 @@ that that variable is buffer-local to the summary buffers."
(defun gnus-kill-ephemeral-group (group)
"Remove ephemeral GROUP from relevant structures."
(remhash group gnus-newsrc-hashtb))
(remhash group gnus-newsrc-hashtb)
(setq gnus-newsrc-alist
(delq (assoc group gnus-newsrc-alist)
gnus-newsrc-alist)))
(defun gnus-simplify-mode-line ()
"Make mode lines a bit simpler."

2
lisp/gnus/nndiary.el
View file

@ -992,7 +992,7 @@ all. This may very well take some time.")
(narrow-to-region
(goto-char (point-min))
(if (search-forward "\n\n" nil t) (1- (point)) (point-max))))
(let ((headers (nnheader-parse-naked-head)))
(let ((headers (nnheader-parse-head t)))
(setf (mail-header-chars headers) chars)
(setf (mail-header-number headers) number)
headers))))

2
lisp/gnus/nnfolder.el
View file

@ -1160,7 +1160,7 @@ This command does not work if you use short group names."
(if (search-forward "\n\n" e t) (setq e (1- (point)))))
(with-temp-buffer
(insert-buffer-substring buf b e)
(let ((headers (nnheader-parse-naked-head)))
(let ((headers (nnheader-parse-head t)))
(setf (mail-header-chars headers) chars)
(setf (mail-header-number headers) number)
headers)))))

346
lisp/gnus/nnheader.el
View file

@ -28,6 +28,10 @@
(eval-when-compile (require 'cl-lib))
(defvar gnus-decode-encoded-word-function)
(defvar gnus-decode-encoded-address-function)
(defvar gnus-alter-header-function)
(defvar nnmail-extra-headers)
(defvar gnus-newsgroup-name)
(defvar jka-compr-compression-info-list)
@ -39,6 +43,7 @@
(require 'mail-utils)
(require 'mm-util)
(require 'gnus-util)
(autoload 'gnus-remove-odd-characters "gnus-sum")
(autoload 'gnus-range-add "gnus-range")
(autoload 'gnus-remove-from-range "gnus-range")
;; FIXME none of these are used explicitly in this file.
@ -188,124 +193,167 @@ on your system, you could say something like:
(autoload 'ietf-drums-unfold-fws "ietf-drums")
(defun nnheader-parse-naked-head (&optional number)
;; This function unfolds continuation lines in this buffer
;; destructively. When this side effect is unwanted, use
;; `nnheader-parse-head' instead of this function.
(let ((case-fold-search t)
(buffer-read-only nil)
(cur (current-buffer))
(p (point-min))
in-reply-to lines ref)
(nnheader-remove-cr-followed-by-lf)
(ietf-drums-unfold-fws)
(subst-char-in-region (point-min) (point-max) ?\t ? )
(goto-char p)
(insert "\n")
(prog1
;; This implementation of this function, with nine
;; search-forwards instead of the one re-search-forward and a
;; case (which basically was the old function) is actually
;; about twice as fast, even though it looks messier. You
;; can't have everything, I guess. Speed and elegance don't
;; always go hand in hand.
(make-full-mail-header
;; Number.
(or number 0)
;; Subject.
(progn
(goto-char p)
(if (search-forward "\nsubject:" nil t)
(nnheader-header-value) "(none)"))
;; From.
(progn
(goto-char p)
(if (search-forward "\nfrom:" nil t)
(nnheader-header-value) "(nobody)"))
;; Date.
(progn
(goto-char p)
(if (search-forward "\ndate:" nil t)
(nnheader-header-value) ""))
;; Message-ID.
(progn
(goto-char p)
(if (search-forward "\nmessage-id:" nil t)
(buffer-substring
(1- (or (search-forward "<" (point-at-eol) t)
(point)))
(or (search-forward ">" (point-at-eol) t) (point)))
;; If there was no message-id, we just fake one to make
;; subsequent routines simpler.
(nnheader-generate-fake-message-id number)))
;; References.
(progn
(goto-char p)
(if (search-forward "\nreferences:" nil t)
(nnheader-header-value)
;; Get the references from the in-reply-to header if
;; there were no references and the in-reply-to header
;; looks promising.
(if (and (search-forward "\nin-reply-to:" nil t)
(setq in-reply-to (nnheader-header-value))
(string-match "<[^\n>]+>" in-reply-to))
(let (ref2)
(setq ref (substring in-reply-to (match-beginning 0)
(match-end 0)))
(while (string-match "<[^\n>]+>"
in-reply-to (match-end 0))
(setq ref2 (substring in-reply-to (match-beginning 0)
(match-end 0)))
(when (> (length ref2) (length ref))
(setq ref ref2)))
ref)
nil)))
;; Chars.
0
;; Lines.
(progn
(goto-char p)
(if (search-forward "\nlines: " nil t)
(if (numberp (setq lines (read cur)))
lines 0)
0))
;; Xref.
(progn
(goto-char p)
(and (search-forward "\nxref:" nil t)
(nnheader-header-value)))
;; Extra.
(when nnmail-extra-headers
(let ((extra nnmail-extra-headers)
out)
(while extra
(goto-char p)
(when (search-forward
(concat "\n" (symbol-name (car extra)) ":") nil t)
(push (cons (car extra) (nnheader-header-value))
out))
(pop extra))
out)))
(goto-char p)
(delete-char 1))))
(defun nnheader-parse-head (&optional naked)
(let ((cur (current-buffer)) num beg end)
(when (if naked
(setq num 0
beg (point-min)
end (point-max))
;; Search to the beginning of the next header. Error
;; messages do not begin with 2 or 3.
(when (re-search-forward "^[23][0-9]+ " nil t)
(setq num (read cur)
beg (point)
end (if (search-forward "\n.\n" nil t)
(goto-char (- (point) 2))
(point)))))
(with-temp-buffer
(insert-buffer-substring cur beg end)
(nnheader-parse-naked-head num)))))
(defsubst nnheader-head-make-header (number)
"Using data of type 'head in the current buffer
return a full mail header with article NUMBER."
(let ((p (point-min))
(cur (current-buffer))
in-reply-to chars lines end ref)
;; This implementation of this function, with nine
;; search-forwards instead of the one re-search-forward and a
;; case (which basically was the old function) is actually
;; about twice as fast, even though it looks messier. You
;; can't have everything, I guess. Speed and elegance don't
;; always go hand in hand.
(make-full-mail-header
;; Number.
number
;; Subject.
(progn
(goto-char p)
(if (search-forward "\nsubject:" nil t)
(funcall gnus-decode-encoded-word-function
(nnheader-header-value))
"(none)"))
;; From.
(progn
(goto-char p)
(if (search-forward "\nfrom:" nil t)
(funcall gnus-decode-encoded-address-function
(nnheader-header-value))
"(nobody)"))
;; Date.
(progn
(goto-char p)
(if (search-forward "\ndate:" nil t)
(nnheader-header-value) ""))
;; Message-ID.
(progn
(goto-char p)
(if (re-search-forward
"^message-id: *\\(<[^\n\t> ]+>\\)" nil t)
;; We do it this way to make sure the Message-ID
;; is (somewhat) syntactically valid.
(buffer-substring (match-beginning 1)
(match-end 1))
;; If there was no message-id, we just fake one to make
;; subsequent routines simpler.
(nnheader-generate-fake-message-id number)))
;; References.
(progn
(goto-char p)
(if (search-forward "\nreferences:" nil t)
(progn
(setq end (point))
(prog1
(nnheader-header-value)
(setq ref
(buffer-substring
(progn
(end-of-line)
(search-backward ">" end t)
(1+ (point)))
(progn
(search-backward "<" end t)
(point))))))
;; Get the references from the in-reply-to header if there
;; were no references and the in-reply-to header looks
;; promising.
(if (and (search-forward "\nin-reply-to:" nil t)
(setq in-reply-to (nnheader-header-value))
(string-match "<[^>]+>" in-reply-to))
(let (ref2)
(setq ref (substring in-reply-to (match-beginning 0)
(match-end 0)))
(while (string-match "<[^>]+>" in-reply-to (match-end 0))
(setq ref2 (substring in-reply-to (match-beginning 0)
(match-end 0)))
(when (> (length ref2) (length ref))
(setq ref ref2)))
ref)
nil)))
;; Chars.
(progn
(goto-char p)
(if (search-forward "\nchars: " nil t)
(if (numberp (setq chars (ignore-errors (read cur))))
chars -1)
-1))
;; Lines.
(progn
(goto-char p)
(if (search-forward "\nlines: " nil t)
(if (numberp (setq lines (ignore-errors (read cur))))
lines -1)
-1))
;; Xref.
(progn
(goto-char p)
(and (search-forward "\nxref:" nil t)
(nnheader-header-value)))
;; Extra.
(when nnmail-extra-headers
(let ((extra nnmail-extra-headers)
out)
(while extra
(goto-char p)
(when (search-forward
(concat "\n" (symbol-name (car extra)) ":") nil t)
(push (cons (car extra) (nnheader-header-value))
out))
(pop extra))
out)))))
(defun nnheader-parse-head (&optional naked temp)
"Parse data of type 'header in the current buffer and return a
mail header, modifying the buffer contents in the process. The
buffer is assumed to begin each header with an \"Article
retrieved\" line with an article number; If NAKED is non-nil
this line is assumed absent, and the buffer should contain a
single header's worth of data. If TEMP is non-nil the data is
first copied to a temporary buffer leaving the original buffer
untouched."
(let ((cur (current-buffer))
(num 0)
(beg (point-min))
(end (point-max))
buf)
(when (or naked
;; Search to the beginning of the next header. Error
;; messages do not begin with 2 or 3.
(when (re-search-forward "^[23][0-9]+ " nil t)
(setq num (read cur)
beg (point)
end (if (search-forward "\n.\n" nil t)
(goto-char (- (point) 2))
(point)))))
;; When TEMP copy the data to a temporary buffer
(if temp
(progn
(set-buffer (setq buf (generate-new-buffer " *nnheader-temp*")))
(insert-buffer-substring cur beg end))
;; Otherwise just narrow to the data
(narrow-to-region beg end))
(let ((case-fold-search t)
(buffer-read-only nil)
header)
(nnheader-remove-cr-followed-by-lf)
(ietf-drums-unfold-fws)
(subst-char-in-region (point-min) (point-max) ?\t ? t)
(subst-char-in-region (point-min) (point-max) ?\r ? t)
(goto-char (point-min))
(insert "\n")
(setq header (nnheader-head-make-header num))
(goto-char (point-min))
(delete-char 1)
(if temp
(kill-buffer buf)
(goto-char (point-max))
(widen))
(when gnus-alter-header-function
(funcall gnus-alter-header-function header))
header))))
(defmacro nnheader-nov-skip-field ()
'(search-forward "\t" eol 'move))
@ -347,24 +395,43 @@ on your system, you could say something like:
'id)
(nnheader-generate-fake-message-id ,number))))
(defun nnheader-parse-nov ()
(defalias 'nnheader-nov-make-header 'nnheader-parse-nov)
(autoload 'gnus-extract-message-id-from-in-reply-to "gnus-sum")
(defun nnheader-parse-nov (&optional number)
(let ((eol (point-at-eol))
(number (nnheader-nov-read-integer)))
(vector
number ; number
(nnheader-nov-field) ; subject
(nnheader-nov-field) ; from
(nnheader-nov-field) ; date
(nnheader-nov-read-message-id number) ; id
(nnheader-nov-field) ; refs
(nnheader-nov-read-integer) ; chars
(nnheader-nov-read-integer) ; lines
(if (eq (char-after) ?\n)
nil
(if (looking-at "Xref: ")
(goto-char (match-end 0)))
(nnheader-nov-field)) ; Xref
(nnheader-nov-parse-extra)))) ; extra
references in-reply-to x header)
(setq header
(make-full-mail-header
(or number (nnheader-nov-read-integer)) ; number
(condition-case () ; subject
(gnus-remove-odd-characters
(funcall gnus-decode-encoded-word-function
(setq x (nnheader-nov-field))))
(error x))
(condition-case () ; from
(gnus-remove-odd-characters
(funcall gnus-decode-encoded-address-function
(setq x (nnheader-nov-field))))
(error x))
(nnheader-nov-field) ; date
(nnheader-nov-read-message-id number) ; id
(setq references (nnheader-nov-field)) ; refs
(nnheader-nov-read-integer) ; chars
(nnheader-nov-read-integer) ; lines
(unless (eobp)
(if (looking-at "Xref: ")
(goto-char (match-end 0)))
(nnheader-nov-field)) ; Xref
(nnheader-nov-parse-extra))) ; extra
(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)))
header))
(defun nnheader-insert-nov (header)
(princ (mail-header-number header) (current-buffer))
@ -399,17 +466,6 @@ on your system, you could say something like:
(delete-char 1))
(forward-line 1)))
(defun nnheader-parse-overview-file (file)
"Parse FILE and return a list of headers."
(mm-with-unibyte-buffer
(nnheader-insert-file-contents file)
(goto-char (point-min))
(let (headers)
(while (not (eobp))
(push (nnheader-parse-nov) headers)
(forward-line 1))
(nreverse headers))))
(defun nnheader-write-overview-file (file headers)
"Write HEADERS to FILE."
(with-temp-file file

10
lisp/gnus/nnimap.el
View file

@ -1686,7 +1686,7 @@ If LIMIT, first try to limit the search to the N last articles."
(gnus-add-to-range
(gnus-add-to-range
(gnus-range-add (gnus-info-read info)
vanished)
vanished)
(cdr (assq '%Flagged flags)))
(cdr (assq '%Seen flags))))
(let ((marks (gnus-info-marks info)))
@ -1851,15 +1851,15 @@ If LIMIT, first try to limit the search to the N last articles."
(setq nnimap-status-string "Read-only server")
nil)
(defvar gnus-refer-thread-use-nnir) ;; gnus-sum.el
(defvar gnus-refer-thread-use-search) ;; gnus-sum.el
(declare-function gnus-fetch-headers "gnus-sum"
(articles &optional limit force-new dependencies))
(autoload 'nnir-search-thread "nnir")
(autoload 'nnselect-search-thread "nnselect")
(deffoo nnimap-request-thread (header &optional group server)
(if gnus-refer-thread-use-nnir
(nnir-search-thread header)
(if gnus-refer-thread-use-search
(nnselect-search-thread header)
(when (nnimap-change-group group server)
(let* ((cmd (nnimap-make-thread-query header))
(result (with-current-buffer (nnimap-buffer)

855
lisp/gnus/nnir.el
View file

File diff suppressed because it is too large Load diff

2
lisp/gnus/nnmaildir.el
View file

@ -492,7 +492,7 @@ This variable is set by `nnmaildir-request-article'.")
(setq nov-mid 0))
(goto-char (point-min))
(delete-char 1)
(setq nov (nnheader-parse-naked-head)
(setq nov (nnheader-parse-head t)
field (or (mail-header-lines nov) 0)))
(unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:))
(setq nov-mid field))

2
lisp/gnus/nnml.el
View file

@ -766,7 +766,7 @@ article number. This function is called narrowed to an article."
(if (re-search-forward "\n\r?\n" nil t)
(1- (point))
(point-max))))
(let ((headers (nnheader-parse-naked-head)))
(let ((headers (nnheader-parse-head t)))
(setf (mail-header-chars headers) chars)
(setf (mail-header-number headers) number)
headers))))

864
lisp/gnus/nnselect.el Normal file
View file

@ -0,0 +1,864 @@
;;; nnselect.el --- a virtual group backend -*- lexical-binding:t -*-
;; Copyright (C) 2020 Free Software Foundation, Inc.
;; Author: Andrew Cohen <cohen@andy.bu.edu>
;; Keywords: news mail
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This is a "virtual" backend that allows an aribtrary list of
;; articles to be treated as a gnus group. An nnselect group uses an
;; nnselect-spec group parameter to specify this list of
;; articles. nnselect-spec is an alist with two keys:
;; nnselect-function, whose value should be a function that returns
;; the list of articles, and nnselect-args. The function will be
;; applied to the arguments to generate the list of articles. The
;; return value should be a vector, each element of which should in
;; turn be a vector of three elements: a real prefixed group name, an
;; article number in that group, and an integer score. The score is
;; not used by nnselect but may be used by other code to help in
;; sorting. Most functions will just chose a fixed number, such as
;; 100, for this score.
;; For example the search function `nnir-run-query' applied to
;; arguments specifying a search query (see "nnir.el") can be used to
;; return a list of articles from a search. Or the function can be the
;; identity and the args a vector of articles.
;;; Code:
;;; Setup:
(require 'gnus-art)
(require 'nnir)
(eval-when-compile (require 'cl-lib))
;; Set up the backend
(nnoo-declare nnselect)
(nnoo-define-basics nnselect)
(gnus-declare-backend "nnselect" 'post-mail 'virtual)
;;; Internal Variables:
(defvar gnus-inhibit-demon)
(defvar gnus-message-group-art)
;; For future use
(defvoo nnselect-directory gnus-directory
"Directory for the nnselect backend.")
(defvoo nnselect-active-file
(expand-file-name "nnselect-active" nnselect-directory)
"nnselect active file.")
(defvoo nnselect-groups-file
(expand-file-name "nnselect-newsgroups" nnselect-directory)
"nnselect groups description file.")
;;; Helper routines.
(defun nnselect-compress-artlist (artlist)
"Compress ARTLIST."
(let (selection)
(pcase-dolist (`(,artgroup . ,arts)
(nnselect-categorize artlist 'nnselect-artitem-group))
(let (list)
(pcase-dolist (`(,rsv . ,articles)
(nnselect-categorize
arts 'nnselect-artitem-rsv 'nnselect-artitem-number))
(push (cons rsv (gnus-compress-sequence (sort articles '<)))
list))
(push (cons artgroup list) selection)))
selection))
(defun nnselect-uncompress-artlist (artlist)
"Uncompress ARTLIST."
(if (vectorp artlist)
artlist
(let (selection)
(pcase-dolist (`(,artgroup (,artrsv . ,artseq)) artlist)
(setq selection
(vconcat
(cl-map 'vector
#'(lambda (art)
(vector artgroup art artrsv))
(gnus-uncompress-sequence artseq)) selection)))
selection)))
(defun nnselect-group-server (group)
"Return the server for GROUP."
(gnus-group-server group))
;; Data type article list.
(define-inline nnselect-artlist-length (artlist)
(inline-quote (length ,artlist)))
(define-inline nnselect-artlist-article (artlist n)
"Return from ARTLIST the Nth artitem (counting starting at 1)."
(inline-quote (when (> ,n 0)
(elt ,artlist (1- ,n)))))
(define-inline nnselect-artitem-group (artitem)
"Return the group from the ARTITEM."
(inline-quote (elt ,artitem 0)))
(define-inline nnselect-artitem-number (artitem)
"Return the number from the ARTITEM."
(inline-quote (elt ,artitem 1)))
(define-inline nnselect-artitem-rsv (artitem)
"Return the Retrieval Status Value (RSV, score) from the ARTITEM."
(inline-quote (elt ,artitem 2)))
(define-inline nnselect-article-group (article)
"Return the group for ARTICLE."
(inline-quote
(nnselect-artitem-group (nnselect-artlist-article
gnus-newsgroup-selection ,article))))
(define-inline nnselect-article-number (article)
"Return the number for ARTICLE."
(inline-quote (nnselect-artitem-number
(nnselect-artlist-article
gnus-newsgroup-selection ,article))))
(define-inline nnselect-article-rsv (article)
"Return the rsv for ARTICLE."
(inline-quote (nnselect-artitem-rsv
(nnselect-artlist-article
gnus-newsgroup-selection ,article))))
(define-inline nnselect-article-id (article)
"Return the pair `(nnselect id . real id)' of ARTICLE."
(inline-quote (cons ,article (nnselect-article-number ,article))))
(define-inline nnselect-categorize (sequence keyfunc &optional valuefunc)
"Sorts a sequence into categories.
Returns a list of the form
`((key1 (element11 element12)) (key2 (element21 element22))'.
The category key for a member of the sequence is obtained
as `(keyfunc member)' and the corresponding element is just
`member' (or `(valuefunc member)' if `valuefunc' is non-nil)."
(inline-letevals (sequence keyfunc valuefunc)
(inline-quote (let ((valuefunc (or ,valuefunc 'identity))
result)
(unless (null ,sequence)
(mapc
(lambda (member)
(let* ((key (funcall ,keyfunc member))
(value (funcall valuefunc member))
(kr (assoc key result)))
(if kr
(push value (cdr kr))
(push (list key value) result))))
(reverse ,sequence))
result)))))
;; Unclear whether a macro or an inline function is best.
;; (defmacro nnselect-categorize (sequence keyfunc &optional valuefunc)
;; "Sorts a sequence into categories and returns a list of the form
;; `((key1 (element11 element12)) (key2 (element21 element22))'.
;; The category key for a member of the sequence is obtained
;; as `(keyfunc member)' and the corresponding element is just
;; `member' (or `(valuefunc member)' if `valuefunc' is non-nil)."
;; (let ((key (make-symbol "key"))
;; (value (make-symbol "value"))
;; (result (make-symbol "result"))
;; (valuefunc (or valuefunc 'identity)))
;; `(unless (null ,sequence)
;; (let (,result)
;; (mapc
;; (lambda (member)
;; (let* ((,key (,keyfunc member))
;; (,value (,valuefunc member))
;; (kr (assoc ,key ,result)))
;; (if kr
;; (push ,value (cdr kr))
;; (push (list ,key ,value) ,result))))
;; (reverse ,sequence))
;; ,result))))
(define-inline ids-by-group (articles)
(inline-quote
(nnselect-categorize ,articles 'nnselect-article-group
'nnselect-article-id)))
(define-inline numbers-by-group (articles)
(inline-quote
(nnselect-categorize
,articles 'nnselect-article-group 'nnselect-article-number)))
(defmacro nnselect-add-prefix (group)
"Ensures that the GROUP has an nnselect prefix."
`(gnus-group-prefixed-name
(gnus-group-short-name ,group) '(nnselect "nnselect")))
(defmacro nnselect-get-artlist (group)
"Retrieve the list of articles for GROUP."
`(when (gnus-nnselect-group-p ,group)
(nnselect-uncompress-artlist
(gnus-group-get-parameter ,group 'nnselect-artlist t))))
(defmacro nnselect-add-novitem (novitem)
"Add NOVITEM to the list of headers."
`(let* ((novitem ,novitem)
(artno (and novitem
(mail-header-number novitem)))
(art (car-safe (rassq artno artids))))
(when art
(setf (mail-header-number novitem) art)
(push novitem headers))))
;;; User Customizable Variables:
(defgroup nnselect nil
"Virtual groups in Gnus with arbitrary selection methods."
:group 'gnus)
(defcustom nnselect-retrieve-headers-override-function nil
"A function that retrieves article headers for ARTICLES from GROUP.
The retrieved headers should populate the `nntp-server-buffer'.
Returns either the retrieved header format 'nov or 'headers.
If this variable is nil, or if the provided function returns nil,
`gnus-retrieve-headers' will be called instead."
:version "24.1" :type '(function) :group 'nnselect)
;; Gnus backend interface functions.
(deffoo nnselect-open-server (server &optional definitions)
;; Just set the server variables appropriately.
(let ((backend (or (car (gnus-server-to-method server)) 'nnselect)))
(nnoo-change-server backend server definitions)))
;; (deffoo nnselect-server-opened (&optional server)
;; "Is SERVER the current virtual server?"
;; (if (string-empty-p server)
;; t
;; (let ((backend (car (gnus-server-to-method server))))
;; (nnoo-current-server-p (or backend 'nnselect) server))))
(deffoo nnselect-server-opened (&optional _server)
t)
(deffoo nnselect-request-group (group &optional _server _dont-check info)
(let* ((group (nnselect-add-prefix group))
(nnselect-artlist (nnselect-get-artlist group))
length)
;; Check for cached select result or run the selection and cache
;; the result.
(unless nnselect-artlist
(gnus-group-set-parameter
group 'nnselect-artlist
(nnselect-compress-artlist (setq nnselect-artlist
(nnselect-run
(gnus-group-get-parameter group 'nnselect-specs t)))))
(nnselect-request-update-info
group (or info (gnus-get-info group))))
(if (zerop (setq length (nnselect-artlist-length nnselect-artlist)))
(progn
(nnheader-report 'nnselect "Selection produced empty results.")
(nnheader-insert ""))
(with-current-buffer nntp-server-buffer
(nnheader-insert "211 %d %d %d %s\n"
length ; total #
1 ; first #
length ; last #
group))) ; group name
nnselect-artlist))
(deffoo nnselect-retrieve-headers (articles group &optional _server fetch-old)
(let ((group (nnselect-add-prefix group)))
(with-current-buffer (gnus-summary-buffer-name group)
(setq gnus-newsgroup-selection (or gnus-newsgroup-selection
(nnselect-get-artlist group)))
(let ((gnus-inhibit-demon t)
(gartids (ids-by-group articles))
headers)
(with-current-buffer nntp-server-buffer
(pcase-dolist (`(,artgroup . ,artids) gartids)
(let ((artlist (sort (mapcar 'cdr artids) '<))
(gnus-override-method (gnus-find-method-for-group artgroup))
(fetch-old
(or
(car-safe
(gnus-group-find-parameter artgroup
'gnus-fetch-old-headers t))
fetch-old)))
(erase-buffer)
(pcase (setq gnus-headers-retrieved-by
(or
(and
nnselect-retrieve-headers-override-function
(funcall
nnselect-retrieve-headers-override-function
artlist artgroup))
(gnus-retrieve-headers
artlist artgroup fetch-old)))
('nov
(goto-char (point-min))
(while (not (eobp))
(nnselect-add-novitem
(nnheader-parse-nov))
(forward-line 1)))
('headers
(goto-char (point-min))
(while (not (eobp))
(nnselect-add-novitem
(nnheader-parse-head))
(forward-line 1)))
((pred listp)
(dolist (novitem gnus-headers-retrieved-by)
(nnselect-add-novitem novitem)))
(_ (error "Unknown header type %s while requesting articles \
of group %s" gnus-headers-retrieved-by artgroup)))))
(setq headers
(sort
headers
(lambda (x y)
(< (mail-header-number x) (mail-header-number y))))))))))
(deffoo nnselect-request-article (article &optional _group server to-buffer)
(let* ((gnus-override-method nil)
servers group-art artlist)
(if (numberp article)
(with-current-buffer gnus-summary-buffer
(unless (zerop (nnselect-artlist-length
gnus-newsgroup-selection))
(setq group-art (cons (nnselect-article-group article)
(nnselect-article-number article)))))
;; message-id: either coming from a referral or a pseudo-article
;; find the servers for a pseudo-article
(if (eq 'nnselect (car (gnus-server-to-method server)))
(with-current-buffer gnus-summary-buffer
(let ((thread (gnus-id-to-thread article)))
(when thread
(mapc
#'(lambda (x)
(when (and x (> x 0))
(cl-pushnew
(list
(gnus-method-to-server
(gnus-find-method-for-group
(nnselect-article-group x)))) servers :test 'equal)))
(gnus-articles-in-thread thread)))))
(setq servers (list (list server))))
(setq artlist
(nnir-run-query
(list
(cons 'nnir-query-spec
(list (cons 'query (format "HEADER Message-ID %s" article))
(cons 'criteria "") (cons 'shortcut t)))
(cons 'nnir-group-spec servers))))
(unless (zerop (nnselect-artlist-length artlist))
(setq
group-art
(cons
(nnselect-artitem-group (nnselect-artlist-article artlist 1))
(nnselect-artitem-number (nnselect-artlist-article artlist 1))))))
(when (numberp (cdr group-art))
(message "Requesting article %d from group %s"
(cdr group-art) (car group-art))
(if to-buffer
(with-current-buffer to-buffer
(let ((gnus-article-decode-hook nil))
(gnus-request-article-this-buffer
(cdr group-art) (car group-art))))
(gnus-request-article (cdr group-art) (car group-art)))
group-art)))
(deffoo nnselect-request-move-article
(article _group _server accept-form &optional last _internal-move-group)
(let* ((artgroup (nnselect-article-group article))
(artnumber (nnselect-article-number article))
(to-newsgroup (nth 1 accept-form))
(to-method (gnus-find-method-for-group to-newsgroup))
(from-method (gnus-find-method-for-group artgroup))
(move-is-internal (gnus-server-equal from-method to-method)))
(unless (gnus-check-backend-function
'request-move-article artgroup)
(error "The group %s does not support article moving" artgroup))
(gnus-request-move-article
artnumber
artgroup
(nth 1 from-method)
accept-form
last
(and move-is-internal
to-newsgroup ; Not respooling
(gnus-group-real-name to-newsgroup)))))
(deffoo nnselect-request-expire-articles
(articles _group &optional _server force)
(if force
(let (not-expired)
(pcase-dolist (`(,artgroup . ,artids) (ids-by-group articles))
(let ((artlist (sort (mapcar 'cdr artids) '<)))
(unless (gnus-check-backend-function 'request-expire-articles
artgroup)
(error "Group %s does not support article expiration" artgroup))
(unless (gnus-check-server (gnus-find-method-for-group artgroup))
(error "Couldn't open server for group %s" artgroup))
(push (mapcar #'(lambda (art)
(car (rassq art artids)))
(let ((nnimap-expunge 'immediately))
(gnus-request-expire-articles
artlist artgroup force)))
not-expired)))
(sort (delq nil not-expired) '<))
articles))
(deffoo nnselect-warp-to-article ()
(let* ((cur (if (> (gnus-summary-article-number) 0)
(gnus-summary-article-number)
(error "Can't warp to a pseudo-article")))
(artgroup (nnselect-article-group cur))
(artnumber (nnselect-article-number cur))
(_quit-config (gnus-ephemeral-group-p gnus-newsgroup-name)))
;; what should we do here? we could leave all the buffers around
;; and assume that we have to exit from them one by one. or we can
;; try to clean up directly
;;first exit from the nnselect summary buffer.
;;(gnus-summary-exit)
;; and if the nnselect summary buffer in turn came from another
;; summary buffer we have to clean that summary up too.
;;(when (not (eq (cdr quit-config) 'group))
;; (gnus-summary-exit))
(gnus-summary-read-group-1 artgroup t t nil
nil (list artnumber))))
;; we pass this through to the real group in case it wants to adjust
;; the mark. We also use this to mark an article expirable iff it is
;; expirable in the real group.
(deffoo nnselect-request-update-mark (_group article mark)
(let* ((artgroup (nnselect-article-group article))
(artnumber (nnselect-article-number article))
(gmark (gnus-request-update-mark artgroup artnumber mark)))
(when (and artnumber
(memq mark gnus-auto-expirable-marks)
(= mark gmark)
(gnus-group-auto-expirable-p artgroup))
(setq gmark gnus-expirable-mark))
gmark))
(deffoo nnselect-request-set-mark (_group actions &optional _server)
(mapc
(lambda (request) (gnus-request-set-mark (car request) (cdr request)))
(nnselect-categorize
(cl-mapcan
(lambda (act)
(cl-destructuring-bind (range action marks) act
(mapcar
(lambda (artgroup)
(list (car artgroup)
(gnus-compress-sequence (sort (cdr artgroup) '<))
action marks))
(numbers-by-group
(gnus-uncompress-range range)))))
actions)
'car 'cdr)))
(deffoo nnselect-request-update-info (group info &optional _server)
(let* ((group (nnselect-add-prefix group))
(gnus-newsgroup-selection (or gnus-newsgroup-selection
(nnselect-get-artlist group))))
(gnus-info-set-marks info nil)
(setf (gnus-info-read info) nil)
(pcase-dolist (`(,artgroup . ,nartids)
(ids-by-group
(number-sequence 1 (nnselect-artlist-length
gnus-newsgroup-selection))))
(let* ((gnus-newsgroup-active nil)
(artids (cl-sort nartids '< :key 'car))
(group-info (gnus-get-info artgroup))
(marks (gnus-info-marks group-info))
(unread (gnus-uncompress-sequence
(gnus-range-difference (gnus-active artgroup)
(gnus-info-read group-info)))))
(gnus-atomic-progn
(setf (gnus-info-read info)
(gnus-add-to-range
(gnus-info-read info)
(delq nil
(mapcar
#'(lambda (art)
(unless (memq (cdr art) unread) (car art)))
artids))))
(pcase-dolist (`(,type . ,range) marks)
(setq range (gnus-uncompress-sequence range))
(gnus-add-marked-articles
group type
(delq nil
(mapcar
#'(lambda (art)
(when (memq (cdr art) range)
(car art))) artids)))))))
(gnus-set-active group (cons 1 (nnselect-artlist-length
gnus-newsgroup-selection)))))
(deffoo nnselect-request-thread (header &optional group server)
(with-current-buffer gnus-summary-buffer
(let ((group (nnselect-add-prefix group))
;; find the best group for the originating article. if its a
;; pseudo-article look for real articles in the same thread
;; and see where they come from.
(artgroup (nnselect-article-group
(if (> (mail-header-number header) 0)
(mail-header-number header)
(if (> (gnus-summary-article-number) 0)
(gnus-summary-article-number)
(let ((thread
(gnus-id-to-thread (mail-header-id header))))
(when thread
(cl-some #'(lambda (x)
(when (and x (> x 0)) x))
(gnus-articles-in-thread thread)))))))))
;; Check if we are dealing with an imap backend.
(if (eq 'nnimap
(car (gnus-find-method-for-group artgroup)))
;; If so we perform the query, massage the result, and return
;; the new headers back to the caller to incorporate into the
;; current summary buffer.
(let* ((group-spec
(list (delq nil (list
(or server (gnus-group-server artgroup))
(unless gnus-refer-thread-use-search
artgroup)))))
(query-spec
(list (cons 'query (nnimap-make-thread-query header))
(cons 'criteria "")))
(last (nnselect-artlist-length gnus-newsgroup-selection))
(first (1+ last))
(new-nnselect-artlist
(nnir-run-query
(list (cons 'nnir-query-spec query-spec)
(cons 'nnir-group-spec group-spec))))
old-arts seq
headers)
(mapc
#'(lambda (article)
(if
(setq seq
(cl-position article
gnus-newsgroup-selection :test 'equal))
(push (1+ seq) old-arts)
(setq gnus-newsgroup-selection
(vconcat gnus-newsgroup-selection (vector article)))
(cl-incf last)))
new-nnselect-artlist)
(setq headers
(gnus-fetch-headers
(append (sort old-arts '<)
(number-sequence first last)) nil t))
(gnus-group-set-parameter
group
'nnselect-artlist
(nnselect-compress-artlist gnus-newsgroup-selection))
(when (>= last first)
(let (new-marks)
(pcase-dolist (`(,artgroup . ,artids)
(ids-by-group (number-sequence first last)))
(pcase-dolist (`(,type . ,marked)
(gnus-info-marks (gnus-get-info artgroup)))
(setq marked (gnus-uncompress-sequence marked))
(when (setq new-marks
(delq nil
(mapcar
#'(lambda (art)
(when (memq (cdr art) marked)
(car art)))
artids)))
(nconc
(symbol-value
(intern
(format "gnus-newsgroup-%s"
(car (rassq type gnus-article-mark-lists)))))
new-marks)))))
(setq gnus-newsgroup-active
(cons 1 (nnselect-artlist-length gnus-newsgroup-selection)))
(gnus-set-active
group
(cons 1 (nnselect-artlist-length gnus-newsgroup-selection))))
headers)
;; If not an imap backend just warp to the original article
;; group and punt back to gnus-summary-refer-thread.
(and (gnus-warp-to-article) (gnus-summary-refer-thread))))))
(deffoo nnselect-close-group (group &optional _server)
(let ((group (nnselect-add-prefix group)))
(unless gnus-group-is-exiting-without-update-p
(nnselect-push-info group))
(setq gnus-newsgroup-selection nil)
(when (gnus-ephemeral-group-p group)
(gnus-kill-ephemeral-group group)
(setq gnus-ephemeral-servers
(assq-delete-all 'nnselect gnus-ephemeral-servers)))))
(deffoo nnselect-request-create-group (group &optional _server args)
(message "Creating nnselect group %s" group)
(let* ((group (gnus-group-prefixed-name group '(nnselect "nnselect")))
(specs (assq 'nnselect-specs args))
(function-spec
(or (alist-get 'nnselect-function specs)
(intern (completing-read "Function: " obarray #'functionp))))
(args-spec
(or (alist-get 'nnselect-args specs)
(read-from-minibuffer "Args: " nil nil t nil "nil")))
(nnselect-specs (list (cons 'nnselect-function function-spec)
(cons 'nnselect-args args-spec))))
(gnus-group-set-parameter group 'nnselect-specs nnselect-specs)
(gnus-group-set-parameter
group 'nnselect-artlist
(nnselect-compress-artlist (or (alist-get 'nnselect-artlist args)
(nnselect-run nnselect-specs))))
(nnselect-request-update-info group (gnus-get-info group)))
t)
(deffoo nnselect-request-type (_group &optional article)
(if (and (numberp article) (> article 0))
(gnus-request-type
(nnselect-article-group article) (nnselect-article-number article))
'unknown))
(deffoo nnselect-request-post (&optional _server)
(if (not gnus-message-group-art)
(nnheader-report 'nnselect "Can't post to an nnselect group")
(gnus-request-post
(gnus-find-method-for-group
(nnselect-article-group (cdr gnus-message-group-art))))))
(deffoo nnselect-request-rename-group (_group _new-name &optional _server)
t)
(deffoo nnselect-request-scan (group _method)
(when (and group
(gnus-group-get-parameter (nnselect-add-prefix group)
'nnselect-rescan t))
(nnselect-request-group-scan group)))
(deffoo nnselect-request-group-scan (group &optional _server _info)
(let* ((group (nnselect-add-prefix group))
(artlist (nnselect-run
(gnus-group-get-parameter group 'nnselect-specs t))))
(gnus-set-active group (cons 1 (nnselect-artlist-length
artlist)))
(gnus-group-set-parameter
group 'nnselect-artlist
(nnselect-compress-artlist artlist))))
;; Add any undefined required backend functions
;; (nnoo-define-skeleton nnselect)
;;; Util Code:
(defun gnus-nnselect-group-p (group)
"Say whether GROUP is nnselect or not."
(or (and (gnus-group-prefixed-p group)
(eq 'nnselect (car (gnus-find-method-for-group group))))
(eq 'nnselect (car gnus-command-method))))
(defun nnselect-run (specs)
"Apply nnselect-function to nnselect-args from SPECS.
Return an article list."
(let ((func (alist-get 'nnselect-function specs))
(args (alist-get 'nnselect-args specs)))
(funcall func args)))
(defun nnselect-search-thread (header)
"Make an nnselect group containing the thread with article HEADER.
The current server will be searched. If the registry is
installed, the server that the registry reports the current
article came from is also searched."
(let* ((query
(list (cons 'query (nnimap-make-thread-query header))
(cons 'criteria "")))
(server
(list (list (gnus-method-to-server
(gnus-find-method-for-group gnus-newsgroup-name)))))
(registry-group (and
(bound-and-true-p gnus-registry-enabled)
(car (gnus-registry-get-id-key
(mail-header-id header) 'group))))
(registry-server
(and registry-group
(gnus-method-to-server
(gnus-find-method-for-group registry-group)))))
(when registry-server (cl-pushnew (list registry-server) server
:test 'equal))
(gnus-group-read-ephemeral-group
(concat "nnselect-" (message-unique-id))
(list 'nnselect "nnselect")
nil
(cons (current-buffer) gnus-current-window-configuration)
; nil
nil nil
(list
(cons 'nnselect-specs
(list
(cons 'nnselect-function 'nnir-run-query)
(cons 'nnselect-args
(list (cons 'nnir-query-spec query)
(cons 'nnir-group-spec server)))))
(cons 'nnselect-artlist nil)))
(gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header)))))
(defun nnselect-push-info (group)
"Copy mark-lists from GROUP to the originating groups."
(let ((select-unreads (numbers-by-group gnus-newsgroup-unreads))
(select-reads (numbers-by-group
(gnus-uncompress-range
(gnus-info-read (gnus-get-info group)))))
(select-unseen (numbers-by-group gnus-newsgroup-unseen))
(gnus-newsgroup-active nil)
mark-list type-list)
(pcase-dolist (`(,mark . ,type) gnus-article-mark-lists)
(when (setq type-list
(symbol-value (intern (format "gnus-newsgroup-%s" mark))))
(push (cons type
(numbers-by-group
(gnus-uncompress-range type-list))) mark-list)))
(pcase-dolist (`(,artgroup . ,artlist)
(numbers-by-group gnus-newsgroup-articles))
(let* ((group-info (gnus-get-info artgroup))
(old-unread (gnus-list-of-unread-articles artgroup))
newmarked)
(when group-info
(pcase-dolist (`(,_mark . ,type) gnus-article-mark-lists)
(let ((select-type
(sort
(cdr (assoc artgroup (alist-get type mark-list)))
'<)) list)
(setq list
(gnus-uncompress-range
(gnus-add-to-range
(gnus-remove-from-range
(alist-get type (gnus-info-marks group-info))
artlist)
select-type)))
(when list
;; Get rid of the entries of the articles that have the
;; default score.
(when (and (eq type 'score)
gnus-save-score
list)
(let* ((arts list)
(prev (cons nil list))
(all prev))
(while arts
(if (or (not (consp (car arts)))
(= (cdar arts) gnus-summary-default-score))
(setcdr prev (cdr arts))
(setq prev arts))
(setq arts (cdr arts)))
(setq list (cdr all)))))
(when (or (eq (gnus-article-mark-to-type type) 'list)
(eq (gnus-article-mark-to-type type) 'range))
(setq list
(gnus-compress-sequence (sort list '<) t)))
;; When exiting the group, everything that's previously been
;; unseen is now seen.
(when (eq type 'seen)
(setq list (gnus-range-add
list (cdr (assoc artgroup select-unseen)))))
(when (or list (eq type 'unexist))
(push (cons type list) newmarked))))
(gnus-atomic-progn
;; Enter these new marks into the info of the group.
(if (nthcdr 3 group-info)
(setcar (nthcdr 3 group-info) newmarked)
;; Add the marks lists to the end of the info.
(when newmarked
(setcdr (nthcdr 2 group-info) (list newmarked))))
;; Cut off the end of the info if there's nothing else there.
(let ((i 5))
(while (and (> i 2)
(not (nth i group-info)))
(when (nthcdr (cl-decf i) group-info)
(setcdr (nthcdr i group-info) nil))))
;; update read and unread
(gnus-update-read-articles
artgroup
(gnus-uncompress-range
(gnus-add-to-range
(gnus-remove-from-range
old-unread
(cdr (assoc artgroup select-reads)))
(sort (cdr (assoc artgroup select-unreads)) '<))))
(gnus-get-unread-articles-in-group
group-info (gnus-active artgroup) t)
(gnus-group-update-group artgroup t t)))))))
(declare-function gnus-registry-get-id-key "gnus-registry" (id key))
(defun gnus-summary-make-search-group (nnir-extra-parms)
"Search a group from the summary buffer.
Pass NNIR-EXTRA-PARMS on to the search engine."
(interactive "P")
(gnus-warp-to-article)
(let ((spec
(list
(cons 'nnir-group-spec
(list (list
(gnus-group-server gnus-newsgroup-name)
gnus-newsgroup-name))))))
(gnus-group-make-search-group nnir-extra-parms spec)))
;; The end.
(provide 'nnselect)
;;; nnselect.el ends here

2
lisp/gnus/nnspool.el
View file

@ -422,7 +422,7 @@ there.")
(nnspool-article-pathname nnspool-current-group article))
(nnheader-insert-article-line article)
(goto-char (point-min))
(let ((headers (nnheader-parse-head)))
(let ((headers (nnheader-parse-head nil t)))
(set-buffer cur)
(goto-char (point-max))
(nnheader-insert-nov headers)))