commit a6b45145824043eb0c049270ef37e64f1a677b4e (HEAD, refs/remotes/origin/master) Author: Michael Albinus Date: Sat Sep 5 10:21:35 2020 +0200 ; Fix typos in etc/NEWS diff --git a/etc/NEWS b/etc/NEWS index da3928d6e4..749b28ac3f 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -317,24 +317,24 @@ tags to be considered as well. ** Gnus +++ -*** New backend 'nnselect' -The newly added nnselect backend allows creating groups from an +*** 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 +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, +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 +'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 +this addition, the user option '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-summary-line-format' '%G' and '%g' specs. The user option +'gnus-refer-thread-use-nnir' has been renamed to 'gnus-refer-thread-use-search'. +++ -*** New user option 'gnus-dbus-close-on-sleep' +*** 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. commit ecfc13e41627511769e00a2d0a7568d5bdbe8a0d Author: Andrew G Cohen Date: Sat Sep 5 08:46:43 2020 +0800 Introduce nnselect backend for gnus This new backend allows gnus to handle arbitrary sets of messages spanning multiple groups, even when these groups are from different backends and different servers. All gnus glue is removed from nnir (leaving only the backend search functions) and gnus search-related processing is done through nnselect. In appropriate places 'nnir' has been replaced by 'nnselect' or 'search'. * etc/NEWS: Document the change. * doc/misc/gnus.texi: New documentation for nnselect and update searching and thread-referral sections. * lisp/gnus/nnselect.el: New file. * lisp/gnus/nnir.el: Remove all gnus glue, leaving only searching capability. Improve documentation strings. * lisp/gnus/gnus-group.el (gnus-group-read-ephemeral-search-group, gnus-group-make-search-group): New functions. * lisp/gnus/gnus-msg.el (gnus-setup-message, gnus-group-news, gnus-summary-news-other-window): Update to work for nnselect. Fix gnus-newsgroup-name wrangling. *lisp/gnus/gnus-registry.el (gnus-registry-action,gnus-registry-ignore-group-p): Make work from nnselect. * lisp/gnus/nnheader.el (nnheader-parse-head, nnheader-parse-nov): Rework and consolidate header parsing. * lisp/gnus/gnus-agent.el (gnus-agent-regenerate-group): * lisp/gnus/gnus-cache.el (gnus-possibly-enter-article): * lisp/gnus/gnus-cloud.el (gnus-cloud-available-chunks): * lisp/gnus/gnus-msg.el (gnus-inews-yank-articles): * lisp/gnus/gnus-sum. (gnus-get-newsgroup-headers): * lisp/gnus/nndiary.el (nndiary-parse-head): * lisp/gnus/nnfolder.el (nnfolder-parse-head): * lisp/gnus/nnmaildir.el (nnmaildir--update-nov): * lisp/gnus/nnml.el (nnml-parse-head): * lisp/gnus/nnspool.el (nnspool-insert-nov-head): Use new header parsing. * lisp/gnus/gnus-start.el (gnus-read-active-for-groups): Rescan on activation by default. * lisp/gnus/gnus-sum.el (gnus-summary-line-format-alist): New specs for virtual groups. (gnus-article-sort-by-rsv, gnus-thread-sort-by-rsv): New functions to allow sorting by search RSV. diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 0bdc2fa297..593f113ac1 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 diff --git a/etc/NEWS b/etc/NEWS index e0ea8f53cc..da3928d6e4 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -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 88873f47bd..03e447e072 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 02a8ea723d..7ca3bf1ce1 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 673a4d2298..e40b2eb418 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 2cbbe62460..ad6e0e30bc 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 e770abc2cd..7bc7fb5be4 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 1ac1d05e03..65bcd0e8a3 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 095e05408d..8cb80b2f52 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 fe600f107c..e4f05de5f8 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 c53f81fe02..8f37fc8828 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 295395c79c..4e3fc9868b 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 945ef0351e..7894285bdf 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 c27af1742d..6ff99056d8 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 fee7a169ff..1a50697bf5 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 507e12a55e..d797e893f5 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 722969c21b..2ec39cf34c 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -10,6 +10,7 @@ ;; IMAP search improved by Daniel Pittman . ;; nnmaildir support for Swish++ and Namazu backends by: ;; Justus Piater Piater.name> +;; Mostly rewritten by Andrew Cohen 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 9c7b125441..81a148db66 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 baf5d54b74..ad608b6575 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 0000000000..460bc63132 --- /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 +;; 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 . + +;;; 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 33b68fa989..0b6bba5fea 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))) commit f450798cb0b9bedfa73efff14605a04eec4f1d9e Author: Andrii Kolomoiets Date: Thu Sep 3 22:13:36 2020 +0300 Don't move point in vc-dir on vc-register/vc-checkin (bug#43188) * lisp/vc/vc-dir.el (vc-dir-update): Save and restore point on 'ewoc-invalidate'. * lisp/vc/vc-dispatcher.el (vc-finish-logentry): Don't call 'vc-dir-move-to-goal-column'. * lisp/vc/vc.el (vc-register): Don't call 'vc-dir-move-to-goal-column'. diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index cdf8ab984e..6c219005ce 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -451,7 +451,11 @@ If NOINSERT, ignore elements on ENTRIES which are not in the ewoc." (setf (vc-dir-fileinfo->state (ewoc-data node)) (nth 1 entry)) (setf (vc-dir-fileinfo->extra (ewoc-data node)) (nth 2 entry)) (setf (vc-dir-fileinfo->needs-update (ewoc-data node)) nil) - (ewoc-invalidate vc-ewoc node)) + ;; `ewoc-invalidate' will kill line and insert new text, + ;; let's keep point column. + (let ((p (point))) + (ewoc-invalidate vc-ewoc node) + (goto-char p))) ;; If the state is nil, the file does not exist ;; anymore, so remember the entry so we can remove ;; it after we are done inserting all ENTRIES. diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index 4a04c9365a..99bf5bf9b6 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -691,7 +691,6 @@ BACKEND, if non-nil, specifies a VC backend for the Log Edit buffer." (message "%s Type C-c C-c when done" msg) (vc-finish-logentry (eq comment t))))) -(declare-function vc-dir-move-to-goal-column "vc-dir" ()) ;; vc-finish-logentry is typically called from a log-edit buffer (see ;; vc-start-logentry). (defun vc-finish-logentry (&optional nocomment) @@ -740,8 +739,6 @@ the buffer contents as a comment." (mapc (lambda (file) (vc-resynch-buffer file t t)) log-fileset)) - (when (vc-dispatcher-browsing) - (vc-dir-move-to-goal-column)) (run-hooks after-hook 'vc-finish-logentry-hook))) (defun vc-dispatcher-browsing () diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 5561292d8c..f0a08044e2 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -1346,8 +1346,6 @@ For old-style locking-based version control systems, like RCS: nil t))))) (vc-call-backend backend 'create-repo)) -(declare-function vc-dir-move-to-goal-column "vc-dir" ()) - ;;;###autoload (defun vc-register (&optional vc-fileset comment) "Register into a version control system. @@ -1398,8 +1396,6 @@ first backend that could register the file is used." (vc-resynch-buffer file t t)) files) - (when (derived-mode-p 'vc-dir-mode) - (vc-dir-move-to-goal-column)) (message "Registering %s... done" files))) (defun vc-register-with (backend) commit 9e5fd29bede00905d7ff95ea213c2e2f47944e61 Author: Lars Ingebrigtsen Date: Fri Sep 4 15:50:48 2020 +0200 Fix previous manual mis-merge of dired-aux * lisp/dired-aux.el (dired-rename-file): Fix manual mis-merge of previous patch. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index eeb06beafd..82f4455392 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1689,7 +1689,8 @@ unless OK-IF-ALREADY-EXISTS is non-nil." (set-visited-file-name newname nil t))) (dired-remove-file file) ;; See if it's an inserted subdir, and rename that, too. - (dired-rename-subdir file newname)) + (when (file-directory-p file) + (dired-rename-subdir file newname))) (defun dired-rename-subdir (from-dir to-dir) (setq from-dir (file-name-as-directory from-dir) commit 9e5db99d3183a849c67ef3dd1c7d3adb0aa3b4b7 Author: Lars Ingebrigtsen Date: Fri Sep 4 15:46:19 2020 +0200 Fix up previous LAMDA->LAMBDA patch * lisp/international/mule-cmds.el (ucs-names): Ensure we're only matching LAMDA as a word. Noted by Stefan Monnier. diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index e49d1fa91e..75d1c611e6 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -3017,7 +3017,7 @@ on encoding." ;; spelling, but others don't. Add the traditional ;; spelling for more convenient completion. (when (and (not old-name) new-name - (string-match "LAMDA" new-name)) + (string-match "\\" new-name)) (puthash (replace-match "LAMBDA" t t new-name) c names)) (setq c (1+ c)))))) ;; Special case for "BELL" which is apparently the only char which commit 6dcfabea97f54c0d875b89b403a4669bfe483211 Author: Mauro Aranda Date: Fri Sep 4 15:35:41 2020 +0200 Do not remove unbound variables or faces when modifying a custom-theme * lisp/cus-theme.el (custom-theme-write-variables custom-theme-write-faces): Remove check for a bound symbol or for a face name, so saving a theme does not remove not yet defined variables or faces (bug#24727). diff --git a/lisp/cus-theme.el b/lisp/cus-theme.el index b0decfe7b7..dc463e05f9 100644 --- a/lisp/cus-theme.el +++ b/lisp/cus-theme.el @@ -419,14 +419,13 @@ It includes all variables in list VARS." (widget-value child) ;; Child is null if the widget is closed (hidden). (car (widget-get widget :shown-value))))) - (when (boundp symbol) - (unless (bolp) - (princ "\n")) - (princ " '(") - (prin1 symbol) - (princ " ") - (prin1 (custom-quote value)) - (princ ")"))))) + (unless (bolp) + (princ "\n")) + (princ " '(") + (prin1 symbol) + (princ " ") + (prin1 (custom-quote value)) + (princ ")")))) (if (bolp) (princ " ")) (princ ")") @@ -454,7 +453,7 @@ It includes all faces in list FACES." ;; Child is null if the widget is closed (hidden). ((widget-get widget :shown-value)) (t (custom-face-get-current-spec symbol))))) - (when (and (facep symbol) value) + (when value (princ (if (bolp) " '(" "\n '(")) (prin1 symbol) (princ " ") commit 93d8ee1d6b2de28396e35ae9687f4bf66d19c5a7 Author: Michael Albinus Date: Fri Sep 4 15:09:22 2020 +0200 * etc/NEWS: Add changes for D-Bus; fix typos. diff --git a/etc/NEWS b/etc/NEWS index e88eaa7167..e0ea8f53cc 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -43,7 +43,7 @@ still a valid backend. --- ** Building without double buffering support. -configure --with-xdbe=no can now be used to disable double buffering +'configure --with-xdbe=no' can now be used to disable double buffering at build time. --- @@ -99,14 +99,14 @@ box if the point is on an image larger than 'SIZE' pixels in any dimension. +++ -** New custom option 'word-wrap-by-category'. +** New user option 'word-wrap-by-category'. When word-wrap is enabled, and this option is non-nil, that allows Emacs to break lines after more characters than just whitespace characters. In particular, this significantly improves word-wrapping for CJK text mixed with Latin text. --- -*** Improved language transliteration in Malayalam input methods. +** Improved language transliteration in Malayalam input methods. Added a new Mozhi scheme. The inapplicable ITRANS scheme is now deprecated. Errors in the Inscript method were corrected. @@ -176,8 +176,10 @@ it is still logged to the *Messages* buffer), or the warning can be disabled entirely. ** mspool.el + --- -*** Autoload the main entry point 'mspool-show' +*** Autoload the main entry point 'mspool-show'. + ** Windows *** The key prefix 'C-x 4 1' displays next command buffer in the same window. @@ -307,7 +309,7 @@ invoke 'C-u C-x v s' ('vc-create-tag'). *** 'vc-hg' now uses 'hg summary' to populate extra 'vc-dir' headers. --- -*** New variable 'vc-git-revision-complete-only-branches'. +*** New user option 'vc-git-revision-complete-only-branches'. If non-nil, only branches and remotes are considered when doing completion over Git branch names. The default is nil, which causes tags to be considered as well. @@ -315,7 +317,7 @@ tags to be considered as well. ** Gnus +++ -*** New option 'gnus-dbus-close-on-sleep' +*** 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. @@ -390,7 +392,6 @@ In Message mode buffers, the 'C-c C-p' ('message-insert-screenshot') command has been added. It depends on using an external program to take the actual screenshot, and defaults to "ImageMagick import". - ** Smtpmail +++ @@ -918,17 +919,16 @@ based on the current window size. In previous versions of Emacs, this was always done (and that could lead to odd displays when resizing the window after starting). This variable defaults to nil. - ** Miscellaneous +++ -*** The user can now customize how \"default\" values are prompted for. +*** The user can now customize how "default" values are prompted for. The new utility function 'format-prompt' has been added which uses the -new 'minibuffer-default-prompt-format' variable to format \"default\" +new 'minibuffer-default-prompt-format' user option to format "default" prompts. This means that prompts that look like "Enter a number (default 10)" can be customized to look like, for instance, "Enter a number [10]", or not have the default displayed at all, like "Enter a -number". (This requires that all callers are altered to user +number". (This requires that all callers are altered to use 'format-prompt', though.) --- @@ -936,7 +936,7 @@ number". (This requires that all callers are altered to user This face is used for error messages from diff. +++ -*** New global mode 'global-goto-address-mode' +*** New global mode 'global-goto-address-mode'. This will enable 'goto-address-mode' in all buffers. --- @@ -987,7 +987,6 @@ never be narrower than 19 characters. When the bookmark.el library is loaded, a customize choice is added to 'tab-bar-new-tab-choice' for new tabs to show the bookmark list. - ** xwidget-webkit mode *** New xwidget functions. @@ -1045,6 +1044,14 @@ The following user options have been renamed: The old names are now obsolete. +** D-Bus + ++++ +*** Registered properties can have the new access type ':write'. + ++++ +*** In case of problems, handlers can emit proper D-Bus error messages now. + * New Modes and Packages in Emacs 28.1 @@ -1134,12 +1141,12 @@ ledit.el, lmenu.el, lucid.el and old-whitespace.el. 'allout-init', 'bookmark-jump-noselect', 'bookmark-read-annotation-text-func', 'buffer-menu-mode-hook', 'c-forward-into-nomenclature', 'char-coding-system-table', -'char-valid-p', 'charset-bytes', 'charset-id', 'charset-list' -(function), 'choose-completion-delete-max-match', 'complete-in-turn', +'char-valid-p', 'charset-bytes', 'charset-id', 'charset-list', +'choose-completion-delete-max-match', 'complete-in-turn', 'completion-base-size', 'completion-common-substring', 'crm-minibuffer-complete', 'crm-minibuffer-complete-and-exit', 'crm-minibuffer-completion-help', 'custom-mode', 'custom-mode-hook', -'detect-coding-with-priority', 'dirtrack-debug' (function), +'detect-coding-with-priority', 'dirtrack-debug', 'dirtrack-debug-toggle', 'dynamic-completion-table', 'easy-menu-precalculate-equivalent-keybindings', 'epa-display-verify-result', 'epg-passphrase-callback-function', @@ -1159,10 +1166,9 @@ ledit.el, lmenu.el, lucid.el and old-whitespace.el. 'nonascii-translation-table', 'password-read-and-add', 'pre-abbrev-expand-hook', 'princ-list', 'print-help-return-message', 'process-filter-multibyte-p', 'read-file-name-predicate', -'remember-buffer' (function), 'rmail-highlight-face', -'rmail-message-filter', 'set-coding-priority', -'set-process-filter-multibyte', 'shadows-compare-text-p', -'shell-dirtrack-toggle', 't-mouse-mode', +'remember-buffer', 'rmail-highlight-face', 'rmail-message-filter', +'set-coding-priority', 'set-process-filter-multibyte', +'shadows-compare-text-p', 'shell-dirtrack-toggle', 't-mouse-mode', 'term-dynamic-simple-complete', 'tooltip-hook', 'tpu-have-ispell', 'url-generate-unique-filename', 'url-temporary-directory', 'vc-arch-command', 'vc-default-working-revision' (variable), commit a418b0a92090624e2c7beea3681f0a179ade837a Author: Michael Albinus Date: Fri Sep 4 15:09:08 2020 +0200 Extend dbus.el by error messages, and :write access type * doc/misc/dbus.texi (Receiving Method Calls): Describe how to produce D-Bus error messages. (Receiving Method Calls): Support :write access type. * lisp/net/dbus.el (dbus-error-dbus, dbus-error-failed) (dbus-error-access-denied, dbus-error-invalid-args) (dbus-error-property-read-only): New defconsts. (dbus-method-error-internal): Add arg ERROR-NAME. (dbus-register-method): Adapt docstring. (dbus-handle-event): Handle error messages returned from the handler. (dbus-get-this-registered-property) (dbus-get-other-registered-property): New defuns. (dbus-register-property): Support :write access type. (dbus-property-handler): Submit proper D-Bus error messages. Handle several paths at the same interface. * src/dbusbind.c (Fdbus_message_internal): Improve handling of DBUS_MESSAGE_TYPE_ERROR. diff --git a/doc/misc/dbus.texi b/doc/misc/dbus.texi index 167d2bd5ac..c16b7aa915 100644 --- a/doc/misc/dbus.texi +++ b/doc/misc/dbus.texi @@ -1462,7 +1462,15 @@ cons cell, @var{handler} can return this object directly, instead of returning a list containing the object. If @var{handler} returns a reply message with an empty argument list, -@var{handler} must return the symbol @code{:ignore}. +@var{handler} must return the symbol @code{:ignore} in order +to distinguish it from @code{nil} (the boolean false). + +If @var{handler} detects an error, it shall return the list +@code{(:error @var{ERROR-NAME} @var{ERROR-MESSAGE)}}. +@var{ERROR-NAME} is a namespaced string which characterizes the error +type, and @var{ERROR-MESSAGE} is a free text string. Alternatively, +any Emacs signal @code{dbus-error} in @var{handler} raises a D-Bus +error message with the error name @samp{org.freedesktop.DBus.Error.Failed}. When @var{dont-register-service} is non-@code{nil}, the known name @var{service} is not registered. This means that other D-Bus clients @@ -1512,17 +1520,20 @@ could use the command line tool @code{dbus-send} in a shell: boolean true @end example -You can indicate an error by raising the Emacs signal -@code{dbus-error}. The handler above could be changed like this: +You can indicate an error by returning an @code{:error} list reply, or +by raising the Emacs signal @code{dbus-error}. The handler above +could be changed like this: @lisp (defun my-dbus-method-handler (&rest args) - (unless (and (= (length args) 1) (stringp (car args))) - (signal 'dbus-error (list (format "Wrong argument list: %S" args)))) - (condition-case err - (find-file (car args)) - (error (signal 'dbus-error (cdr err)))) - t) + (if (not (and (= (length args) 1) (stringp (car args)))) + (list :error + "org.freedesktop.TextEditor.Error.InvalidArgs" + (format "Wrong argument list: %S" args)) + (condition-case err + (find-file (car args)) + (error (signal 'dbus-error (cdr err)))) + t)) @end lisp The test then runs @@ -1534,9 +1545,20 @@ The test then runs "org.freedesktop.TextEditor.OpenFile" \ string:"/etc/hosts" string:"/etc/passwd" -@print{} Error org.freedesktop.DBus.Error.Failed: +@print{} Error org.freedesktop.TextEditor.Error.InvalidArgs: Wrong argument list: ("/etc/hosts" "/etc/passwd") @end example + +@example +# dbus-send --session --print-reply \ + --dest="org.freedesktop.TextEditor" \ + "/org/freedesktop/TextEditor" \ + "org.freedesktop.TextEditor.OpenFile" \ + string:"/etc/crypttab" + +@print{} Error org.freedesktop.DBus.Error.Failed: + D-Bus error: "File is not readable", "/etc/crypttab" +@end example @end defun @defun dbus-register-property bus service path interface property access value &optional emits-signal dont-register-service @@ -1556,14 +1578,16 @@ discussion of @var{dont-register-service} below). @var{property} is the name of the property of @var{interface}. @var{access} indicates, whether the property can be changed by other -services via D-Bus. It must be either the symbol @code{:read} or -@code{:readwrite}. @var{value} is the initial value of the property, -it can be of any valid type (@xref{dbus-call-method}, for details). +services via D-Bus. It must be either the symbol @code{:read}, +@code{:write} or @code{:readwrite}. @var{value} is the initial value +of the property, it can be of any valid type (@xref{dbus-call-method}, +for details). If @var{property} already exists on @var{path}, it will be overwritten. For properties with access type @code{:read} this is the only way to change their values. Properties with access type -@code{:readwrite} can be changed by @code{dbus-set-property}. +@code{:write} or @code{:readwrite} can be changed by +@code{dbus-set-property}. The interface @samp{org.freedesktop.DBus.Properties} is added to @var{path}, including a default handler for the @samp{Get}, diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 971d3e730e..639b766d42 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -53,6 +53,8 @@ (require 'xml) +;;; D-Bus constants. + (defconst dbus-service-dbus "org.freedesktop.DBus" "The bus name used to talk to the bus itself.") @@ -62,7 +64,8 @@ (defconst dbus-path-local (concat dbus-path-dbus "/Local") "The object path used in local/in-process-generated messages.") -;; Default D-Bus interfaces. + +;;; Default D-Bus interfaces. (defconst dbus-interface-dbus "org.freedesktop.DBus" "The interface exported by the service `dbus-service-dbus'.") @@ -145,7 +148,28 @@ See URL `https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter ;; ;; -;; Emacs defaults. + +;;; Default D-Bus errors. + +(defconst dbus-error-dbus "org.freedesktop.DBus.Error" + "The namespace for default error names. +See /usr/include/dbus-1.0/dbus/dbus-protocol.h.") + +(defconst dbus-error-failed (concat dbus-error-dbus ".Failed") + "A generic error; \"something went wrong\" - see the error message for more.") + +(defconst dbus-error-access-denied (concat dbus-error-dbus ".AccessDenied") + "Security restrictions don't allow doing what you're trying to do.") + +(defconst dbus-error-invalid-args (concat dbus-error-dbus ".InvalidArgs") + "Invalid arguments passed to a method call.") + +(defconst dbus-error-property-read-only + (concat dbus-error-dbus ".PropertyReadOnly") + "Property you tried to set is read-only.") + + +;;; Emacs defaults. (defconst dbus-service-emacs "org.gnu.Emacs" "The well known service name of Emacs.") @@ -157,7 +181,8 @@ shall be subdirectories of this path.") (defconst dbus-interface-emacs "org.gnu.Emacs" "The interface namespace used by Emacs.") -;; D-Bus constants. + +;;; Basic D-Bus message functions. (defmacro dbus-ignore-errors (&rest body) "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil. @@ -172,9 +197,6 @@ Otherwise, return result of last form in BODY, or all other errors." Every function must accept two arguments, the event and the error variable caught in `condition-case' by `dbus-error'.") - -;;; Basic D-Bus message functions. - (defvar dbus-return-values-table (make-hash-table :test #'equal) "Hash table for temporarily storing arguments of reply messages. A key in this hash table is a list (:serial BUS SERIAL), like in @@ -463,8 +485,9 @@ This is an internal function, it shall not be used outside dbus.el." (apply #'dbus-message-internal dbus-message-type-method-return bus service serial args)) -(defun dbus-method-error-internal (bus service serial &rest args) +(defun dbus-method-error-internal (bus service serial error-name &rest args) "Return error message for message SERIAL on the D-Bus BUS. +ERROR-NAME must belong to the \"org.freedesktop.DBus.Error\" namespace. This is an internal function, it shall not be used outside dbus.el." (or (featurep 'dbusbind) @@ -477,7 +500,7 @@ This is an internal function, it shall not be used outside dbus.el." (signal 'wrong-type-argument (list 'natnump serial))) (apply #'dbus-message-internal dbus-message-type-error - bus service serial args)) + bus service serial error-name args)) ;;; Hash table of registered functions. @@ -587,7 +610,7 @@ queue of this service." (maphash (lambda (key value) - (unless (equal :serial (car key)) + (unless (eq :serial (car key)) (dolist (elt value) (ignore-errors (when (and (equal bus (cadr key)) (string-equal service (cadr elt))) @@ -775,10 +798,18 @@ discussion of DONT-REGISTER-SERVICE below). INTERFACE is the interface offered by SERVICE. It must provide METHOD. HANDLER is a Lisp function to be called when a method call is -received. It must accept the input arguments of METHOD. The return -value of HANDLER is used for composing the returning D-Bus message. -If HANDLER returns a reply message with an empty argument list, -HANDLER must return the symbol `:ignore'. +received. It must accept the input arguments of METHOD. The +return value of HANDLER is used for composing the returning D-Bus +message. If HANDLER returns a reply message with an empty +argument list, HANDLER must return the symbol `:ignore' in order +to distinguish it from `nil' (the boolean false). + +If HANDLER detects an error, it shall return the list `(:error +ERROR-NAME ERROR-MESSAGE)'. ERROR-NAME is a namespaced string +which characterizes the error type, and ERROR-MESSAGE is a free +text string. Alternatively, any Emacs signal `dbus-error' in +HANDLER raises a D-Bus error message with the error name +\"org.freedesktop.DBus.Error.Failed\". When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is not registered. This means that other D-Bus clients have no way of @@ -996,22 +1027,26 @@ If the HANDLER returns a `dbus-error', it is propagated as return message." (signal 'dbus-error (nthcdr 9 event))) ;; Apply the handler. (setq result (apply (nth 8 event) (nthcdr 9 event))) - ;; Return a message when it is a message call. + ;; Return an (error) message when it is a message call. (when (= dbus-message-type-method-call (nth 2 event)) (dbus-ignore-errors - (if (eq result :ignore) - (dbus-method-return-internal - (nth 1 event) (nth 4 event) (nth 3 event)) - (apply #'dbus-method-return-internal - (nth 1 event) (nth 4 event) (nth 3 event) - (if (consp result) result (list result))))))) + (if (eq (car-safe result) :error) + (apply #'dbus-method-error-internal + (nth 1 event) (nth 4 event) (nth 3 event) (cdr result)) + (if (eq result :ignore) + (dbus-method-return-internal + (nth 1 event) (nth 4 event) (nth 3 event)) + (apply #'dbus-method-return-internal + (nth 1 event) (nth 4 event) (nth 3 event) + (if (consp result) result (list result)))))))) ;; Error handling. (dbus-error ;; Return an error message when it is a message call. (when (= dbus-message-type-method-call (nth 2 event)) (dbus-ignore-errors (dbus-method-error-internal - (nth 1 event) (nth 4 event) (nth 3 event) (cadr err)))) + (nth 1 event) (nth 4 event) (nth 3 event) dbus-error-failed + (error-message-string err)))) ;; Propagate D-Bus error messages. (run-hook-with-args 'dbus-event-error-functions event err) (when dbus-debug @@ -1420,6 +1455,26 @@ nil is returned." (dbus-call-method bus service path dbus-interface-properties "GetAll" :timeout 500 interface)))) +(defun dbus-get-this-registered-property (bus _service path interface property) + "Return PROPERTY entry of `dbus-registered-objects-table'. +Filter out not matching PATH." + ;; Remove entries not belonging to this case. + (seq-remove + (lambda (item) + (not (string-equal path (nth 2 item)))) + (gethash (list :property bus interface property) + dbus-registered-objects-table))) + +(defun dbus-get-other-registered-property (bus _service path interface property) + "Return PROPERTY entry of `dbus-registered-objects-table'. +Filter out matching PATH." + ;; Remove matching entries. + (seq-remove + (lambda (item) + (string-equal path (nth 2 item))) + (gethash (list :property bus interface property) + dbus-registered-objects-table))) + (defun dbus-register-property (bus service path interface property access value &optional emits-signal dont-register-service) @@ -1436,14 +1491,14 @@ discussion of DONT-REGISTER-SERVICE below). INTERFACE is the name of the interface used at PATH, PROPERTY is the name of the property of INTERFACE. ACCESS indicates, whether the property can be changed by other services via D-Bus. It must be either -the symbol `:read' or `:readwrite'. VALUE is the initial value -of the property, it can be of any valid type (see +the symbol `:read', `:write' or `:readwrite'. VALUE is the +initial value of the property, it can be of any valid type (see `dbus-call-method' for details). If PROPERTY already exists on PATH, it will be overwritten. For properties with access type `:read' this is the only way to -change their values. Properties with access type `:readwrite' -can be changed by `dbus-set-property'. +change their values. Properties with access type `:write' or +`:readwrite' can be changed by `dbus-set-property'. The interface \"org.freedesktop.DBus.Properties\" is added to PATH, including a default handler for the \"Get\", \"GetAll\" and @@ -1457,7 +1512,7 @@ of noticing the newly registered property. When interfaces are constructed incrementally by adding single methods or properties at a time, DONT-REGISTER-SERVICE can be used to prevent other clients from discovering the still incomplete interface." - (unless (member access '(:read :readwrite)) + (unless (member access '(:read :write :readwrite)) (signal 'wrong-type-argument (list "Access type invalid" access))) ;; Add handlers for the three property-related methods. @@ -1479,24 +1534,26 @@ clients from discovering the still incomplete interface." (when emits-signal (dbus-send-signal bus service path dbus-interface-properties "PropertiesChanged" - `((:dict-entry ,property (:variant ,value))) - '(:array))) + (if (member access '(:read :readwrite)) + `(:array (:dict-entry ,property (:variant ,value))) + '(:array: :signature "{sv}")) + (if (eq access :write) + `(:array ,property) + '(:array)))) ;; Create a hash table entry. We use nil for the unique name, ;; because the property might be accessed from anybody. - (let* ((key (list :property bus interface property)) - ;; Remove possible existing entry, because it must be overwritten. - (val (seq-remove - (lambda (item) - (equal (butlast item) (list nil service path))) - (gethash key dbus-registered-objects-table))) - (entry + (let ((key (list :property bus interface property)) + (val + (cons (list nil service path (cons (if emits-signal (list access :emits-signal) (list access)) - value)))) - (puthash key (cons entry val) dbus-registered-objects-table) + value)) + (dbus-get-other-registered-property + bus service path interface property)))) + (puthash key val dbus-registered-objects-table) ;; Return the object. (list key (list service path)))) @@ -1513,61 +1570,70 @@ It will be registered for all objects created by `dbus-register-property'." (cond ;; "Get" returns a variant. ((string-equal method "Get") - (let ((entry - ;; Remove entries not belonging to this case. - (seq-remove - (lambda (item) - (not (string-equal (nth 2 item) path))) - (gethash (list :property bus interface property) - dbus-registered-objects-table)))) - - (when (string-equal path (nth 2 (car entry))) - `((:variant ,(cdar (last (car entry)))))))) + (let* ((entry (dbus-get-this-registered-property + bus service path interface property)) + (object (car (last (car entry))))) + (cond + ((not (consp object)) + `(:error ,dbus-error-invalid-args + ,(format-message + "No such property \"%s\" at path \"%s\"" property path))) + ((eq (car object) :write) + `(:error ,dbus-error-access-denied + ,(format-message + "Property \"%s\" at path \"%s\" is not readable" property path))) + ;; Return the result. + (t `((:variant ,(cdar (last (car entry))))))))) ;; "Set" expects a variant. ((string-equal method "Set") (let* ((value (caar (cddr args))) - (entry (gethash (list :property bus interface property) - dbus-registered-objects-table)) - ;; The value of the hash table is a list; in case of - ;; properties it contains just one element (UNAME SERVICE - ;; PATH OBJECT). OBJECT is a cons cell of a list, which - ;; contains a list of annotations (like :read, - ;; :read-write, :emits-signal), and the value of the - ;; property. + (entry (dbus-get-this-registered-property + bus service path interface property)) (object (car (last (car entry))))) - (unless (consp object) - (signal 'dbus-error - (list "Property not registered at path" property path))) - (unless (member :readwrite (car object)) - (signal 'dbus-error - (list "Property not writable at path" property path))) - (puthash (list :property bus interface property) - (list (append (butlast (car entry)) - (list (cons (car object) value)))) - dbus-registered-objects-table) - ;; Send the "PropertiesChanged" signal. - (when (member :emits-signal (car object)) - (dbus-send-signal - bus service path dbus-interface-properties "PropertiesChanged" - `((:dict-entry ,property (:variant ,value))) - '(:array))) - ;; Return empty reply. - :ignore)) + (cond + ((not (consp object)) + `(:error ,dbus-error-invalid-args + ,(format-message + "No such property \"%s\" at path \"%s\"" property path))) + ((eq (car object) :read) + `(:error ,dbus-error-property-read-only + ,(format-message + "Property \"%s\" at path \"%s\" is not writable" property path))) + (t (puthash (list :property bus interface property) + (cons (append (butlast (car entry)) + (list (cons (car object) value))) + (dbus-get-other-registered-property + bus service path interface property)) + dbus-registered-objects-table) + ;; Send the "PropertiesChanged" signal. + (when (member :emits-signal (car object)) + (dbus-send-signal + bus service path dbus-interface-properties "PropertiesChanged" + (if (or (member :read (car object)) + (member :readwrite (car object))) + `(:array (:dict-entry ,property (:variant ,value))) + '(:array: :signature "{sv}")) + (if (eq (car object) :write) + `(:array ,property) + '(:array)))) + ;; Return empty reply. + :ignore)))) ;; "GetAll" returns "a{sv}". ((string-equal method "GetAll") (let (result) (maphash (lambda (key val) - (when (and (equal (butlast key) (list :property bus interface)) - (string-equal path (nth 2 (car val))) - (not (functionp (car (last (car val)))))) - (push - (list :dict-entry - (car (last key)) - (list :variant (cdar (last (car val))))) - result))) + (dolist (item val) + (when (and (equal (butlast key) (list :property bus interface)) + (string-equal path (nth 2 item)) + (not (functionp (car (last item))))) + (push + (list :dict-entry + (car (last key)) + (list :variant (cdar (last item)))) + result)))) dbus-registered-objects-table) ;; Return the result, or an empty array. (list :array (or result '(:signature "{sv}")))))))) @@ -1775,5 +1841,7 @@ this connection to those buses." ;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and ;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved. +;; +;; * Run handlers in own threads. ;;; dbus.el ends here diff --git a/src/dbusbind.c b/src/dbusbind.c index f6a0879e6a..4fce92521a 100644 --- a/src/dbusbind.c +++ b/src/dbusbind.c @@ -1261,6 +1261,7 @@ usage: (dbus-message-internal &rest REST) */) Lisp_Object path = Qnil; Lisp_Object interface = Qnil; Lisp_Object member = Qnil; + Lisp_Object error_name = Qnil; Lisp_Object result; DBusConnection *connection; DBusMessage *dmessage; @@ -1298,7 +1299,9 @@ usage: (dbus-message-internal &rest REST) */) else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */ { serial = xd_extract_unsigned (args[3], TYPE_MAXIMUM (dbus_uint32_t)); - count = 4; + if (mtype == DBUS_MESSAGE_TYPE_ERROR) + error_name = args[4]; + count = (mtype == DBUS_MESSAGE_TYPE_ERROR) ? 5 : 4; } /* Check parameters. */ @@ -1341,13 +1344,22 @@ usage: (dbus-message-internal &rest REST) */) XD_OBJECT_TO_STRING (interface), XD_OBJECT_TO_STRING (member)); break; - default: /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */ + case DBUS_MESSAGE_TYPE_METHOD_RETURN: ui_serial = serial; XD_DEBUG_MESSAGE ("%s %s %s %u", XD_MESSAGE_TYPE_TO_STRING (mtype), XD_OBJECT_TO_STRING (bus), XD_OBJECT_TO_STRING (service), ui_serial); + break; + default: /* DBUS_MESSAGE_TYPE_ERROR */ + ui_serial = serial; + XD_DEBUG_MESSAGE ("%s %s %s %u %s", + XD_MESSAGE_TYPE_TO_STRING (mtype), + XD_OBJECT_TO_STRING (bus), + XD_OBJECT_TO_STRING (service), + ui_serial, + XD_OBJECT_TO_STRING (error_name)); } /* Retrieve bus address. */ @@ -1406,7 +1418,7 @@ usage: (dbus-message-internal &rest REST) */) XD_SIGNAL1 (build_string ("Unable to create a return message")); if ((mtype == DBUS_MESSAGE_TYPE_ERROR) - && (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED))) + && (!dbus_message_set_error_name (dmessage, SSDATA (error_name)))) XD_SIGNAL1 (build_string ("Unable to create an error message")); } commit 0f793b5658b0a3610c5b5cad5dd8558d5d11ddfe Author: Mauro Aranda Date: Fri Sep 4 14:50:40 2020 +0200 Document :type-error property for customization types * doc/lispref/customize.texi (Type Keywords): Document :type-error, so Lisp programs can display a more correct message when the value of a user option doesn't match its type (bug#23975). diff --git a/doc/lispref/customize.texi b/doc/lispref/customize.texi index b9c9130a92..c35444f581 100644 --- a/doc/lispref/customize.texi +++ b/doc/lispref/customize.texi @@ -1197,6 +1197,13 @@ current value is valid for the widget. Otherwise, it should return the widget containing the invalid data, and set that widget's @code{:error} property to a string explaining the error. +@item :type-error @var{string} +@kindex type-error@r{, customization keyword} +@var{string} should be a string that describes why a value doesn't +match the type, as determined by the @code{:match} function. When the +@code{:match} function returns @code{nil}, the widget's @code{:error} +property will be set to @var{string}. + @ignore @item :indent @var{columns} Indent this item by @var{columns} columns. The indentation is used for