diff options
| -rw-r--r-- | doc/misc/gnus.texi | 259 | ||||
| -rw-r--r-- | etc/NEWS | 19 | ||||
| -rw-r--r-- | lisp/gnus/gnus-agent.el | 2 | ||||
| -rw-r--r-- | lisp/gnus/gnus-cache.el | 2 | ||||
| -rw-r--r-- | lisp/gnus/gnus-cloud.el | 10 | ||||
| -rw-r--r-- | lisp/gnus/gnus-group.el | 54 | ||||
| -rw-r--r-- | lisp/gnus/gnus-msg.el | 120 | ||||
| -rw-r--r-- | lisp/gnus/gnus-registry.el | 13 | ||||
| -rw-r--r-- | lisp/gnus/gnus-srvr.el | 5 | ||||
| -rw-r--r-- | lisp/gnus/gnus-start.el | 2 | ||||
| -rw-r--r-- | lisp/gnus/gnus-sum.el | 295 | ||||
| -rw-r--r-- | lisp/gnus/gnus.el | 7 | ||||
| -rw-r--r-- | lisp/gnus/nndiary.el | 2 | ||||
| -rw-r--r-- | lisp/gnus/nnfolder.el | 2 | ||||
| -rw-r--r-- | lisp/gnus/nnheader.el | 344 | ||||
| -rw-r--r-- | lisp/gnus/nnimap.el | 10 | ||||
| -rw-r--r-- | lisp/gnus/nnir.el | 857 | ||||
| -rw-r--r-- | lisp/gnus/nnmaildir.el | 2 | ||||
| -rw-r--r-- | lisp/gnus/nnml.el | 2 | ||||
| -rw-r--r-- | lisp/gnus/nnselect.el | 864 | ||||
| -rw-r--r-- | lisp/gnus/nnspool.el | 2 |
21 files changed, 1651 insertions, 1222 deletions
diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 0bdc2fa297d..593f113ac14 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -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. - -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}. +FIXME: A brief comparison of nnir, nnmairix, contrib/gnus-namazu would +be nice. + +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 @@ -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. diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 88873f47bd5..03e447e072a 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -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)) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index 02a8ea723d3..7ca3bf1ce1c 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -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)) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index 673a4d22988..e40b2eb418d 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -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)) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 2cbbe624602..ad6e0e30bca 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -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 diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index e770abc2cdf..7bc7fb5be41 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -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) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 1ac1d05e033..65bcd0e8a36 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -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) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 095e05408d6..8cb80b2f520 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -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 diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index fe600f107ce..e4f05de5f8e 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -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'. diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index c53f81fe026..8f37fc88284 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -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)) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 295395c79c2..4e3fc9868b4 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -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." diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 945ef0351e5..7894285bdf3 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -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)))) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index c27af1742d8..6ff99056d84 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -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))))) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index fee7a169ff9..1a50697bf5d 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -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) + +(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)) - (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 + 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) - (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))))) + (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 diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 507e12a55e7..d797e893f51 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -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) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index 722969c21ba..2ec39cf34c9 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -10,6 +10,7 @@ ;; IMAP search improved by Daniel Pittman <daniel@rimspace.net>. ;; nnmaildir support for Swish++ and Namazu backends by: ;; Justus Piater <Justus <at> Piater.name> +;; Mostly rewritten by Andrew Cohen <cohen@bu.edu> from 2010 ;; Keywords: news mail searching ir ;; This file is part of GNU Emacs. @@ -29,20 +30,11 @@ ;;; Commentary: -;; What does it do? Well, it allows you to search your mail using -;; some search engine (imap, namazu, swish-e and others -- see -;; later) by typing `G G' in the Group buffer. You will then get a -;; buffer which shows all articles matching the query, sorted by -;; Retrieval Status Value (score). - -;; When looking at the retrieval result (in the Summary buffer) you -;; can type `A W' (aka M-x gnus-warp-to-article RET) on an article. You -;; will be warped into the group this article came from. Typing `A T' -;; (aka M-x gnus-summary-refer-thread RET) will warp to the group and -;; also show the thread this article is part of. +;; What does it do? Well, it searches your mail using some search +;; engine (imap, namazu, swish-e, gmane and others -- see later). ;; The Lisp setup may involve setting a few variables and setting up the -;; search engine. You can define the variables in the server definition +;; search engine. You can define the variables in the server definition ;; like this : ;; (setq gnus-secondary-select-methods '( ;; (nnimap "" (nnimap-address "localhost") @@ -53,6 +45,45 @@ ;; an alist, type `C-h v nnir-engines RET' for more information; this ;; includes examples for setting `nnir-search-engine', too.) +;; The entry to searching is the single function `nnir-run-query', +;; which dispatches the search to the proper search function. The +;; argument of `nnir-run-query' is an alist with two keys: +;; 'nnir-query-spec and 'nnir-group-spec. The value for +;; 'nnir-query-spec is an alist. The only required key/value pair is +;; (query . "query") specifying the search string to pass to the query +;; engine. Individual engines may have other elements. The value of +;; 'nnir-group-spec is a list with the specification of the +;; groups/servers to search. The format of the 'nnir-group-spec is +;; (("server1" ("group11" "group12")) ("server2" ("group21" +;; "group22"))). If any of the group lists is absent then all groups +;; on that server are searched. + +;; The output of `nnir-run-query' is a vector, each element of which +;; should in turn be a three-element vector with the form: [fully +;; prefixed group-name of the article; the article number; the +;; Retrieval Status Value (RSV)] as returned from the search engine. +;; An RSV is the score assigned to the document by the search engine. +;; For Boolean search engines, the RSV is always 1000 (or 1 or 100, or +;; whatever you like). + +;; A vector of this form is used by the nnselect backend to create +;; virtual groups. So nnir-run-query is a suitable function to use in +;; nnselect groups. + +;; The default sorting order of articles in an nnselect summary buffer +;; is based on the order of the articles in the above mentioned +;; vector, so that's where you can do the sorting you'd like. Maybe +;; it would be nice to have a way of displaying the search result +;; sorted differently? + +;; So what do you need to do when you want to add another search +;; engine? You write a function that executes the query. Temporary +;; data from the search engine can be put in `nnir-tmp-buffer'. This +;; function should return the list of articles as a vector, as +;; described above. Then, you need to register this backend in +;; `nnir-engines'. Then, users can choose the backend by setting +;; `nnir-search-engine' as a server variable. + ;; If you use one of the local indices (namazu, find-grep, swish) you ;; must also set up a search engine backend. @@ -75,13 +106,13 @@ ;; ,---- ;; | package conf; # Don't remove this line! ;; | -;; | # Paths which will not be indexed. Don't use `^' or `$' anchors. +;; | # Paths which will not be indexed. Don't use `^' or `$' anchors. ;; | $EXCLUDE_PATH = "spam|sent"; ;; | -;; | # Header fields which should be searchable. case-insensitive +;; | # Header fields which should be searchable. case-insensitive ;; | $REMAIN_HEADER = "from|date|message-id|subject"; ;; | -;; | # Searchable fields. case-insensitive +;; | # Searchable fields. case-insensitive ;; | $SEARCH_FIELD = "from|date|message-id|subject"; ;; | ;; | # The max length of a word. @@ -121,72 +152,17 @@ ;; | (nnml-active-file "~/News/cache/active")) ;; `---- -;; Developer information: - -;; I have tried to make the code expandable. Basically, it is divided -;; into two layers. The upper layer is somewhat like the `nnvirtual' -;; backend: given a specification of what articles to show from -;; another backend, it creates a group containing exactly those -;; articles. The lower layer issues a query to a search engine and -;; produces such a specification of what articles to show from the -;; other backend. - -;; The interface between the two layers consists of the single -;; function `nnir-run-query', which dispatches the search to the -;; proper search function. The argument of `nnir-run-query' is an -;; alist with two keys: 'nnir-query-spec and 'nnir-group-spec. The -;; value for 'nnir-query-spec is an alist. The only required key/value -;; pair is (query . "query") specifying the search string to pass to -;; the query engine. Individual engines may have other elements. The -;; value of 'nnir-group-spec is a list with the specification of the -;; groups/servers to search. The format of the 'nnir-group-spec is -;; (("server1" ("group11" "group12")) ("server2" ("group21" -;; "group22"))). If any of the group lists is absent then all groups -;; on that server are searched. - -;; The output of `nnir-run-query' is supposed to be a vector, each -;; element of which should in turn be a three-element vector. The -;; first element should be full group name of the article, the second -;; element should be the article number, and the third element should -;; be the Retrieval Status Value (RSV) as returned from the search -;; engine. An RSV is the score assigned to the document by the search -;; engine. For Boolean search engines, the RSV is always 1000 (or 1 -;; or 100, or whatever you like). - -;; The sorting order of the articles in the summary buffer created by -;; nnir is based on the order of the articles in the above mentioned -;; vector, so that's where you can do the sorting you'd like. Maybe -;; it would be nice to have a way of displaying the search result -;; sorted differently? - -;; So what do you need to do when you want to add another search -;; engine? You write a function that executes the query. Temporary -;; data from the search engine can be put in `nnir-tmp-buffer'. This -;; function should return the list of articles as a vector, as -;; described above. Then, you need to register this backend in -;; `nnir-engines'. Then, users can choose the backend by setting -;; `nnir-search-engine' as a server variable. ;;; Code: ;;; Setup: -(require 'nnoo) -(require 'gnus-group) -(require 'message) -(require 'gnus-util) (eval-when-compile (require 'cl-lib)) +(require 'gnus) ;;; Internal Variables: -(defvar nnir-memo-query nil - "Internal: stores current query.") - -(defvar nnir-memo-server nil - "Internal: stores current server.") - -(defvar nnir-artlist nil - "Internal: stores search result.") +(defvar gnus-inhibit-demon) (defvar nnir-search-history () "Internal: the history for querying search options in nnir.") @@ -203,30 +179,19 @@ ("to" . "TO") ("from" . "FROM") ("body" . "BODY") - ("imap" . "")) + ("imap" . "") + ("gmail" . "X-GM-RAW")) "Mapping from user readable keys to IMAP search items for use in nnir.") (defvar nnir-imap-search-other "HEADER %S" - "The IMAP search item to use for anything other than -`nnir-imap-search-arguments'. By default this is the name of an -email header field.") + "The IMAP search item for anything other than `nnir-imap-search-arguments'. +By default this is the name of an email header field.") (defvar nnir-imap-search-argument-history () "The history for querying search options in nnir.") ;;; Helper macros -;; Data type article list. - -(defmacro nnir-artlist-length (artlist) - "Return number of articles in artlist." - `(length ,artlist)) - -(defmacro nnir-artlist-article (artlist n) - "Return from ARTLIST the Nth artitem (counting starting at 1)." - `(when (> ,n 0) - (elt ,artlist (1- ,n)))) - (defmacro nnir-artitem-group (artitem) "Return the group from the ARTITEM." `(elt ,artitem 0)) @@ -239,52 +204,6 @@ email header field.") "Return the Retrieval Status Value (RSV, score) from the ARTITEM." `(elt ,artitem 2)) -(defmacro nnir-article-group (article) - "Return the group for ARTICLE." - `(nnir-artitem-group (nnir-artlist-article nnir-artlist ,article))) - -(defmacro nnir-article-number (article) - "Return the number for ARTICLE." - `(nnir-artitem-number (nnir-artlist-article nnir-artlist ,article))) - -(defmacro nnir-article-rsv (article) - "Return the rsv for ARTICLE." - `(nnir-artitem-rsv (nnir-artlist-article nnir-artlist ,article))) - -(defsubst nnir-article-ids (article) - "Return the pair `(nnir id . real id)' of ARTICLE." - (cons article (nnir-article-number article))) - -(defmacro nnir-categorize (sequence keyfunc &optional valuefunc) - "Sort 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'. If VALUEFUNC is non-nil, the element of the list -is `(VALUEFUNC member)'." - `(unless (null ,sequence) - (let (value) - (mapc - (lambda (member) - (let ((y (,keyfunc member)) - (x ,(if valuefunc - `(,valuefunc member) - 'member))) - (if (assoc y value) - (push x (cadr (assoc y value))) - (push (list y (list x)) value)))) - ,sequence) - value))) - -;;; Finish setup: - -(require 'gnus-sum) - -(nnoo-declare nnir) -(nnoo-define-basics nnir) - -(gnus-declare-backend "nnir" 'mail 'virtual) - ;;; User Customizable Variables: @@ -293,43 +212,17 @@ is `(VALUEFUNC member)'." :group 'gnus) (defcustom nnir-ignored-newsgroups "" - "A regexp to match newsgroups in the active file that should -be skipped when searching." + "Newsgroups to skip when searching. +Any newsgroup in the active file matching this regexp will be +skipped when searching." :version "24.1" :type '(regexp) :group 'nnir) -(defcustom nnir-summary-line-format nil - "The format specification of the lines in an nnir summary buffer. - -All the items from `gnus-summary-line-format' are available, along -with three items unique to nnir summary buffers: - -%Z Search retrieval score value (integer) -%G Article original full group name (string) -%g Article original short group name (string) - -If nil this will use `gnus-summary-line-format'." - :version "24.1" - :type '(choice (const :tag "gnus-summary-line-format" nil) string) - :group 'nnir) - -(defcustom nnir-retrieve-headers-override-function nil - "If non-nil, a function that accepts an article list and group -and populates the `nntp-server-buffer' with the retrieved -headers. Must return either `nov' or `headers' indicating the -retrieved header format. - -If this variable is nil, or if the provided function returns nil for -a search result, `gnus-retrieve-headers' will be called instead." - :version "24.1" - :type '(choice (const :tag "gnus-retrieve-headers" nil) function) - :group 'nnir) - (defcustom nnir-imap-default-search-key "whole message" - "The default IMAP search key for an nnir search. Must be one of -the keys in `nnir-imap-search-arguments'. To use raw imap queries -by default set this to \"imap\"." + "The default IMAP search key for an nnir search. +Must be one of the keys in `nnir-imap-search-arguments'. To use +raw imap queries by default set this to \"imap\"." :version "24.1" :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem))) nnir-imap-search-arguments)) @@ -357,9 +250,9 @@ Instead, use this: :group 'nnir) (defcustom nnir-swish++-remove-prefix (concat (getenv "HOME") "/Mail/") - "The prefix to remove from each file name returned by swish++ -in order to get a group name (albeit with / instead of .). This is a -regular expression. + "The prefix to remove from swish++ file names to get group names. +Resulting names have '/' in place of '.'. This is a regular +expression. This variable is very similar to `nnir-namazu-remove-prefix', except that it is for swish++, not Namazu." @@ -408,9 +301,9 @@ This could be a server parameter." :group 'nnir) (defcustom nnir-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/") - "The prefix to remove from each file name returned by swish-e -in order to get a group name (albeit with / instead of .). This is a -regular expression. + "The prefix to remove from swish-e file names to get group names. +Resulting names have '/' in place of '.'. This is a regular +expression. This variable is very similar to `nnir-namazu-remove-prefix', except that it is for swish-e, not Namazu. @@ -441,8 +334,8 @@ Instead, use this: :group 'nnir) (defcustom nnir-hyrex-remove-prefix (concat (getenv "HOME") "/Mail/") - "The prefix to remove from each file name returned by HyREX -in order to get a group name (albeit with / instead of .). + "The prefix to remove from HyREX file names to get group names. +Restulting names have '/' in place of '.'. For example, suppose that HyREX returns file names such as \"/home/john/Mail/mail/misc/42\". For this example, use the following @@ -478,8 +371,8 @@ Instead, use this: :group 'nnir) (defcustom nnir-namazu-remove-prefix (concat (getenv "HOME") "/Mail/") - "The prefix to remove from each file name returned by Namazu -in order to get a group name (albeit with / instead of .). + "The prefix to remove from Namazu file names to get group names. +Resulting names have '/' in place of '.'. For example, suppose that Namazu returns file names such as \"/home/john/Mail/mail/misc/42\". For this example, use the following @@ -509,9 +402,9 @@ Instead, use this: (defcustom nnir-notmuch-remove-prefix (regexp-quote (or (getenv "MAILDIR") (expand-file-name "~/Mail"))) - "The prefix to remove from each file name returned by notmuch -in order to get a group name (albeit with / instead of .). This is a -regular expression. + "The prefix to remove from notmuch file names to get group names. +Resulting names have '/' in place of '.'. This is a regular +expression. This variable is very similar to `nnir-namazu-remove-prefix', except that it is for notmuch, not Namazu." @@ -590,347 +483,12 @@ Add an entry here when adding a new search engine.") ,@(mapcar (lambda (elem) (list 'const (car elem))) nnir-engines))))) -;; Gnus glue. - -(declare-function gnus-group-topic-name "gnus-topic" ()) -(declare-function gnus-topic-find-groups "gnus-topic" - (topic &optional level all lowest recursive)) - -(defun gnus-group-make-nnir-group (nnir-extra-parms &optional specs) - "Create an nnir group. -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") - (let* ((group-spec - (or (cdr (assq 'nnir-group-spec specs)) - (if (gnus-server-server-name) - (list (list (gnus-server-server-name))) - (nnir-categorize - (or gnus-group-marked - (if (gnus-group-group-name) - (list (gnus-group-group-name)) - (mapcar (lambda (entry) - (gnus-info-group (cadr entry))) - (gnus-topic-find-groups (gnus-group-topic-name) - nil t nil t)))) - gnus-group-server)))) - (query-spec - (or (cdr (assq 'nnir-query-spec specs)) - (apply - 'append - (list (cons 'query - (read-string "Query: " nil 'nnir-search-history))) - (when nnir-extra-parms - (mapcar - (lambda (x) - (nnir-read-parms (nnir-server-to-search-engine (car x)))) - group-spec)))))) - (gnus-group-read-ephemeral-group - (concat "nnir-" (message-unique-id)) - (list 'nnir "nnir") - nil -; (cons (current-buffer) gnus-current-window-configuration) - nil - nil nil - (list - (cons 'nnir-specs (list (cons 'nnir-query-spec query-spec) - (cons 'nnir-group-spec group-spec))) - (cons 'nnir-artlist nil))))) - -(defun gnus-summary-make-nnir-group (nnir-extra-parms) - "Search a group from the summary buffer." - (interactive "P") - (gnus-warp-to-article) - (let ((spec - (list - (cons 'nnir-group-spec - (list (list - (gnus-group-server gnus-newsgroup-name) - (list gnus-newsgroup-name))))))) - (gnus-group-make-nnir-group nnir-extra-parms spec))) - - -;; Gnus backend interface functions. - -(deffoo nnir-open-server (server &optional definitions) - ;; Just set the server variables appropriately. - (let ((backend (car (gnus-server-to-method server)))) - (if backend - (nnoo-change-server backend server definitions) - (add-hook 'gnus-summary-generate-hook 'nnir-mode) - (nnoo-change-server 'nnir server definitions)))) - -(deffoo nnir-request-group (group &optional server dont-check _info) - (nnir-possibly-change-group group server) - (let ((pgroup (gnus-group-guess-full-name-from-command-method group)) - length) - ;; Check for cached search result or run the query and cache the - ;; result. - (unless (and nnir-artlist dont-check) - (gnus-group-set-parameter - pgroup 'nnir-artlist - (setq nnir-artlist - (nnir-run-query - (gnus-group-get-parameter pgroup 'nnir-specs t)))) - (nnir-request-update-info pgroup (gnus-get-info pgroup))) - (with-current-buffer nntp-server-buffer - (if (zerop (setq length (nnir-artlist-length nnir-artlist))) - (progn - (nnir-close-group group) - (nnheader-report 'nnir "Search produced empty results.")) - (nnheader-insert "211 %d %d %d %s\n" - length ; total # - 1 ; first # - length ; last # - group)))) ; group name - nnir-artlist) - -(defvar gnus-inhibit-demon) - -(deffoo nnir-retrieve-headers (articles &optional _group _server _fetch-old) - (with-current-buffer nntp-server-buffer - (let ((gnus-inhibit-demon t) - (articles-by-group (nnir-categorize - articles nnir-article-group nnir-article-ids)) - headers) - (while (not (null articles-by-group)) - (let* ((group-articles (pop articles-by-group)) - (artgroup (car group-articles)) - (articleids (cadr group-articles)) - (artlist (sort (mapcar 'cdr articleids) '<)) - (server (gnus-group-server artgroup)) - (gnus-override-method (gnus-server-to-method server)) - parsefunc) - ;; (nnir-possibly-change-group nil server) - (erase-buffer) - (pcase (setq gnus-headers-retrieved-by - (or - (and - nnir-retrieve-headers-override-function - (funcall nnir-retrieve-headers-override-function - artlist artgroup)) - (gnus-retrieve-headers artlist artgroup nil))) - ('nov - (setq parsefunc 'nnheader-parse-nov)) - ('headers - (setq parsefunc 'nnheader-parse-head)) - (_ (error "Unknown header type %s while requesting articles \ - of group %s" gnus-headers-retrieved-by artgroup))) - (goto-char (point-min)) - (while (not (eobp)) - (let* ((novitem (funcall parsefunc)) - (artno (and novitem - (mail-header-number novitem))) - (art (car (rassq artno articleids)))) - (when art - (setf (mail-header-number novitem) art) - (push novitem headers)) - (forward-line 1))))) - (setq headers - (sort headers - (lambda (x y) - (< (mail-header-number x) (mail-header-number y))))) - (erase-buffer) - (mapc 'nnheader-insert-nov headers) - 'nov))) - -(defvar gnus-article-decode-hook) - -(deffoo nnir-request-article (article &optional group server to-buffer) - (nnir-possibly-change-group group server) - (if (and (stringp article) - (not (eq 'nnimap (car (gnus-server-to-method server))))) - (nnheader-report - 'nnir - "nnir-request-article only groks message ids for nnimap servers: %s" - server) - (save-excursion - (let ((article article) - query) - (when (stringp article) - (setq gnus-override-method (gnus-server-to-method server)) - (setq query - (list - (cons 'query (format "HEADER Message-ID %s" article)) - (cons 'criteria "") - (cons 'shortcut t))) - (unless (and nnir-artlist (equal query nnir-memo-query) - (equal server nnir-memo-server)) - (setq nnir-artlist (nnir-run-imap query server) - nnir-memo-query query - nnir-memo-server server)) - (setq article 1)) - (unless (zerop (nnir-artlist-length nnir-artlist)) - (let ((artfullgroup (nnir-article-group article)) - (artno (nnir-article-number article))) - (message "Requesting article %d from group %s" - artno artfullgroup) - (if to-buffer - (with-current-buffer to-buffer - (let ((gnus-article-decode-hook nil)) - (gnus-request-article-this-buffer artno artfullgroup))) - (gnus-request-article artno artfullgroup)) - (cons artfullgroup artno))))))) - -(deffoo nnir-request-move-article (article group server accept-form - &optional last _internal-move-group) - (nnir-possibly-change-group group server) - (let* ((artfullgroup (nnir-article-group article)) - (artno (nnir-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 artfullgroup)) - (move-is-internal (gnus-server-equal from-method to-method))) - (unless (gnus-check-backend-function - 'request-move-article artfullgroup) - (error "The group %s does not support article moving" artfullgroup)) - (gnus-request-move-article - artno - artfullgroup - (nth 1 from-method) - accept-form - last - (and move-is-internal - to-newsgroup ; Not respooling - (gnus-group-real-name to-newsgroup))))) - -(deffoo nnir-request-expire-articles (articles group &optional server force) - (nnir-possibly-change-group group server) - (if force - (let ((articles-by-group (nnir-categorize - articles nnir-article-group nnir-article-ids)) - not-deleted) - (while (not (null articles-by-group)) - (let* ((group-articles (pop articles-by-group)) - (artgroup (car group-articles)) - (articleids (cadr group-articles)) - (artlist (sort (mapcar 'cdr articleids) '<))) - (unless (gnus-check-backend-function 'request-expire-articles - artgroup) - (error "The group %s does not support article deletion" artgroup)) - (unless (gnus-check-server (gnus-find-method-for-group artgroup)) - (error "Couldn't open server for group %s" artgroup)) - (push (gnus-request-expire-articles - artlist artgroup force) - not-deleted))) - (sort (delq nil not-deleted) '<)) - articles)) - -(deffoo nnir-warp-to-article () - (nnir-possibly-change-group gnus-newsgroup-name) - (let* ((cur (if (> (gnus-summary-article-number) 0) - (gnus-summary-article-number) - (error "Can't warp to a pseudo-article"))) - (backend-article-group (nnir-article-group cur)) - (backend-article-number (nnir-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 nnir summary buffer. -; (gnus-summary-exit) - ;; and if the nnir 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 backend-article-group t t nil - nil (list backend-article-number)))) - -(deffoo nnir-request-update-mark (_group article mark) - (let ((artgroup (nnir-article-group article)) - (artnumber (nnir-article-number article))) - (or (and artgroup - artnumber - (gnus-request-update-mark artgroup artnumber mark)) - mark))) - -(deffoo nnir-request-set-mark (group actions &optional server) - (nnir-possibly-change-group group server) - (let (mlist) - (dolist (action actions) - (cl-destructuring-bind (range action marks) action - (let ((articles-by-group (nnir-categorize - (gnus-uncompress-range range) - nnir-article-group nnir-article-number))) - (dolist (artgroup articles-by-group) - (push (list - (car artgroup) - (list (gnus-compress-sequence - (sort (cadr artgroup) '<)) - action marks)) - mlist))))) - (dolist (request (nnir-categorize mlist car cadr)) - (gnus-request-set-mark (car request) (cadr request))))) - - -(deffoo nnir-request-update-info (group info &optional server) - (nnir-possibly-change-group group server) - ;; clear out all existing marks. - (setf (gnus-info-marks info) nil) - (setf (gnus-info-read info) nil) - (let ((group (gnus-group-guess-full-name-from-command-method group)) - (articles-by-group - (nnir-categorize - (gnus-uncompress-range (cons 1 (nnir-artlist-length nnir-artlist))) - nnir-article-group nnir-article-ids))) - (gnus-set-active group - (cons 1 (nnir-artlist-length nnir-artlist))) - (while (not (null articles-by-group)) - (let* ((group-articles (pop articles-by-group)) - (articleids (reverse (cadr group-articles))) - (group-info (gnus-get-info (car group-articles))) - (marks (gnus-info-marks group-info)) - (read (gnus-info-read group-info))) - (setf (gnus-info-read info) - (gnus-add-to-range - (gnus-info-read info) - (delq nil - (mapcar - #'(lambda (art) - (when (gnus-member-of-range (cdr art) read) - (car art))) - articleids)))) - (dolist (mark marks) - (cl-destructuring-bind (type . range) mark - (gnus-add-marked-articles - group type - (delq nil - (mapcar - #'(lambda (art) - (when (gnus-member-of-range (cdr art) range) (car art))) - articleids))))))))) - - -(deffoo nnir-close-group (group &optional server) - (nnir-possibly-change-group group server) - (let ((pgroup (gnus-group-guess-full-name-from-command-method group))) - (when (and nnir-artlist (not (gnus-ephemeral-group-p pgroup))) - (gnus-group-set-parameter pgroup 'nnir-artlist nnir-artlist)) - (setq nnir-artlist nil) - (when (gnus-ephemeral-group-p pgroup) - (gnus-kill-ephemeral-group pgroup) - (setq gnus-ephemeral-servers - (delq (assq 'nnir gnus-ephemeral-servers) - gnus-ephemeral-servers))))) -;; (gnus-opened-servers-remove -;; (car (assoc '(nnir "nnir-ephemeral" (nnir-address "nnir")) -;; gnus-opened-servers)))) - - - (defmacro nnir-add-result (dirnam artno score prefix server artlist) - "Ask `nnir-compose-result' to construct a result vector, -and if it is non-nil, add it to ARTLIST." + "Construct a result vector and add it to ARTLIST. +DIRNAM, ARTNO, SCORE, PREFIX and SERVER are passed to +`nnir-compose-result' to make the vector. Only add the result if +non-nil." `(let ((result (nnir-compose-result ,dirnam ,artno ,score ,prefix ,server))) (when (not (null result)) (push result ,artlist)))) @@ -940,9 +498,9 @@ and if it is non-nil, add it to ARTLIST." ;; Helper function currently used by the Swish++ and Namazu backends; ;; perhaps useful for other backends as well (defun nnir-compose-result (dirnam article score prefix server) - "Extract the group from DIRNAM, and create a result vector -ready to be added to the list of search results." - + "Construct a result vector. +The DIRNAM, ARTICLE, SCORE, PREFIX, and SERVER are used to +construct the vector entries." ;; remove nnir-*-remove-prefix from beginning of dirnam filename (when (string-match (concat "^" prefix) dirnam) (setq dirnam (replace-match "" t t dirnam))) @@ -977,13 +535,14 @@ ready to be added to the list of search results." ;; imap interface (defun nnir-run-imap (query srv &optional groups) - "Run a search against an IMAP back-end server. -This uses a custom query language parser; see `nnir-imap-make-query' -for details on the language and supported extensions." + "Run the QUERY search against an IMAP back-end server SRV. +Search GROUPS, or all active groups on SRV if GROUPS is nil. +This uses a custom query language parser; see +`nnir-imap-make-query' for details on the language and supported +extensions." (save-excursion (let ((qstring (cdr (assq 'query query))) (server (cadr (gnus-server-to-method srv))) -;; (defs (nth 2 (gnus-server-to-method srv))) (criteria (or (cdr (assq 'criteria query)) (cdr (assoc nnir-imap-default-search-key nnir-imap-search-arguments)))) @@ -995,38 +554,37 @@ for details on the language and supported extensions." (catch 'found (mapcar #'(lambda (group) - (let (artlist) - (condition-case () - (when (nnimap-change-group - (gnus-group-short-name group) server) - (with-current-buffer (nnimap-buffer) - (message "Searching %s..." group) - (let ((arts 0) - (result (nnimap-command "UID SEARCH %s" - (if (string= criteria "") - qstring - (nnir-imap-make-query - criteria qstring))))) - (mapc - (lambda (artnum) - (let ((artn (string-to-number artnum))) - (when (> artn 0) - (push (vector group artn 100) - artlist) - (when (assq 'shortcut query) - (throw 'found (list artlist))) - (setq arts (1+ arts))))) - (and (car result) - (cdr (assoc "SEARCH" (cdr result))))) - (message "Searching %s... %d matches" group arts))) - (message "Searching %s...done" group)) - (quit nil)) - (nreverse artlist))) + (let (artlist) + (condition-case () + (when (nnimap-change-group + (gnus-group-short-name group) server) + (with-current-buffer (nnimap-buffer) + (message "Searching %s..." group) + (let ((arts 0) + (result (nnimap-command "UID SEARCH %s" + (if (string= criteria "") + qstring + (nnir-imap-make-query + criteria qstring))))) + (mapc + (lambda (artnum) + (let ((artn (string-to-number artnum))) + (when (> artn 0) + (push (vector group artn 100) + artlist) + (when (assq 'shortcut query) + (throw 'found (list artlist))) + (setq arts (1+ arts))))) + (and (car result) + (cdr (assoc "SEARCH" (cdr result))))) + (message "Searching %s... %d matches" group arts))) + (message "Searching %s...done" group)) + (quit nil)) + (nreverse artlist))) groups)))))) (defun nnir-imap-make-query (criteria qstring) - "Parse the query string and criteria into an appropriate IMAP search -expression, returning the string query to make. + "Make an IMAP search expression from QSTRING and CRITERIA. This implements a little language designed to return the expected results to an arbitrary query string to the end user. @@ -1063,7 +621,7 @@ In the future the following will be added to the language: (defun nnir-imap-query-to-imap (criteria query) - "Turn an s-expression format QUERY into IMAP." + "Turn an s-expression format QUERY with CRITERIA into IMAP." (mapconcat ;; Turn the expressions into IMAP text (lambda (item) @@ -1099,8 +657,9 @@ In the future the following will be added to the language: (defun nnir-imap-parse-query (string) - "Turn STRING into an s-expression based query based on the IMAP -query language as defined in `nnir-imap-make-query'. + "Turn STRING into an s-expression query. +STRING is based on the IMAP query language as defined in +`nnir-imap-make-query'. This involves turning individual tokens into higher level terms that the search language can then understand and use." @@ -1116,7 +675,7 @@ that the search language can then understand and use." (defun nnir-imap-next-expr (&optional count) - "Return the next expression from the current buffer." + "Return the next (COUNT) expression from the current buffer." (let ((term (nnir-imap-next-term count)) (next (nnir-imap-peek-symbol))) ;; Are we looking at an 'or' expression? @@ -1129,7 +688,7 @@ that the search language can then understand and use." (defun nnir-imap-next-term (&optional count) - "Return the next term from the current buffer." + "Return the next (COUNT) term from the current buffer." (let ((term (nnir-imap-next-symbol count))) ;; What sort of term is this? (cond @@ -1147,9 +706,10 @@ that the search language can then understand and use." (nnir-imap-next-symbol))) (defun nnir-imap-next-symbol (&optional count) - "Return the next symbol from the current buffer, or nil if we are -at the end of the buffer. If supplied COUNT skips some symbols before -returning the one at the supplied position." + "Return the next (COUNT) symbol from the current buffer. +Return nil if we are at the end of the buffer. If supplied COUNT +skips some symbols before returning the one at the supplied +position." (when (and (numberp count) (> count 1)) (nnir-imap-next-symbol (1- count))) (let ((case-fold-search t)) @@ -1180,7 +740,7 @@ returning the one at the supplied position." (buffer-substring start end))))))) (defun nnir-imap-delimited-string (delimiter) - "Return a delimited string from the current buffer." + "Return a string delimited by DELIMITER from the current buffer." (let ((start (point)) end) (forward-char 1) ; skip the first delimiter. (while (not end) @@ -1207,7 +767,7 @@ returning the one at the supplied position." ;; - file size ;; - group (defun nnir-run-swish++ (query server &optional _group) - "Run QUERY against swish++. + "Run QUERY on SERVER against swish++. Returns a vector of (group name, file name) pairs (also vectors, actually). @@ -1297,7 +857,7 @@ Windows NT 4.0." ;; Swish-E interface. (defun nnir-run-swish-e (query server &optional _group) - "Run given QUERY against swish-e. + "Run given QUERY on SERVER against swish-e. Returns a vector of (group name, file name) pairs (also vectors, actually). @@ -1392,6 +952,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." ;; HyREX interface (defun nnir-run-hyrex (query server &optional group) + "Run given QUERY with GROUP on SERVER against hyrex." (save-excursion (let ((artlist nil) (groupspec (cdr (assq 'hyrex-group query))) @@ -1463,7 +1024,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." ;; Namazu interface (defun nnir-run-namazu (query server &optional _group) - "Run given QUERY against Namazu. + "Run QUERY on SERVER against Namazu. Returns a vector of (group name, file name) pairs (also vectors, actually). @@ -1533,7 +1094,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (nnir-artitem-rsv y))))))))) (defun nnir-run-notmuch (query server &optional groups) - "Run QUERY against notmuch. + "Run QUERY with GROUPS from SERVER against notmuch. Returns a vector of (group name, file name) pairs (also vectors, actually). If GROUPS is a list of group names, use them to construct path: search terms (see the variable @@ -1617,7 +1178,7 @@ construct path: search terms (see the variable artlist))) (defun nnir-run-find-grep (query server &optional grouplist) - "Run find and grep to obtain matching articles." + "Run find and grep to QUERY GROUPLIST on SERVER for matching articles." (let* ((method (gnus-server-to-method server)) (sym (intern (concat (symbol-name (car method)) "-directory"))) @@ -1703,14 +1264,10 @@ construct path: search terms (see the variable ;;; Util Code: -(defun gnus-nnir-group-p (group) - "Say whether GROUP is nnir or not." - (if (gnus-group-prefixed-p group) - (eq 'nnir (car (gnus-find-method-for-group group))) - (and group (string-match "^nnir" group)))) (defun nnir-read-parms (nnir-search-engine) - "Read additional search parameters according to `nnir-engines'." + "Read additional search parameters for NNIR-SEARCH-ENGINE. +Parameters are according to `nnir-engines'." (let ((parmspec (nth 2 (assoc nnir-search-engine nnir-engines)))) (mapcar #'nnir-read-parm parmspec))) @@ -1727,7 +1284,7 @@ PARMSPEC is a cons cell, the car is a symbol, the cdr is a prompt." (cons sym (read-string prompt))))) (defun nnir-run-query (specs) - "Invoke appropriate search engine function (see `nnir-engines')." + "Invoke search engine appropriate for SPECS (see `nnir-engines')." (apply #'vconcat (mapcar (lambda (x) @@ -1736,10 +1293,11 @@ PARMSPEC is a cons cell, the car is a symbol, the cdr is a prompt." (search-func (cadr (assoc search-engine nnir-engines)))) (and search-func (funcall search-func (cdr (assq 'nnir-query-spec specs)) - server (cadr x))))) + server (cdr x))))) (cdr (assq 'nnir-group-spec specs))))) (defun nnir-server-to-search-engine (server) + "Find search engine for SERVER." (or (nnir-read-server-parm 'nnir-search-engine server t) (cdr (assoc (car (gnus-server-to-method server)) nnir-method-default-engines)))) @@ -1754,48 +1312,10 @@ environment unless NOT-GLOBAL is non-nil." ((and (not not-global) (boundp key)) (symbol-value key)) (t nil)))) -(defun nnir-possibly-change-group (group &optional server) - (or (not server) (nnir-server-opened server) (nnir-open-server server)) - (when (gnus-nnir-group-p group) - (setq nnir-artlist (gnus-group-get-parameter - (gnus-group-prefixed-name - (gnus-group-short-name group) '(nnir "nnir")) - 'nnir-artlist t)))) - -(defun nnir-server-opened (&optional server) - (let ((backend (car (gnus-server-to-method server)))) - (nnoo-current-server-p (or backend 'nnir) server))) - -(autoload 'nnimap-make-thread-query "nnimap") -(declare-function gnus-registry-get-id-key "gnus-registry" (id key)) - -(defun nnir-search-thread (header) - "Make an nnir group based on the thread containing the 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-make-nnir-group nil (list - (cons 'nnir-query-spec query) - (cons 'nnir-group-spec server))) - (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header))))) +(autoload 'gnus-request-list "gnus-int") (defun nnir-get-active (srv) + "Return the active list for SRV." (let ((method (gnus-server-to-method srv)) groups) (gnus-request-list method) @@ -1835,82 +1355,37 @@ is also searched." (forward-line))))) groups)) -;; Behind gnus-registry-enabled test. -(declare-function gnus-registry-action "gnus-registry" - (action data-header from &optional to method)) - -(defun nnir-registry-action (action data-header _from &optional to method) - "Call `gnus-registry-action' with the original article group." - (gnus-registry-action - action - data-header - (nnir-article-group (mail-header-number data-header)) - to - method)) - -(defun nnir-mode () - (when (eq (car (gnus-find-method-for-group gnus-newsgroup-name)) 'nnir) - (when (and nnir-summary-line-format - (not (string= nnir-summary-line-format - gnus-summary-line-format))) - (setq gnus-summary-line-format nnir-summary-line-format) - (gnus-update-format-specifications nil 'summary)) - (when (bound-and-true-p gnus-registry-enabled) - (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action t) - (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action t) - (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action t) - (add-hook 'gnus-summary-article-delete-hook 'nnir-registry-action t t) - (add-hook 'gnus-summary-article-move-hook 'nnir-registry-action t t) - (add-hook 'gnus-summary-article-expire-hook 'nnir-registry-action t t)))) - - -(defun gnus-summary-create-nnir-group () - (interactive) - (or (nnir-server-opened "") (nnir-open-server "nnir")) - (let ((name (gnus-read-group "Group name: ")) - (method '(nnir "")) - (pgroup - (gnus-group-guess-full-name-from-command-method gnus-newsgroup-name))) - (with-current-buffer gnus-group-buffer - (gnus-group-make-group - name method nil - (gnus-group-find-parameter pgroup))))) - - -(deffoo nnir-request-create-group (group &optional _server args) - (message "Creating nnir group %s" group) - (let* ((group (gnus-group-prefixed-name group '(nnir "nnir"))) - (specs (assq 'nnir-specs args)) - (query-spec - (or (cdr (assq 'nnir-query-spec specs)) - (list (cons 'query - (read-string "Query: " nil 'nnir-search-history))))) - (group-spec - (or (cdr (assq 'nnir-group-spec specs)) - (list (list (read-string "Server: " nil nil))))) - (nnir-specs (list (cons 'nnir-query-spec query-spec) - (cons 'nnir-group-spec group-spec)))) - (gnus-group-set-parameter group 'nnir-specs nnir-specs) - (gnus-group-set-parameter - group 'nnir-artlist - (or (cdr (assq 'nnir-artlist args)) - (nnir-run-query nnir-specs))) - (nnir-request-update-info group (gnus-get-info group))) - t) - -(deffoo nnir-request-delete-group (_group &optional _force _server) - t) - -(deffoo nnir-request-list (&optional _server) - t) - -(deffoo nnir-request-scan (_group _method) - t) - -(deffoo nnir-request-close () - t) - -(nnoo-define-skeleton nnir) +(autoload 'nnselect-categorize "nnselect" nil nil) +(autoload 'gnus-group-topic-name "gnus-topic" nil nil) +(defvar gnus-group-marked) +(defvar gnus-topic-alist) + +(defun nnir-make-specs (nnir-extra-parms &optional specs) + "Make the query-spec and group-spec for a search with NNIR-EXTRA-PARMS. +Query for the specs, or use SPECS." + (let* ((group-spec + (or (cdr (assq 'nnir-group-spec specs)) + (if (gnus-server-server-name) + (list (list (gnus-server-server-name))) + (nnselect-categorize + (or gnus-group-marked + (if (gnus-group-group-name) + (list (gnus-group-group-name)) + (cdr (assoc (gnus-group-topic-name) gnus-topic-alist)))) + 'nnselect-group-server)))) + (query-spec + (or (cdr (assq 'nnir-query-spec specs)) + (apply + 'append + (list (cons 'query + (read-string "Query: " nil 'nnir-search-history))) + (when nnir-extra-parms + (mapcar + (lambda (x) + (nnir-read-parms (nnir-server-to-search-engine (car x)))) + group-spec)))))) + (list (cons 'nnir-query-spec query-spec) + (cons 'nnir-group-spec group-spec)))) ;; The end. (provide 'nnir) diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 9c7b1254413..81a148db669 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -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)) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index baf5d54b74d..ad608b6575e 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -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)))) diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el new file mode 100644 index 00000000000..460bc63132c --- /dev/null +++ b/lisp/gnus/nnselect.el @@ -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 diff --git a/lisp/gnus/nnspool.el b/lisp/gnus/nnspool.el index 33b68fa989e..0b6bba5fea7 100644 --- a/lisp/gnus/nnspool.el +++ b/lisp/gnus/nnspool.el @@ -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))) |