From 68fe9e966e9c70318e35f82532a5e95d74c1faa5 Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Wed, 14 Oct 2020 21:39:46 -0700 Subject: [PATCH 1/3] New gnus-search library This library provides a fundamental reworking of the search functionality previously found in nnir.el. It uses class-based search engines to interface with external searching facilities, and a parsed search query syntax that can search multiple engines. * lisp/gnus/gnus-search.el: New library containing search functionality for Gnus. * doc/misc/gnus.texi: Document. * lisp/gnus/gnus-group.el (gnus-group-make-search-group, gnus-group-read-ephemeral-search-group): Remove references to nnir, change meaning of prefix argument, change values of nnselect-function and nnselect-args. * lisp/gnus/nnselect.el: Replace references to nnir (nnselect-request-article): Use gnus-search functions, and search criteria. (nnselect-request-thread, nnselect-search-thread): Use gnus-search thread search. (gnus-summary-make-search-group): Switch to use gnus-search function and arguments. * test/lisp/gnus/search-tests.el: Tests for new functionality. --- doc/misc/gnus.texi | 604 ++++----- lisp/gnus/gnus-group.el | 68 +- lisp/gnus/gnus-search.el | 2230 ++++++++++++++++++++++++++++++++ lisp/gnus/nnselect.el | 91 +- test/lisp/gnus/search-tests.el | 99 ++ 5 files changed, 2679 insertions(+), 413 deletions(-) create mode 100644 lisp/gnus/gnus-search.el create mode 100644 test/lisp/gnus/search-tests.el diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 69ac05d5aa..0c5910074a 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -795,19 +795,11 @@ Top Searching -* nnir:: Searching with various engines. +* Search Engines:: Selecting and configuring search engines. +* Creating Search Groups:: Creating search groups. +* Search Queries:: Gnus' built-in search syntax. * nnmairix:: Searching with Mairix. -nnir - -* What is nnir?:: What does nnir do. -* Basic Usage:: How to perform simple searches. -* Setting up nnir:: How to set up nnir. - -Setting up nnir - -* Associating Engines:: How to associate engines. - Various * Process/Prefix:: A convention used by many treatment commands. @@ -17919,12 +17911,11 @@ Selection Groups @lisp (nnselect-specs - (nnselect-function . nnir-run-query) + (nnselect-function . gnus-search-run-query) (nnselect-args - (nnir-query-spec - (query . "FLAGGED") - (criteria . "")) - (nnir-group-spec + (search-query-spec + (query . "mark:flag")) + (search-group-spec ("nnimap:home") ("nnimap:work")))) @end lisp @@ -17945,9 +17936,8 @@ Selection Groups (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)))))) + (gnus-search-run-query (list (cons 'search-query-spec query-spec) + (cons 'search-group-spec group-spec)))))) @end lisp Then the following @code{nnselect-specs}: @@ -17970,18 +17960,13 @@ Selection Groups 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. +Gnus includes engines for searching a variety of backends. While the +details of each search engine vary, the result of a search is always a +vector of the sort used by the nnselect method, and the results of +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 search +query as the @code{nnselect-specs}. @node Combined Groups @subsection Combined Groups @@ -21445,9 +21430,6 @@ Searching @chapter Searching @cindex searching -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 @@ -21455,50 +21437,168 @@ Searching or searching through messages in the summary buffer (@pxref{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. +Limiting commands and summary buffer searching work on 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. + +It's possible to search a backend more thoroughly using an associated +search engine. Some backends come with their own search engine: IMAP +servers, for instance, do their own searching. Other backends, for +example a local @code{nnmaildir} installation, might require the user +to manually set up some sort of search indexing. Default associations +between backends and engines can be defined in +@code{gnus-search-default-engines}, and engines can also be defined on +a per-backend basis (@xref{Search Engines}). + +Once the search engines are set up, you can search for messages in +groups from one or more backends, and show the results in a group. +The groups that hold search results are created on the nnselect +backend, and can be either ephemeral or persistent (@xref{Creating +Search Groups}). + +@vindex: gnus-search-use-parsed-queries + +Search queries can be specified one of two ways: either using the +syntax of the engine responsible for the group you're searching, or +using Gnus' generalized search syntax. Set the option +@code{gnus-search-use-parsed-queries} to a non-nil value to used the +generalized syntax. The advantage of this syntax is that, if you have +multiple backends indexed by different engines, you don't need to +remember which one you're searching -- it's also possible to issue the +same query against multiple groups, indexed by different engines, at +the same time. It also provides a few other conveniences including +relative date parsing and tie-ins into other Emacs packages. For +details on Gnus' query language, @xref{Search Queries}. @menu -* nnir:: Searching with various engines. -* nnmairix:: Searching with Mairix. +* Search Engines:: Selecting and configuring search engines. +* Creating Search Groups:: How and where. +* Search Queries:: Gnus' built-in search syntax. +* nnmairix:: Searching with Mairix. @end menu -@node nnir -@section nnir -@cindex nnir +@node Search Engines +@section Search Engines +@cindex search engines +@cindex configuring search + +In order to search for messages from any given server, that server +must have a search engine associated with it. IMAP servers do their +own searching (theoretically it is possible to use a different engine +to search an IMAP store, but we don't recommend it), but in all other +cases the user will have to manually specific an engine to use. This +can be done at two different levels: generally by server type, or on a +per-server basis. + +@vindex gnus-search-default-engines +The option @code{gnus-search-default-engines} assigns search engines +by server type. Its value is an alist mapping symbols indicating a +server type (e.g. @code{nnmaildir} or @code{nnml}) to symbols +indicating a search engine class. The built-in search engine symbols +are: -This section describes how to use @code{nnir} to search for articles -within gnus. +@itemize +@item +@code{gnus-search-imap} -@menu -* What is nnir?:: What does @code{nnir} do? -* Basic Usage:: How to perform simple searches. -* Setting up nnir:: How to set up @code{nnir}. -@end menu +@item +@code{gnus-search-find-grep} -@node What is nnir? -@subsection What is nnir? +@item +@code{gnus-search-notmuch} -@code{nnir} is a Gnus interface to a number of tools for searching -through mail and news repositories. Different backends (like -@code{nnimap} and @code{nntp}) work with different tools (called -@dfn{engines} in @code{nnir} lingo), but all use the same basic search -interface. +@item +@code{gnus-search-swish-e} + +@item +@code{gnus-search-swish++} + +@item +@code{gnus-search-mairix} -The @code{nnimap} search engine should work with no configuration. -Other engines may require a local index that needs to be created and -maintained outside of Gnus. +@item +@code{gnus-search-namazu} +@end itemize + +If you need more granularity, you can specify a search engine in the +server definition, using the @code{gnus-search-engine} key, whether +that be in your @file{.gnus.el} config file, or through the server +buffer. That might look like: +@example +'(nnmaildir "My Mail" + (directory "/home/user/.mail") + (gnus-search-engine gnus-search-notmuch + (config-file "/home/user/.mail/.notmuch_config"))) +@end example -@node Basic Usage -@subsection Basic Usage +Search engines like notmuch, namazu and mairix are similar in +behavior: they use a local executable to create an index of a message +store, and run command line search queries against those messages, +returning a list of absolute file names for matching messages. + +These engines have a handful of configuration parameters that can +either be set as a default option for all engines of that type, or set +per-engine in your server config. These common paramters are: + +@itemize +@item +@code{program}: The name of the executable. Defaults to the plain +program name such as ``notmuch'' or ``namazu''. + +@item +@code{config-file}: The absolute filename of the configuration file +for this search engine. + +@item +@code{remove-prefix}: The directory part to be removed from the +filenames returned by the search query. This absolute path should +include everything up to the top level of the message store. + +@item +@code{switches}: Additional command-line switches to be fed to the +search program. The value of this parameter must be a list of +strings, one string per switch. + +@end itemize + +The options above can be set in one of two ways: using a customization +option that is set for all engines of that type, or on a per-engine +basis in your server configuration files. + +The customization options are formed on the pattern +@code{gnus-search--}. For instance, to use a +non-standard notmuch program, you might set +@code{gnus-search-notmuch-program} to ``/usr/local/bin/notmuch''. +This would apply to all notmuch engines. The engines that use these +options are: ``notmuch'', ``namazu'', ``mairix'', ``swish-e'' and +``swish++''. + +The options can also be set directly on your Gnus server definitions, +for instance, in the @code{nnmaildir} example above. Note that the +server options are part of the @code{gnus-search-engine} sexp, and the +option symbol and value form a two-element list, not a cons cell. + +The namazu and swish-e engines each have an additional option, +specifying where to store the index files. For namazu it is +@code{index-directory}, and should be a single directory path. For +swish-e it is @code{index-files}, and should be a list of strings. + +All indexed search engines come with their own method of updating +their search indexes to include newly-arrived messages. Gnus +currently provides no convenient interface for this, and you'll have +to manage updates yourself, though this will likely change in the +future. + +Lastly, all search engines accept a @code{raw-queries-p} option. This +indicates that engines of this type (or this particular engine) should +always use raw queries, never parsed (@xref{Search Queries}). + +@node Creating Search Groups +@section Creating Search Groups +@cindex creating search groups In the group buffer typing @kbd{G G} will search the group on the current line by calling @code{gnus-group-read-ephemeral-search-group}. @@ -21525,297 +21625,137 @@ Basic Usage 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 -even more? Calling for an nnir search with the cursor on a topic heading -will search all the groups under that heading. +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 even more? Initiating a search with the cursor on a topic +heading will search all the groups under that topic. Still not enough? OK, in the server buffer -@code{gnus-group-read-ephemeral-search-group} (now bound to @kbd{G}) +@code{gnus-group-read-ephemeral-search-group} (here 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-read-ephemeral-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. - - -@node Setting up nnir -@subsection Setting up nnir - -To set up nnir you may need to do some prep work. Firstly, you may -need to configure the search engines you plan to use. Some of them, -like @code{imap}, need no special configuration. Others, like -@code{namazu} and @code{swish}, require configuration as described -below. Secondly, you need to associate a search engine with a server -or a backend. - -If you just want to use the @code{imap} engine to search @code{nnimap} -servers then you don't have to do anything. But you might want to -read the details of the query language anyway. - -@menu -* Associating Engines:: How to associate engines. -* The imap Engine:: Imap configuration and usage. -* The swish++ Engine:: Swish++ configuration and usage. -* The swish-e Engine:: Swish-e configuration and usage. -* The namazu Engine:: Namazu configuration and usage. -* The notmuch Engine:: Notmuch configuration and usage. -* The hyrex Engine:: Hyrex configuration and usage. -* Customizations:: User customizable settings. -@end menu - -@node Associating Engines -@subsubsection Associating Engines - - -When searching a group, @code{nnir} needs to know which search engine to -use. You can configure a given server to use a particular engine by -setting the server variable @code{nnir-search-engine} to the engine -name. For example to use the @code{namazu} engine to search the server -named @code{home} you can use - -@lisp -(setq gnus-secondary-select-methods - '((nnml "home" - (nnimap-address "localhost") - (nnir-search-engine namazu)))) -@end lisp - -Alternatively you might want to use a particular engine for all servers -with a given backend. For example, you might want to use the @code{imap} -engine for all servers using the @code{nnimap} backend. In this case you -can customize the variable @code{nnir-method-default-engines}. This is -an alist of pairs of the form @code{(backend . engine)}. By default this -variable is set to use the @code{imap} engine for all servers using the -@code{nnimap} backend. But if you wanted to use @code{namazu} for all -your servers with an @code{nnimap} backend you could change this to - -@lisp -'((nnimap . namazu)) -@end lisp - -@node The imap Engine -@subsubsection The imap Engine - -The @code{imap} engine requires no configuration. - -Queries using the @code{imap} engine follow a simple query language. -The search is always case-insensitive and supports the following -features (inspired by the Google search input language): - -@table @samp - -@item Boolean query operators -AND, OR, and NOT are supported, and parentheses can be used to control -operator precedence, e.g., (emacs OR xemacs) AND linux. Note that -operators must be written with all capital letters to be -recognized. Also preceding a term with a @minus{} sign is equivalent -to NOT term. - -@item Automatic AND queries -If you specify multiple words then they will be treated as an AND -expression intended to match all components. - -@item Phrase searches -If you wrap your query in double-quotes then it will be treated as a -literal string. - -@end table - -By default the whole message will be searched. The query can be limited -to a specific part of a message by using a prefix-arg. After inputting -the query this will prompt (with completion) for a message part. -Choices include ``Whole message'', ``Subject'', ``From'', and -``To''. Any unrecognized input is interpreted as a header name. For -example, typing @kbd{Message-ID} in response to this prompt will limit -the query to the Message-ID header. - -Finally selecting ``Imap'' will interpret the query as a raw -@acronym{IMAP} search query. The format of such queries can be found in -RFC3501. - -If you don't like the default of searching whole messages you can -customize @code{nnir-imap-default-search-key}. For example to use -@acronym{IMAP} queries by default +customize @code{gnus-search-ignored-newsgroups}: groups matching this +regexp will be ignored. + +@node Search Queries +@section Search Queries +@cindex search queries +@cindex search syntax + +Gnus provides an optional unified search syntax that can be used +across all supported search engines. This can be convenient in that +you don't have to remember different search syntaxes; it's also +possible to mark multiple groups indexed by different engines and +issue a single search against them. + +@vindex gnus-search-use-parsed-queries +Set the option @code{gnus-search-use-parsed-queries} to non-@code{nil} +to enable this -- it is @code{nil} by default. Even if it is +non-@code{nil}, it's still possible to turn off parsing for a class of +engines or a single engine (@pxref{Search Engines}), or a single +search by giving a prefix argument to any of the search commands. + +The search syntax is fairly simple: keys and values are separated by a +colon, multi-word values must be quoted, ``and'' is implicit, ``or'' +is explicit, ``not'' will negate the following expression (or keys can +be prefixed with a ``-''),and parentheses can be used to group logical +sub-clauses. For example: -@lisp -(setq nnir-imap-default-search-key "Imap") -@end lisp - -@node The swish++ Engine -@subsubsection The swish++ Engine - -FIXME: Say something more here. - -Documentation for swish++ may be found at the swish++ sourceforge page: -@uref{http://swishplusplus.sourceforge.net} - -@table @code - -@item nnir-swish++-program -The name of the swish++ executable. Defaults to @code{search} - -@item nnir-swish++-additional-switches -A list of strings to be given as additional arguments to -swish++. @code{nil} by default. - -@item nnir-swish++-remove-prefix -The prefix to remove from each file name returned by swish++ in order -to get a group name. By default this is @code{$HOME/Mail}. - -@end table - -@node The swish-e Engine -@subsubsection The swish-e Engine - -FIXME: Say something more here. - -@table @code - -@item nnir-swish-e-program -The name of the swish-e search program. Defaults to @code{swish-e}. - -@item nnir-swish-e-additional-switches -A list of strings to be given as additional arguments to -swish-e. @code{nil} by default. - -@item nnir-swish-e-remove-prefix -The prefix to remove from each file name returned by swish-e in order -to get a group name. By default this is @code{$HOME/Mail}. - -@end table - -@node The namazu Engine -@subsubsection The namazu Engine - -Using the namazu engine requires creating and maintaining index files. -One directory should contain all the index files, and nnir must be told -where to find them by setting the @code{nnir-namazu-index-directory} -variable. - -To work correctly the @code{nnir-namazu-remove-prefix} variable must -also be correct. This is the prefix to remove from each file name -returned by Namazu in order to get a proper group name (albeit with @samp{/} -instead of @samp{.}). - -For example, suppose that Namazu returns file names such as -@samp{/home/john/Mail/mail/misc/42}. For this example, use the -following setting: @code{(setq nnir-namazu-remove-prefix -"/home/john/Mail/")} Note the trailing slash. Removing this prefix from -the directory gives @samp{mail/misc/42}. @code{nnir} knows to remove -the @samp{/42} and to replace @samp{/} with @samp{.} to arrive at the -correct group name @samp{mail.misc}. - -Extra switches may be passed to the namazu search command by setting the -variable @code{nnir-namazu-additional-switches}. It is particularly -important not to pass any switches to namazu that will change the -output format. Good switches to use include @option{--sort}, -@option{--ascending}, @option{--early} and @option{--late}. -Refer to the Namazu documentation for further -information on valid switches. - -Mail must first be indexed with the @command{mknmz} program. Read the -documentation for namazu to create a configuration file. Here is an -example: - -@cartouche @example - package conf; # Don't remove this line! - - # Paths which will not be indexed. Don't use '^' or '$' anchors. - $EXCLUDE_PATH = "spam|sent"; - - # Header fields which should be searchable. case-insensitive - $REMAIN_HEADER = "from|date|message-id|subject"; - - # Searchable fields. case-insensitive - $SEARCH_FIELD = "from|date|message-id|subject"; - - # The max length of a word. - $WORD_LENG_MAX = 128; - - # The max length of a field. - $MAX_FIELD_LENGTH = 256; +(from:john or from:peter) subject: ``lunch tomorrow'' since:3d @end example -@end cartouche -For this example, mail is stored in the directories @samp{~/Mail/mail/}, -@samp{~/Mail/lists/} and @samp{~/Mail/archive/}, so to index them go to -the index directory set in @code{nnir-namazu-index-directory} and issue -the following command: +The syntax is made to be accepted by a wide range of engines, and thus +will happily accept most input, valid or not. Some terms will only be +meaningful to some engines; other engines will drop them silently. -@example -mknmz --mailnews ~/Mail/archive/ ~/Mail/mail/ ~/Mail/lists/ -@end example - -For maximum searching efficiency you might want to have a cron job run -this command periodically, say every four hours. +Key completion is offered on @key{TAB}, but it's also possible to +enter the query with abbreviated keys, which will be expanded during +parsing. If a key is abbreviated to the point of ambiguity (for +instance, ``s:'' could be ``subject:'' or ``since:''), an error will +be raised. +Supported keys include all the usual mail headers: ``from'', ``subject'', ``cc'', etc. Other keys are: -@node The notmuch Engine -@subsubsection The notmuch Engine - -@table @code -@item nnir-notmuch-program -The name of the notmuch search executable. Defaults to -@samp{notmuch}. - -@item nnir-notmuch-additional-switches -A list of strings, to be given as additional arguments to notmuch. - -@item nnir-notmuch-remove-prefix -The prefix to remove from each file name returned by notmuch in order -to get a group name (albeit with @samp{/} instead of @samp{.}). This -is a regular expression. - -@item nnir-notmuch-filter-group-names-function -A function used to transform the names of groups being searched in, -for use as a ``path:'' search keyword for notmuch. If nil, the -default, ``path:'' keywords are not used. Otherwise, this should be a -callable which accepts a single group name and returns a transformed -name as notmuch expects to see it. In many mail backends, for -instance, dots in group names must be converted to forward slashes: to -achieve this, set this option to -@example -(lambda (g) (replace-regexp-in-string "\\." "/" g)) -@end example +@itemize +@item +body: +@item +recipient: to or cc or bcc +@item +address: from or recipient +@item +mark: Accepts ``flag'', ``seen'', ``read'' or ``replied'', or any of +Gnus' single-letter representations of those marks, i.e. ``mark:R'' +for ``read''. +@item +tag: This is interpreted as ``keyword'' for IMAP and ``tag'' for +notmuch. +@item +attachment: Matches the attachment file name. +@item +before: Date is exclusive; see below for date parsing. +@item +after: Date is inclusive; can also use ``since''. +@item +thread: Return entire message threads, not just individual messages. +@item +raw: Do not parse this particular search. +@item +limit: Limit the results to this many messages. When searching +multiple groups this may give undesired results, as the limiting +happens before sorting. +@item +grep: On systems with a grep command, additionally filter the results +by using the value of this term as a grep regexp. +@end itemize -@end table +@vindex gnus-search-contact-sources +If an elisp-based contact management packages (e.g. BBDB or EBDB) +pushes a function onto the option @code{gnus-search-contact-sources}, +three other keys become available: +@itemize +@item +contact-from: Search by contact name, and the actual search will use +all the contact's email addresses. +@item +contact-to: The same, but as if ``recipient''. +@item +contact: The same, but as if ``address''. +@end itemize -@node The hyrex Engine -@subsubsection The hyrex Engine -This engine is obsolete. +@subsection Date value parsing -@node Customizations -@subsubsection Customizations +@vindex gnus-search-date-keys +Date-type keys (see @code{gnus-search-date-keys}) will accept a wide +variety of values. First, anything that @code{parse-time-string} can +parse is acceptable. Dates with missing values will be interpreted as +the most recent occurance thereof: for instance ``march 03'' is the +most recent March 3rd. Lastly, it's possible to use relative +specifications, such as ``3d'' (three days ago). This format also accepts +w, m and y. -@table @code +When creating persistent search groups, the search is saved unparsed, +and re-parsed every time the group is updated. So a permanent search +group with a query like: -@item nnir-method-default-engines -Alist of pairs of server backends and search engines. The default -association is @example -(nnimap . imap) +from: ``my boss'' mark:flag since:1w @end example -@item nnir-ignored-newsgroups -A regexp to match newsgroups in the active file that should be skipped -when searching all groups on a server. - -@end table - +would always contain only messages from the past seven days. @node nnmairix @section nnmairix @cindex mairix @cindex nnmairix + +This section is now mostly obsolete, as mairix can be used as a regular +search engine, including persistent search groups, with +@code{nnselect}. + This paragraph describes how to set up mairix and the back end @code{nnmairix} for indexing and searching your mail from within Gnus. Additionally, you can create permanent ``smart'' groups which are diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 1d614f8a8d..c6f7e1c41a 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -3165,29 +3165,27 @@ gnus-group-make-directory-group (gnus-group-real-name group) (list 'nndir (gnus-group-real-name group) (list 'nndir-directory dir))))) - -(autoload 'nnir-read-parms "nnir") -(autoload 'nnir-server-to-search-engine "nnir") (autoload 'gnus-group-topic-name "gnus-topic") +(autoload 'gnus-search-make-spec "gnus-search") ;; Temporary to make group creation easier -(defun gnus-group-make-search-group (nnir-extra-parms &optional specs) +(defun gnus-group-make-search-group (no-parse &optional specs) "Make a 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." +current line, or all the groups under the current topic. A +prefix arg NO-PARSE means that Gnus should not parse the search +query before passing it to the underlying search engine. A +non-nil SPECS arg must be an alist with `search-query-spec' and +`search-group-spec' keys, and skips all prompting." (interactive "P") (let ((name (gnus-read-group "Group name: "))) (with-current-buffer gnus-group-buffer (let* ((group-spec (or - (cdr (assq 'nnir-group-spec specs)) + (cdr (assq 'search-group-spec specs)) (if (gnus-server-server-name) (list (list (gnus-server-server-name))) (seq-group-by @@ -3199,16 +3197,8 @@ gnus-group-make-search-group (assoc (gnus-group-topic-name) gnus-topic-alist)))))))) (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)))))) + (cdr (assq 'search-query-spec specs)) + (gnus-search-make-spec no-parse)))) (gnus-group-make-group name (list 'nnselect "nnselect") @@ -3216,29 +3206,29 @@ gnus-group-make-search-group (list (cons 'nnselect-specs (list - (cons 'nnselect-function 'nnir-run-query) + (cons 'nnselect-function 'gnus-search-run-query) (cons 'nnselect-args - (list (cons 'nnir-query-spec query-spec) - (cons 'nnir-group-spec group-spec))))) + (list (cons 'search-query-spec query-spec) + (cons 'search-group-spec group-spec))))) (cons 'nnselect-artlist nil))))))) (define-obsolete-function-alias 'gnus-group-make-nnir-group 'gnus-group-read-ephemeral-search-group "28.1") -(defun gnus-group-read-ephemeral-search-group (nnir-extra-parms &optional specs) +(defun gnus-group-read-ephemeral-search-group (no-parse &optional specs) "Read 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." +current line, or all the groups under the current topic. A +prefix arg NO-PARSE means that Gnus should not parse the search +query before passing it to the underlying search engine. A +non-nil SPECS arg must be an alist with `search-query-spec' and +`search-group-spec' keys, and skips all prompting." (interactive "P") (let* ((group-spec - (or (cdr (assq 'nnir-group-spec specs)) + (or (cdr (assq 'search-group-spec specs)) (if (gnus-server-server-name) (list (list (gnus-server-server-name))) (seq-group-by @@ -3249,16 +3239,8 @@ gnus-group-read-ephemeral-search-group (cdr (assoc (gnus-group-topic-name) gnus-topic-alist)))))))) (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)))))) + (or (cdr (assq 'search-query-spec specs)) + (gnus-search-make-spec no-parse)))) (gnus-group-read-ephemeral-group (concat "nnselect-" (message-unique-id)) (list 'nnselect "nnselect") @@ -3268,10 +3250,10 @@ gnus-group-read-ephemeral-search-group (list (cons 'nnselect-specs (list - (cons 'nnselect-function 'nnir-run-query) + (cons 'nnselect-function 'gnus-search-run-query) (cons 'nnselect-args - (list (cons 'nnir-query-spec query-spec) - (cons 'nnir-group-spec group-spec))))) + (list (cons 'search-query-spec query-spec) + (cons 'search-group-spec group-spec))))) (cons 'nnselect-artlist nil))))) (defun gnus-group-add-to-virtual (n vgroup) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el new file mode 100644 index 0000000000..50007da4d3 --- /dev/null +++ b/lisp/gnus/gnus-search.el @@ -0,0 +1,2230 @@ +;;; gnus-search.el --- Search facilities for Gnus -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Eric Abrahamsen + +;; This program 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. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; This file defines a generalized search language, and search engines +;; that interface with various search programs. It is responsible for +;; parsing the user's search input, sending that query to the search +;; engines, and collecting results. Results are in the form of a +;; vector of vectors, each vector representing a found article. The +;; nnselect backend interprets that value to create a group containing +;; the search results. + +;; This file was formerly known as nnir. Later, the backend parts of +;; nnir became nnselect, and only the search functionality was left +;; here. + +;; See the Gnus manual for details of the search language. Tests are +;; in tests/gnus-search-test.el. + +;; The search parsing routines are responsible for accepting the +;; user's search query as a string and parsing it into a sexp +;; structure. The function `gnus-search-parse-query' is the entry +;; point for that. Once the query is in sexp form, it is passed to +;; the search engines themselves, which are responsible for +;; transforming the query into a form that the external program can +;; understand, and then filtering the search results into a format +;; that nnselect can understand. + +;; The general flow is: + +;; 1. The user calls one of `gnus-group-make-search-group' or +;; `gnus-group-make-permanent-search-group' (or a few other entry +;; points). These functions prompt for a search query, and collect +;; the groups to search, then create an nnselect group, setting an +;; 'nnselect-specs group parameter where 'nnselect-function is +;; `gnus-search-run-query', and 'nnselect-args is the search query and +;; groups to search. + +;; 2. `gnus-search-run-query' is called with 'nnselect-args. It looks +;; at the groups to search, categorizes them by server, and for each +;; server finds the search engine to use. It calls each engine's +;; `gnus-search-run-search' method with the query and groups passed as +;; arguments, and the results are collected and handed off to the +;; nnselect group. + +;; For information on writing new search engines, see the Gnus manual. + +;;; Code: + +(require 'gnus-group) +(require 'gnus-sum) +(require 'message) +(require 'gnus-util) +(require 'eieio) +(eval-when-compile (require 'cl-lib)) +(autoload 'eieio-build-class-alist "eieio-opt") +(autoload 'nnmaildir-base-name-to-article-number "nnmaildir") + +(defvar gnus-inhibit-demon) +(defvar gnus-english-month-names) + +;;; Internal Variables: + +(defvar gnus-search-memo-query nil + "Internal: stores current query.") + +(defvar gnus-search-memo-server nil + "Internal: stores current server.") + +(defvar gnus-search-history () + "Internal history of Gnus searches.") + +(define-error 'gnus-search-parse-error "Gnus search parsing error") + +;;; User Customizable Variables: + +(defgroup gnus-search nil + "Search groups in Gnus with assorted search engines." + :group 'gnus) + +(defcustom gnus-search-use-parsed-queries nil + "When t, use Gnus' generalized search language. +The generalized search language is a search language that can be +used across all search engines that Gnus supports. See the Gnus +manual for details. + +If this option is set to nil, search queries will be passed +directly to the search engines without being parsed or +transformed." + :version "28.1" + :type 'boolean + :group 'gnus-search) + +(define-obsolete-variable-alias 'nnir-ignored-newsgroups + 'gnus-search-ignored-newsgroups "28.1") + +(defcustom gnus-search-ignored-newsgroups "" + "A regexp to match newsgroups in the active file that should + be skipped when searching." + :version "24.1" + :type 'regexp + :group 'gnus-search) + +;; Engine-specific configuration options. + +(defcustom gnus-search-swish++-config-file + (expand-file-name "~/Mail/swish++.conf") + "Location of Swish++ configuration file. +This variable can also be set per-server." + :type 'file + :group 'gnus-search) + +(defcustom gnus-search-swish++-program "search" + "Name of swish++ search executable. +This variable can also be set per-server." + :type 'string + :group 'gnus-search) + +(defcustom gnus-search-swish++-switches '() + "A list of strings, to be given as additional arguments to swish++. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-swish++-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-swish++-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :group 'gnus-search) + +(defcustom gnus-search-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. + +This variable can also be set per-server." + :type 'regexp + :group 'gnus-search) + +(defcustom gnus-search-swish++-raw-queries-p nil + "If t, all Swish++ engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-config-file + (expand-file-name "~/Mail/swish-e.conf") + "Configuration file for swish-e. +This variable can also be set per-server." + :type 'file + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-program "search" + "Name of swish-e search executable. +This variable can also be set per-server." + :type 'string + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-switches '() + "A list of strings, to be given as additional arguments to swish-e. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-swish-e-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-swish-e-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-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. + +This variable can also be set per-server." + :type 'regexp + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-index-files '() + "A list of index files to use with this Swish-e instance. +This variable can also be set per-server." + :type '(repeat file) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-swish-e-raw-queries-p nil + "If t, all Swish-e engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +;; Namazu engine, see + +(defcustom gnus-search-namazu-program "namazu" + "Name of Namazu search executable. +This variable can also be set per-server." + :type 'string + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-namazu-index-directory (expand-file-name "~/Mail/namazu/") + "Index directory for Namazu. +This variable can also be set per-server." + :type 'directory + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-namazu-switches '() + "A list of strings, to be given as additional arguments to namazu. +The switches `-q', `-a', and `-s' are always used, very few other switches +make any sense in this context. + +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-namazu-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-namazu-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-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 .). + +For example, suppose that Namazu returns file names such as +\"/home/john/Mail/mail/misc/42\". For this example, use the following +setting: (setq gnus-search-namazu-remove-prefix \"/home/john/Mail/\") +Note the trailing slash. Removing this prefix gives \"mail/misc/42\". +Gnus knows to remove the \"/42\" and to replace \"/\" with \".\" to +arrive at the correct group name, \"mail.misc\". + +This variable can also be set per-server." + :type 'directory + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-namazu-raw-queries-p nil + "If t, all Namazu engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-program "notmuch" + "Name of notmuch search executable. +This variable can also be set per-server." + :type '(string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-config-file + (expand-file-name "~/.notmuch-config") + "Configuration file for notmuch. +This variable can also be set per-server." + :type 'file + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-switches '() + "A list of strings, to be given as additional arguments to notmuch. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-notmuch-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnus-search-notmuch-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :type '(repeat string) + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-remove-prefix (concat (getenv "HOME") "/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. + +This variable can also be set per-server." + :type 'regexp + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-notmuch-raw-queries-p nil + "If t, all Notmuch engines will only accept raw search query + strings." + :type 'boolean + :version "28.1" + :group 'gnus-search) + +(defcustom gnus-search-imap-raw-queries-p nil + "If t, all IMAP engines will only accept raw search query + strings." + :version "28.1" + :type 'boolean + :group 'gnus-search) + +(defcustom gnus-search-mairix-program "mairix" + "Name of mairix search executable. +This variable can also be set per-server." + :version "28.1" + :type 'string + :group 'gnus-search) + +(defcustom gnus-search-mairix-config-file + (expand-file-name "~/.mairixrc") + "Configuration file for mairix. +This variable can also be set per-server." + :version "28.1" + :type 'file + :group 'gnus-search) + +(defcustom gnus-search-mairix-switches '() + "A list of strings, to be given as additional arguments to mairix. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-mairix-switches \"-i -w\") ; wrong +Instead, use this: + (setq gnu-search-mairix-switches \\='(\"-i\" \"-w\")) + +This variable can also be set per-server." + :version "28.1" + :type '(repeat string) + :group 'gnus-search) + +(defcustom gnus-search-mairix-remove-prefix (concat (getenv "HOME") "/Mail/") + "The prefix to remove from each file name returned by mairix +in order to get a group name (albeit with / instead of .). This is a +regular expression. + +This variable can also be set per-server." + :version "28.1" + :type 'regexp + :group 'gnus-search) + +(defcustom gnus-search-mairix-raw-queries-p nil + "If t, all Mairix engines will only accept raw search query + strings." + :version "28.1" + :type 'boolean + :group 'gnus-search) + +;; Options for search language parsing. + +(defcustom gnus-search-expandable-keys + '("from" "subject" "to" "cc" "bcc" "body" "recipient" "date" + "mark" "contact" "contact-from" "contact-to" "before" "after" + "larger" "smaller" "attachment" "text" "since" "thread" + "sender" "address" "tag" "size" "grep" "limit" "raw") + "A list of strings representing expandable search keys. +\"Expandable\" simply means the key can be abbreviated while +typing in search queries, ie \"subject\" could be entered as +\"subj\" or even \"su\", though \"s\" is ambigous between +\"subject\" and \"since\". + +Keys can contain hyphens, in which case each section will be +expanded separately. \"cont\" will expand to \"contact\", for +instance, while \"c-t\" will expand to \"contact-to\". + +Ambiguous abbreviations will raise an error." + :group 'gnus-search + :version "28.1" + :type '(repeat string)) + +(defcustom gnus-search-date-keys + '("date" "before" "after" "on" "senton" "sentbefore" "sentsince" "since") + "A list of keywords whose value should be parsed as a date. +See the docstring of `gnus-search-parse-query' for information on +date parsing." + :group 'gnus-search + :version "26.1" + :type '(repeat string)) + +(defcustom gnus-search-contact-sources nil + "A list of sources used to search for messages from contacts. +Each list element can be either a function, or an alist. +Functions should accept a search string, and return a list of +email addresses of matching contacts. An alist should map single +strings to lists of mail addresses, usable as search keys in mail +headers." + :group 'gnus-search + :version "28.1" + :type '(repeat (choice function + (alist + :key-type string + :value-type (repeat string))))) + +;;; Search language + +;; This "language" was generalized from the original IMAP search query +;; parsing routine. + +(defun gnus-search-parse-query (string) + "Turn STRING into an s-expression based query. +The resulting query structure is passed to the various search +backends, each of which adapts it as needed. + +The search \"language\" is essentially a series of key:value +expressions. Key is most often a mail header, but there are +other keys. Value is a string, quoted if it contains spaces. +Key and value are separated by a colon, no space. Expressions +are implictly ANDed; the \"or\" keyword can be used to +OR. \"not\" will negate the following expression, or keys can be +prefixed with a \"-\". The \"near\" operator will work for +engines that understand it; other engines will convert it to +\"or\". Parenthetical groups work as expected. + +A key that matches the name of a mail header will search that +header. + +Search keys can be abbreviated so long as they remain +unambiguous, ie \"f\" will search the \"from\" header. \"s\" will +raise an error. + +Other keys: + +\"address\" will search all sender and recipient headers. + +\"recipient\" will search \"To\", \"Cc\", and \"Bcc\". + +\"before\" will search messages sent before the specified +date (date specifications to come later). Date is exclusive. + +\"after\" (or its synonym \"since\") will search messages sent +after the specified date. Date is inclusive. + +\"mark\" will search messages that have some sort of mark. +Likely values include \"flag\", \"seen\", \"read\", \"replied\". +It's also possible to use Gnus' internal marks, ie \"mark:R\" +will be interpreted as mark:read. + +\"tag\" will search tags -- right now that's translated to +\"keyword\" in IMAP, and left as \"tag\" for notmuch. At some +point this should also be used to search marks in the Gnus +registry. + +\"contact\" will search messages to/from a contact. Contact +management packages must push a function onto +`gnus-search-contact-sources', the docstring of which see, for +this to work. + +\"contact-from\" does what you'd expect. + +\"contact-to\" searches the same headers as \"recipient\". + +Other keys can be specified, provided that the search backends +know how to interpret them. + +Date values (any key in `gnus-search-date-keys') can be provided +in any format that `parse-time-string' can parse (note that this +can produce weird results). Dates with missing bits will be +interpreted as the most recent occurance thereof (ie \"march 03\" +is the most recent March 3rd). Lastly, relative specifications +such as 1d (one day ago) are understood. This also accepts w, m, +and y. m is assumed to be 30 days. + +This function will accept pretty much anything as input. Its +only job is to parse the query into a sexp, and pass that on -- +it is the job of the search backends to make sense of the +structured query. Malformed, unusable or invalid queries will +typically be silently ignored." + (with-temp-buffer + ;; Set up the parsing environment. + (insert string) + (goto-char (point-min)) + ;; Now, collect the output terms and return them. + (let (out) + (while (not (gnus-search-query-end-of-input)) + (push (gnus-search-query-next-expr) out)) + (reverse out)))) + +(defun gnus-search-query-next-expr (&optional count halt) + "Return the next expression from the current buffer." + (let ((term (gnus-search-query-next-term count)) + (next (gnus-search-query-peek-symbol))) + ;; Deal with top-level expressions. And, or, not, near... What + ;; else? Notmuch also provides xor and adj. It also provides a + ;; "nearness" parameter for near and adj. + (cond + ;; Handle 'expr or expr' + ((and (eq next 'or) + (null halt)) + (list 'or term (gnus-search-query-next-expr 2))) + ;; Handle 'near operator. + ((eq next 'near) + (let ((near-next (gnus-search-query-next-expr 2))) + (if (and (stringp term) + (stringp near-next)) + (list 'near term near-next) + (signal 'gnus-search-parse-error + (list "\"Near\" keyword must appear between two plain strings."))))) + ;; Anything else + (t term)))) + +(defun gnus-search-query-next-term (&optional count) + "Return the next TERM from the current buffer." + (let ((term (gnus-search-query-next-symbol count))) + ;; What sort of term is this? + (cond + ;; negated term + ((eq term 'not) (list 'not (gnus-search-query-next-expr nil 'halt))) + ;; generic term + (t term)))) + +(defun gnus-search-query-peek-symbol () + "Return the next symbol from the current buffer, but don't consume it." + (save-excursion + (gnus-search-query-next-symbol))) + +(defun gnus-search-query-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." + (when (and (numberp count) (> count 1)) + (gnus-search-query-next-symbol (1- count))) + (let ((case-fold-search t)) + ;; end of input stream? + (unless (gnus-search-query-end-of-input) + ;; No, return the next symbol from the stream. + (cond + ;; Negated expression -- return it and advance one char. + ((looking-at "-") (forward-char 1) 'not) + ;; List expression -- we parse the content and return this as a list. + ((looking-at "(") + (gnus-search-parse-query (gnus-search-query-return-string ")" t))) + ;; Keyword input -- return a symbol version. + ((looking-at "\\band\\b") (forward-char 3) 'and) + ((looking-at "\\bor\\b") (forward-char 2) 'or) + ((looking-at "\\bnot\\b") (forward-char 3) 'not) + ((looking-at "\\bnear\\b") (forward-char 4) 'near) + ;; Plain string, no keyword + ((looking-at "[\"/]?\\b[^:]+\\([[:blank:]]\\|\\'\\)") + (gnus-search-query-return-string + (when (looking-at-p "[\"/]") t))) + ;; Assume a K:V expression. + (t (let ((key (gnus-search-query-expand-key + (buffer-substring + (point) + (progn + (re-search-forward ":" (point-at-eol) t) + (1- (point)))))) + (value (gnus-search-query-return-string + (when (looking-at-p "[\"/]") t)))) + (gnus-search-query-parse-kv key value))))))) + +(defun gnus-search-query-parse-kv (key value) + "Handle KEY and VALUE, parsing and expanding as necessary. +This may result in (key value) being turned into a larger query +structure. + +In the simplest case, they are simply consed together. String +KEY is converted to a symbol." + (let (return) + (cond + ((member key gnus-search-date-keys) + (when (string= "after" key) + (setq key "since")) + (setq value (gnus-search-query-parse-date value))) + ((string-match-p "contact" key) + (setq return (gnus-search-query-parse-contact key value))) + ((equal key "mark") + (setq value (gnus-search-query-parse-mark value)))) + (or return + (cons (intern key) value)))) + +(defun gnus-search-query-parse-date (value &optional rel-date) + "Interpret VALUE as a date specification. +See the docstring of `gnus-search-parse-query' for details. + +The result is a list of (dd mm yyyy); individual elements can be +nil. + +If VALUE is a relative time, interpret it as relative to +REL-DATE, or (current-time) if REL-DATE is nil." + ;; Time parsing doesn't seem to work with slashes. + (let ((value (replace-regexp-in-string "/" "-" value)) + (now (append '(0 0 0) + (seq-subseq (decode-time (or rel-date + (current-time))) + 3)))) + ;; Check for relative time parsing. + (if (string-match "\\([[:digit:]]+\\)\\([dwmy]\\)" value) + (seq-subseq + (decode-time + (time-subtract + (apply #'encode-time now) + (days-to-time + (* (string-to-number (match-string 1 value)) + (cdr (assoc (match-string 2 value) + '(("d" . 1) + ("w" . 7) + ("m" . 30) + ("y" . 365)))))))) + 3 6) + ;; Otherwise check the value of `parse-time-string'. + + ;; (SEC MIN HOUR DAY MON YEAR DOW DST TZ) + (let ((d-time (parse-time-string value))) + ;; Did parsing produce anything at all? + (if (seq-some #'integerp (seq-subseq d-time 3 7)) + (seq-subseq + ;; If DOW is given, handle that specially. + (if (and (seq-elt d-time 6) (null (seq-elt d-time 3))) + (decode-time + (time-subtract (apply #'encode-time now) + (days-to-time + (+ (if (> (seq-elt d-time 6) + (seq-elt now 6)) + 7 0) + (- (seq-elt now 6) (seq-elt d-time 6)))))) + d-time) + 3 6) + ;; `parse-time-string' failed to produce anything, just + ;; return the string. + value))))) + +(defun gnus-search-query-parse-mark (mark) + "Possibly transform MARK. +If MARK is a single character, assume it is one of the +gnus-*-mark marks, and return an appropriate string." + (if (= 1 (length mark)) + (let ((m (aref mark 0))) + ;; Neither pcase nor cl-case will work here. + (cond + ((eql m gnus-ticked-mark) "flag") + ((eql m gnus-read-mark) "read") + ((eql m gnus-replied-mark) "replied") + ((eql m gnus-recent-mark) "recent") + (t mark))) + mark)) + +(defun gnus-search-query-parse-contact (key value) + "Handle VALUE as the name of a contact. +Runs VALUE through the elements of +`gnus-search-contact-sources' until one of them returns a list +of email addresses. Turns those addresses into an appropriate +chunk of query syntax." + (let ((funcs (or (copy-sequence gnus-search-contact-sources) + (signal 'gnus-search-parse-error + (list "No functions for handling contacts.")))) + func addresses) + (while (and (setq func (pop funcs)) + (null addresses)) + (setq addresses (if (functionp func) + (funcall func value) + (when (string= value (car func)) + (cdr func))))) + (unless addresses + (setq addresses (list value))) + ;; Simplest case: single From address. + (if (and (null (cdr addresses)) + (equal key "contact-from")) + (cons 'sender (car addresses)) + (cons + 'or + (mapcan + (lambda (a) + (pcase key + ("contact-from" + (list (cons 'sender a))) + ("contact-to" + (list (cons 'recipient a))) + ("contact" + (list (cons 'address a))))) + addresses))))) + +(defun gnus-search-query-expand-key (key) + (cond ((test-completion key gnus-search-expandable-keys) + ;; We're done! + key) + ;; There is more than one possible completion. + ((consp (cdr (completion-all-completions + key gnus-search-expandable-keys #'stringp 0))) + (signal 'gnus-search-parse-error + (list (format "Ambiguous keyword: %s" key)))) + ;; Return KEY, either completed or untouched. + ((car-safe (completion-try-completion + key gnus-search-expandable-keys + #'stringp 0))))) + +(defun gnus-search-query-return-string (&optional delimited trim) + "Return a string from the current buffer. +If DELIMITED is non-nil, assume the next character is a delimiter +character, and return everything between point and the next +occurance of the delimiter, including the delimiters themselves. +If TRIM is non-nil, do not return the delimiters. Otherwise, +return one word." + ;; This function cannot handle nested delimiters, as it's not a + ;; proper parser. Ie, you cannot parse "to:bob or (from:bob or + ;; (cc:bob or bcc:bob))". + (let ((start (point)) + (delimiter (if (stringp delimited) + delimited + (when delimited + (char-to-string (char-after))))) + end) + (if delimiter + (progn + (when trim + ;; Skip past first delimiter if we're trimming. + (forward-char 1)) + (while (not end) + (unless (search-forward delimiter nil t (unless trim 2)) + (signal 'gnus-search-parse-error + (list (format "Unmatched delimited input with %s in query" delimiter)))) + (let ((here (point))) + (unless (equal (buffer-substring (- here 2) (- here 1)) "\\") + (setq end (if trim (1- (point)) (point)) + start (if trim (1+ start) start)))))) + (setq end (progn (re-search-forward "\\([[:blank:]]+\\|$\\)" (point-max) t) + (match-beginning 0)))) + (buffer-substring-no-properties start end))) + +(defun gnus-search-query-end-of-input () + "Are we at the end of input?" + (skip-chars-forward "[[:blank:]]") + (looking-at "$")) + +;;; Search engines + +;; Search engines are implemented as classes. This is good for two +;; things: encapsulating things like indexes and search prefixes, and +;; transforming search queries. + +(defclass gnus-search-engine () + ((raw-queries-p + :initarg :raw-queries-p + :initform nil + :type boolean + :custom boolean + :documentation + "When t, searches through this engine will never be parsed or + transformed, and must be entered \"raw\".")) + :abstract t + :documentation "Abstract base class for Gnus search engines.") + +(defclass gnus-search-grep () + ((grep-program + :initarg :grep-program + :initform "grep" + :type string + :documentation "Grep executable to use for second-pass grep + searches.") + (grep-options + :initarg :grep-options + :initform nil + :type list + :documentation "Additional options, in the form of a list, + passed to the second-pass grep search, when present.")) + :abstract t + :documentation "An abstract mixin class that can be added to + local-filesystem search engines, providing an additional grep: + search key. After the base engine returns a list of search + results (as local filenames), an external grep process is used + to further filter the results.") + +(cl-defgeneric gnus-search-grep-search (engine artlist criteria) + "Run a secondary grep search over a list of preliminary results. + +ARTLIST is a list of (filename score) pairs, produced by one of +the other search engines. CRITERIA is a grep-specific search +key. This method uses an external grep program to further filter +the files in ARTLIST by that search key.") + +(cl-defmethod gnus-search-grep-search ((engine gnus-search-grep) + artlist criteria) + (with-slots (grep-program grep-options) engine + (if (executable-find grep-program) + ;; Don't catch errors -- allow them to propagate. + (let ((matched-files + (apply + #'process-lines + grep-program + `("-l" ,@grep-options + "-e" ,(shell-quote-argument criteria) + ,@(mapcar #'car artlist))))) + (seq-filter (lambda (a) (member (car a) matched-files)) + artlist)) + (nnheader-report 'search "invalid grep program: %s" grep-program)))) + +(defclass gnus-search-process () + ((proc-buffer + :initarg :proc-buffer + :type buffer + :documentation "A temporary buffer this engine uses for its + search process, and for munging its search results.")) + :abstract t + :documentation + "A mixin class for engines that do their searching in a single + process launched for this purpose, which returns at the end of + the search. Subclass instances are safe to be run in + threads.") + +(cl-defmethod shared-initialize ((engine gnus-search-process) + slots) + (setq slots (plist-put slots :proc-buffer + (get-buffer-create + (generate-new-buffer-name " *gnus-search-")))) + (cl-call-next-method engine slots)) + +(defclass gnus-search-imap (gnus-search-engine) + ((literal-plus + :initarg :literal-plus + :initform nil + :type boolean + :documentation + "Can this search engine handle literal+ searches? This slot + is set automatically by the imap server, and cannot be + set manually. Only the LITERAL+ capability is handled.") + (multisearch + :initarg :multisearch + :initform nil + :type boolean + :documentation + "Can this search engine handle the MULTISEARCH capability? + This slot is set automatically by the imap server, and cannot + be set manually. Currently unimplemented.") + (fuzzy + :initarg :fuzzy + :initform nil + :type boolean + :documentation + "Can this search engine handle the FUZZY search capability? + This slot is set automatically by the imap server, and cannot + be set manually. Currently only partially implemented.")) + :documentation + "The base IMAP search engine, using an IMAP server's search capabilites. + +This backend may be subclassed to handle particular IMAP servers' +quirks.") + +(eieio-oset-default 'gnus-search-imap 'raw-queries-p + gnus-search-imap-raw-queries-p) + +(defclass gnus-search-find-grep (gnus-search-engine + gnus-search-process + gnus-search-grep) + nil) + +(defclass gnus-search-gmane (gnus-search-engine gnus-search-process) + nil) + +;;; The "indexed" search engine. These are engines that use an +;;; external program, with indexes kept on disk, to search messages +;;; usually kept in some local directory. The three common slots are +;;; "program", holding the string name of the executable; "switches", +;;; holding additional switches to pass to the executable; and +;;; "prefix", which is sort of the path to the found messages which +;;; should be removed so that Gnus can find them. Many of the +;;; subclasses also allow distinguishing multiple databases or +;;; indexes. These slots can be set using a global default, or on a +;;; per-server basis. + +(defclass gnus-search-indexed (gnus-search-engine + gnus-search-process + gnus-search-grep) + ((program + :initarg :program + :type string + :documentation + "The executable used for indexing and searching.") + (config-file + :init-arg :config-file + :type string + :custom file + :documentation "Location of the config file, if any.") + (remove-prefix + :initarg :remove-prefix + :type string + :documentation + "The path to the directory where the indexed mails are + kept. This path is removed from the search results.") + (switches + :initarg :switches + :type list + :documentation + "Additional switches passed to the search engine command-line + program.")) + :abstract t + :allow-nil-initform t + :documentation "A base search engine class that assumes a local search index + accessed by a command line program.") + +(eieio-oset-default 'gnus-search-indexed 'remove-prefix + (concat (getenv "HOME") "/Mail/")) + +(defclass gnus-search-swish-e (gnus-search-indexed) + ((index-files + :init-arg :index-files + :type list))) + +(eieio-oset-default 'gnus-search-swish-e 'program + gnus-search-swish-e-program) + +(eieio-oset-default 'gnus-search-swish-e 'remove-prefix + gnus-search-swish-e-remove-prefix) + +(eieio-oset-default 'gnus-search-swish-e 'index-files + gnus-search-swish-e-index-files) + +(eieio-oset-default 'gnus-search-swish-e 'switches + gnus-search-swish-e-switches) + +(eieio-oset-default 'gnus-search-swish-e 'raw-queries-p + gnus-search-swish-e-raw-queries-p) + +(defclass gnus-search-swish++ (gnus-search-indexed) + nil) + +(eieio-oset-default 'gnus-search-swish++ 'program + gnus-search-swish++-program) + +(eieio-oset-default 'gnus-search-swish++ 'remove-prefix + gnus-search-swish++-remove-prefix) + +(eieio-oset-default 'gnus-search-swish++ 'config-file + gnus-search-swish++-config-file) + +(eieio-oset-default 'gnus-search-swish++ 'switches + gnus-search-swish++-switches) + +(eieio-oset-default 'gnus-search-swish++ 'raw-queries-p + gnus-search-swish++-raw-queries-p) + +(defclass gnus-search-mairix (gnus-search-indexed) + nil) + +(eieio-oset-default 'gnus-search-mairix 'program + gnus-search-mairix-program) + +(eieio-oset-default 'gnus-search-mairix 'switches + gnus-search-mairix-switches) + +(eieio-oset-default 'gnus-search-mairix 'remove-prefix + gnus-search-mairix-remove-prefix) + +(eieio-oset-default 'gnus-search-mairix 'config-file + gnus-search-mairix-config-file) + +(eieio-oset-default 'gnus-search-mairix 'raw-queries-p + gnus-search-mairix-raw-queries-p) + +(defclass gnus-search-namazu (gnus-search-indexed) + ((index-directory + :initarg :index-directory + :type string + :custom directory))) + +(eieio-oset-default 'gnus-search-namazu 'program + gnus-search-namazu-program) + +(eieio-oset-default 'gnus-search-namazu 'index-directory + gnus-search-namazu-index-directory) + +(eieio-oset-default 'gnus-search-namazu 'switches + gnus-search-namazu-switches) + +(eieio-oset-default 'gnus-search-namazu 'remove-prefix + gnus-search-namazu-remove-prefix) + +(eieio-oset-default 'gnus-search-namazu 'raw-queries-p + gnus-search-namazu-raw-queries-p) + +(defclass gnus-search-notmuch (gnus-search-indexed) + nil) + +(eieio-oset-default 'gnus-search-notmuch 'program + gnus-search-notmuch-program) + +(eieio-oset-default 'gnus-search-notmuch 'switches + gnus-search-notmuch-switches) + +(eieio-oset-default 'gnus-search-notmuch 'remove-prefix + gnus-search-notmuch-remove-prefix) + +(eieio-oset-default 'gnus-search-notmuch 'config-file + gnus-search-notmuch-config-file) + +(eieio-oset-default 'gnus-search-notmuch 'raw-queries-p + gnus-search-notmuch-raw-queries-p) + +(define-obsolete-variable-alias 'nnir-method-default-engines + 'gnus-search-default-engines "28.1") + +(defcustom gnus-search-default-engines '((nnimap gnus-search-imap) + (nntp gnus-search-gmane)) + "Alist of default search engines keyed by server method." + :version "26.1" + :group 'gnus-search + :type `(repeat (list (choice (const nnimap) (const nntp) (const nnspool) + (const nneething) (const nndir) (const nnmbox) + (const nnml) (const nnmh) (const nndraft) + (const nnfolder) (const nnmaildir)) + (choice + ,@(mapcar + (lambda (el) (list 'const (intern (car el)))) + (eieio-build-class-alist 'gnus-search-engine t)))))) + +;;; Transforming and running search queries. + +(cl-defgeneric gnus-search-run-search (engine server query groups) + "Run QUERY in GROUPS against SERVER, using search ENGINE. +Should return results as a vector of vectors.") + +(cl-defgeneric gnus-search-transform (engine expression) + "Transform sexp EXPRESSION into a string search query usable by ENGINE. +Responsible for handling and, or, and parenthetical expressions.") + +(cl-defgeneric gnus-search-transform-expression (engine expression) + "Transform a basic EXPRESSION into a string usable by ENGINE.") + +(cl-defgeneric gnus-search-make-query-string (engine query-spec) + "Extract the actual query string to use from QUERY-SPEC.") + +;; Methods that are likely to be the same for all engines. + +(cl-defmethod gnus-search-make-query-string ((engine gnus-search-engine) + query-spec) + (if (and gnus-search-use-parsed-queries + (null (alist-get 'raw query-spec)) + (null (slot-value engine 'raw-queries-p))) + (gnus-search-transform + engine (alist-get 'parsed-query query-spec)) + (alist-get 'query query-spec))) + +(defsubst gnus-search-single-p (query) + "Return t if QUERY is a search for a single message." + (let ((q (alist-get 'parsed-query query))) + (and (= (length q ) 1) + (consp (car-safe q)) + (eq (caar q) 'id)))) + +(cl-defmethod gnus-search-transform ((engine gnus-search-engine) + (query list)) + (let (clauses) + (mapc + (lambda (item) + (when-let ((expr (gnus-search-transform-expression engine item))) + (push expr clauses))) + query) + (mapconcat #'identity (reverse clauses) " "))) + +;; Most search engines just pass through plain strings. +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-engine) + (expr string)) + expr) + +;; Most search engines use implicit ANDs. +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-engine) + (_expr (eql and))) + nil) + +;; Most search engines use explicit infixed ORs. +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-engine) + (expr (head or))) + (let ((left (gnus-search-transform-expression engine (nth 1 expr))) + (right (gnus-search-transform-expression engine (nth 2 expr)))) + ;; Unhandled keywords return a nil; don't create an "or" expression + ;; unless both sub-expressions are non-nil. + (if (and left right) + (format "%s or %s" left right) + (or left right)))) + +;; Most search engines just use the string "not" +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-engine) + (expr (head not))) + (let ((next (gnus-search-transform-expression engine (cadr expr)))) + (when next + (format "not %s" next)))) + +;;; Search Engine Interfaces: + +(autoload 'nnimap-change-group "nnimap") +(declare-function nnimap-buffer "nnimap" ()) +(declare-function nnimap-command "nnimap" (&rest args)) + +;; imap interface +(cl-defmethod gnus-search-run-search ((engine gnus-search-imap) + srv query groups) + (save-excursion + (let ((server (cadr (gnus-server-to-method srv))) + (gnus-inhibit-demon t) + ;; We're using the message id to look for a single message. + (single-search (gnus-search-single-p query)) + (grouplist (or groups (gnus-search-get-active srv))) + q-string artlist group) + (message "Opening server %s" server) + ;; We should only be doing this once, in + ;; `nnimap-open-connection', but it's too frustrating to try to + ;; get to the server from the process buffer. + (with-current-buffer (nnimap-buffer) + (setf (slot-value engine 'literal-plus) + (when (nnimap-capability "LITERAL+") t)) + ;; MULTISEARCH not yet implemented. + (setf (slot-value engine 'multisearch) + (when (nnimap-capability "MULTISEARCH") t)) + ;; FUZZY only partially supported: the command is sent to the + ;; server (and presumably acted upon), but we don't yet + ;; request a RELEVANCY score as part of the response. + (setf (slot-value engine 'fuzzy) + (when (nnimap-capability "SEARCH=FUZZY") t))) + + (setq q-string + (gnus-search-make-query-string engine query)) + + ;; If it's a thread query, make sure that all message-id + ;; searches are also references searches. + (when (alist-get 'thread query) + (setq q-string + (replace-regexp-in-string + "HEADER Message-Id \\([^ )]+\\)" + "(OR HEADER Message-Id \\1 HEADER References \\1)" + q-string))) + + (while (and (setq group (pop grouplist)) + (or (null single-search) (null artlist))) + (when (nnimap-change-group + (gnus-group-short-name group) server) + (with-current-buffer (nnimap-buffer) + (message "Searching %s..." group) + (let ((result + (gnus-search-imap-search-command engine q-string))) + (when (car result) + (setq artlist + (vconcat + (mapcar + (lambda (artnum) + (let ((artn (string-to-number artnum))) + (when (> artn 0) + (vector group artn 100)))) + (cdr (assoc "SEARCH" (cdr result)))) + artlist)))) + (message "Searching %s...done" group)))) + artlist))) + +(cl-defmethod gnus-search-imap-search-command ((engine gnus-search-imap) + (query string)) + "Create the IMAP search command for QUERY. +Currenly takes into account support for the LITERAL+ capability. +Other capabilities could be tested here." + (with-slots (literal-plus) engine + (when literal-plus + (setq query (split-string query "\n"))) + (cond + ((consp query) + ;; We're not really streaming, just need to prevent + ;; `nnimap-send-command' from waiting for a response. + (let* ((nnimap-streaming t) + (call + (nnimap-send-command + "UID SEARCH CHARSET UTF-8 %s" + (pop query)))) + (dolist (l query) + (process-send-string (get-buffer-process (current-buffer)) l) + (process-send-string (get-buffer-process (current-buffer)) + (if (nnimap-newlinep nnimap-object) + "\n" + "\r\n"))) + (nnimap-get-response call))) + (t (nnimap-command "UID SEARCH %s" query))))) + +;; TODO: Don't exclude booleans and date keys, just check for them +;; before checking for general keywords. +(defvar gnus-search-imap-search-keys + '(body cc bcc from header keyword larger smaller subject text to uid) + "Known IMAP search keys, excluding booleans and date keys.") + +(cl-defmethod gnus-search-transform ((_ gnus-search-imap) + (_query null)) + "ALL") + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr string)) + (unless (string-match-p "\\`/.+/\\'" expr) + ;; Also need to check for fuzzy here. Or better, do some + ;; refactoring of this stuff. + (format "TEXT %s" + (gnus-search-imap-handle-string engine expr)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr (head or))) + (let ((left (gnus-search-transform-expression engine (nth 1 expr))) + (right (gnus-search-transform-expression engine (nth 2 expr)))) + (if (and left right) + (format "(OR %s %s)" + left (format (if (eq 'or (car-safe (nth 2 expr))) + "(%s)" "%s") + right)) + (or left right)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr (head near))) + "Imap searches interpret \"near\" as \"or\"." + (setcar expr 'or) + (gnus-search-transform-expression engine expr)) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr (head not))) + "Transform IMAP NOT. +If the term to be negated is a flag, then use the appropriate UN* +boolean instead." + (if (eql (caadr expr) 'mark) + (if (string= (cdadr expr) "new") + "OLD" + (format "UN%s" (gnus-search-imap-handle-flag (cdadr expr)))) + (format "NOT %s" + (gnus-search-transform-expression engine (cadr expr))))) + +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-imap) + (expr (head mark))) + (gnus-search-imap-handle-flag (cdr expr))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) + (expr list)) + "Handle a search keyword for IMAP. +All IMAP search keywords that take a value are supported +directly. Keywords that are boolean are supported through other +means (usually the \"mark\" keyword)." + (let ((fuzzy-supported (slot-value engine 'fuzzy)) + (fuzzy "")) + (cl-case (car expr) + (date (setcar expr 'on)) + (tag (setcar expr 'keyword)) + (sender (setcar expr 'from))) + (cond + ((consp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ((eq (car expr) 'recipient) + (gnus-search-transform + engine (gnus-search-parse-query + (format + "to:%s or cc:%s or bcc:%s" + (cdr expr) (cdr expr) (cdr expr))))) + ((eq (car expr) 'address) + (gnus-search-transform + engine (gnus-search-parse-query + (format + "from:%s or to:%s or cc:%s or bcc:%s" + (cdr expr) (cdr expr) (cdr expr) (cdr expr))))) + ((memq (car expr) '(before since on sentbefore senton sentsince)) + ;; Ignore dates given as strings. + (when (listp (cdr expr)) + (format "%s %s" + (upcase (symbol-name (car expr))) + (gnus-search-imap-handle-date engine (cdr expr))))) + ((stringp (cdr expr)) + ;; If the search term starts or ends with "*", remove the + ;; asterisk. If the engine supports FUZZY, then additionally make + ;; the search fuzzy. + (when (string-match "\\`\\*\\|\\*\\'" (cdr expr)) + (setcdr expr (replace-regexp-in-string + "\\`\\*\\|\\*\\'" "" (cdr expr))) + (when fuzzy-supported + (setq fuzzy "FUZZY "))) + ;; If the search term is a regexp, drop the expression altogether. + (unless (string-match-p "\\`/.+/\\'" (cdr expr)) + (cond + ((memq (car expr) gnus-search-imap-search-keys) + (format "%s%s %s" + fuzzy + (upcase (symbol-name (car expr))) + (gnus-search-imap-handle-string engine (cdr expr)))) + ((eq (car expr) 'id) + (format "HEADER Message-ID \"%s\"" (cdr expr))) + ;; Treat what can't be handled as a HEADER search. Probably a bad + ;; idea. + (t (format "%sHEADER %s %s" + fuzzy + (car expr) + (gnus-search-imap-handle-string engine (cdr expr)))))))))) + +(cl-defmethod gnus-search-imap-handle-date ((_engine gnus-search-imap) + (date list)) + "Turn DATE into a date string recognizable by IMAP. +While other search engines can interpret partially-qualified +dates such as a plain \"January\", IMAP requires an absolute +date. + +DATE is a list of (dd mm yyyy), any element of which could be +nil. Massage those numbers into the most recent past occurrence +of whichever date elements are present." + (let ((now (decode-time (current-time)))) + ;; Set nil values to 1, current-month, current-year, or else 1, 1, + ;; current-year, depending on what we think the user meant. + (unless (seq-elt date 1) + (setf (seq-elt date 1) + (if (seq-elt date 0) + (seq-elt now 4) + 1))) + (unless (seq-elt date 0) + (setf (seq-elt date 0) 1)) + (unless (seq-elt date 2) + (setf (seq-elt date 2) + (seq-elt now 5))) + ;; Fiddle with the date until it's in the past. There + ;; must be a way to combine all these steps. + (unless (< (seq-elt date 2) + (seq-elt now 5)) + (when (< (seq-elt now 3) + (seq-elt date 0)) + (cl-decf (seq-elt date 1))) + (cond ((zerop (seq-elt date 1)) + (setf (seq-elt date 1) 1) + (cl-decf (seq-elt date 2))) + ((< (seq-elt now 4) + (seq-elt date 1)) + (cl-decf (seq-elt date 2)))))) + (format-time-string "%e-%b-%Y" (apply #'encode-time + (append '(0 0 0) + date)))) + +(cl-defmethod gnus-search-imap-handle-string ((engine gnus-search-imap) + (str string)) + (with-slots (literal-plus) engine + (if (multibyte-string-p str) + ;; If LITERAL+ is available, use it and encode string as + ;; UTF-8. + (if literal-plus + (format "{%d+}\n%s" + (string-bytes str) + (encode-coding-string str 'utf-8)) + ;; Otherwise, if the user hasn't already quoted the string, + ;; quote it for them. + (if (string-prefix-p "\"" str) + str + (format "\"%s\"" str))) + str))) + +(defun gnus-search-imap-handle-flag (flag) + "Make sure string FLAG is something IMAP will recognize." + ;; What else? What about the KEYWORD search key? + (setq flag + (pcase flag + ("flag" "flagged") + ("read" "seen") + (_ flag))) + (if (member flag '("seen" "answered" "deleted" "draft" "flagged")) + (upcase flag) + "")) + +;;; Methods for the indexed search engines. + +;; First, some common methods. + +(cl-defgeneric gnus-search-indexed-parse-output (engine server &optional groups) + "Parse the results of ENGINE's query against SERVER in GROUPS. +Locally-indexed search engines return results as a list of +filenames, sometimes with additional information. Returns a list +of viable results, in the form of a list of [group article score] +vectors.") + +(cl-defgeneric gnus-search-index-extract (engine) + "Extract a single article result from the current buffer. +Returns a list of two values: a file name, and a relevancy score. +Advances point to the beginning of the next result.") + +(cl-defmethod gnus-search-run-search ((engine gnus-search-indexed) + server query groups) + "Run QUERY against SERVER using ENGINE. +This method is common to all indexed search engines. + +Returns a list of [group article score] vectors." + + (save-excursion + (let* ((qstring (gnus-search-make-query-string engine query)) + (program (slot-value engine 'program)) + (buffer (slot-value engine 'proc-buffer)) + (cp-list (gnus-search-indexed-search-command + engine qstring query groups)) + proc exitstatus) + (set-buffer buffer) + (erase-buffer) + + (if groups + (message "Doing %s query on %s..." program groups) + (message "Doing %s query..." program)) + (setq proc (apply #'start-process (format "search-%s" server) + buffer program cp-list)) + (while (process-live-p proc) + (accept-process-output proc)) + (setq exitstatus (process-exit-status proc)) + (if (zerop exitstatus) + ;; The search results have been put into the current buffer; + ;; `parse-output' finds them there and returns the article + ;; list. + (gnus-search-indexed-parse-output engine server query groups) + (nnheader-report 'search "%s error: %s" program exitstatus) + ;; Failure reason is in this buffer, show it if the user + ;; wants it. + (when (> gnus-verbose 6) + (display-buffer buffer)) + nil)))) + +(cl-defmethod gnus-search-indexed-parse-output ((engine gnus-search-indexed) + server query &optional groups) + (let ((prefix (slot-value engine 'remove-prefix)) + (group-regexp (when groups + (regexp-opt + (mapcar + (lambda (x) (gnus-group-real-name x)) + groups)))) + artlist vectors article group) + (goto-char (point-min)) + (while (not (eobp)) + (pcase-let ((`(,f-name ,score) (gnus-search-indexed-extract engine))) + (when (and (file-readable-p f-name) + (null (file-directory-p f-name)) + (or (null groups) + (and (gnus-search-single-p query) + (alist-get 'thread query)) + (string-match-p group-regexp f-name))) + (push (list f-name score) artlist)))) + ;; Are we running an additional grep query? + (when-let ((grep-reg (alist-get 'grep query))) + (setq artlist (gnus-search-grep-search engine artlist grep-reg))) + ;; Turn (file-name score) into [group article score]. + (pcase-dolist (`(,f-name ,score) artlist) + (setq article (file-name-nondirectory f-name)) + ;; Remove prefix. + (when (and prefix + (file-name-absolute-p prefix) + (string-match (concat "^" + (file-name-as-directory prefix)) + f-name)) + (setq group (replace-match "" t t (file-name-directory f-name)))) + ;; Break the directory name down until it's something that + ;; (probably) can be used as a group name. + (setq group + (replace-regexp-in-string + "[/\\]" "." + (replace-regexp-in-string + "/?\\(cur\\|new\\|tmp\\)?/\\'" "" + (replace-regexp-in-string + "^[./\\]" "" + group nil t) + nil t) + nil t)) + + (push (vector (gnus-group-full-name group server) + (if (string-match-p "\\`[[:digit:]]+\\'" article) + (string-to-number article) + (nnmaildir-base-name-to-article-number + (substring article 0 (string-match ":" article)) + group nil)) + (if (numberp score) + score + (string-to-number score))) + vectors)) + vectors)) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-indexed)) + "Base implementation treats the whole line as a filename, and +fudges a relevancy score of 100." + (prog1 + (list (buffer-substring-no-properties (line-beginning-position) + (line-end-position)) + 100) + (forward-line 1))) + +;; Swish++ + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-swish++) + (expr (head near))) + (format "%s near %s" + (gnus-search-transform-expression engine (nth 1 expr)) + (gnus-search-transform-expression engine (nth 2 expr)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-swish++) + (expr list)) + (cond + ((listp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ;; Untested and likely wrong. + ((and (stringp (cdr expr)) + (string-prefix-p "(" (cdr expr))) + (format "%s = %s" (car expr) (gnus-search-transform + engine + (gnus-search-parse-query (cdr expr))))) + (t (format "%s = %s" (car expr) (cdr expr))))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-swish++) + (qstring string) + _query &optional _groups) + (with-slots (config-file switches) engine + `("--config-file" ,config-file + ,@switches + ,qstring + ))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-swish++)) + (when (re-search-forward + "\\(^[0-9]+\\) \\([^ ]+\\) [0-9]+ \\(.*\\)$" nil t) + (list (match-string 2) + (match-string 1)))) + +;; Swish-e + +;; I didn't do the query transformation for Swish-e, because the +;; program seems no longer to exist. + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-swish-e) + (qstring string) + _query &optional _groups) + (with-slots (index-files switches) engine + `("-f" ,@index-files + ,@switches + "-w" + ,qstring + ))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-swish-e)) + (when (re-search-forward + "\\(^[0-9]+\\) \\([^ ]+\\) \"\\([^\"]+\\)\" [0-9]+$" nil t) + (list (match-string 3) + (match-string 1)))) + +;; Namazu interface + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-namazu) + (expr list)) + (cond + ((listp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ((eql (car expr) 'body) + (cadr expr)) + ;; I have no idea which fields namazu can handle. Just do these + ;; for now. + ((memq (car expr) '(subject from to)) + (format "+%s:%s" (car expr) (cdr expr))) + ((eql (car expr) 'address) + (gnus-search-transform engine `((or (from . ,(cdr expr)) + (to . ,(cdr expr)))))) + ((eq (car expr) 'id) + (format "+message-id:%s" (cdr expr))) + (t (ignore-errors (cl-call-next-method))))) + +;; I can't tell if this is actually necessary. +(cl-defmethod gnus-search-run-search :around ((_e gnus-search-namazu) + _server _query _groups) + (let ((process-environment (copy-sequence process-environment))) + (setenv "LC_MESSAGES" "C") + (cl-call-next-method))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-namazu) + (qstring string) + query &optional _groups) + (let ((max (alist-get 'limit query))) + (with-slots (switches index-directory) engine + (append + (list "-q" ; don't be verbose + "-a" ; show all matches + "-s") ; use short format + (when max (list (format "--max=%d" max))) + switches + (list qstring index-directory))))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-namazu)) + "Extract a single message result for Namazu. +Namazu provides a little more information, for instance a score." + + (when (re-search-forward + "^\\([0-9,]+\\.\\).*\\((score: \\([0-9]+\\)\\))\n\\([^ ]+\\)" + nil t) + (list (match-string 4) + (match-string 3)))) + +;;; Notmuch interface + +(cl-defmethod gnus-search-transform ((_engine gnus-search-notmuch) + (_query null)) + "*") + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-notmuch) + (expr (head near))) + (format "%s near %s" + (gnus-search-transform-expression engine (nth 1 expr)) + (gnus-search-transform-expression engine (nth 2 expr)))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-notmuch) + (expr list)) + ;; Swap keywords as necessary. + (cl-case (car expr) + (sender (setcar expr 'from)) + ;; Notmuch's "to" is already equivalent to our "recipient". + (recipient (setcar expr 'to)) + (mark (setcar expr 'tag))) + ;; Then actually format the results. + (cl-flet ((notmuch-date (date) + (if (stringp date) + date + (pcase date + (`(nil ,m nil) + (nth (1- m) gnus-english-month-names)) + (`(nil nil ,y) + (number-to-string y)) + (`(,d ,m nil) + (format "%02d-%02d" d m)) + (`(nil ,m ,y) + (format "%02d-%d" m y)) + (`(,d ,m ,y) + (format "%d/%d/%d" m d y)))))) + (cond + ((consp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ((eql (car expr) 'address) + (gnus-search-transform engine `((or (from . ,(cdr expr)) + (to . ,(cdr expr)))))) + ((eql (car expr) 'body) + (cdr expr)) + ((memq (car expr) '(from to subject attachment mimetype tag id + thread folder path lastmod query property)) + ;; Notmuch requires message-id with no angle brackets. + (when (eql (car expr) 'id) + (setcdr + expr (replace-regexp-in-string "\\`<\\|>\\'" "" (cdr expr)))) + (format "%s:%s" (car expr) + (if (string-match "\\`\\*" (cdr expr)) + ;; Notmuch can only handle trailing asterisk + ;; wildcards, so strip leading asterisks. + (replace-match "" nil nil (cdr expr)) + (cdr expr)))) + ((eq (car expr) 'date) + (format "date:%s" (notmuch-date (cdr expr)))) + ((eq (car expr) 'before) + (format "date:..%s" (notmuch-date (cdr expr)))) + ((eq (car expr) 'since) + (format "date:%s.." (notmuch-date (cdr expr)))) + (t (ignore-errors (cl-call-next-method)))))) + +(cl-defmethod gnus-search-run-search :around ((engine gnus-search-notmuch) + server query groups) + "Handle notmuch's thread-search routine." + ;; Notmuch allows for searching threads, but only using its own + ;; thread ids. That means a thread search is a \"double-bounce\": + ;; once to find the relevant thread ids, and again to find the + ;; actual messages. This method performs the first \"bounce\". + (if (alist-get 'thread query) + (with-slots (program proc-buffer) engine + (let* ((qstring + (gnus-search-make-query-string engine query)) + (cp-list (gnus-search-indexed-search-command + engine qstring query groups)) + thread-ids proc) + (set-buffer proc-buffer) + (erase-buffer) + (setq proc (apply #'start-process (format "search-%s" server) + proc-buffer program cp-list)) + (while (process-live-p proc) + (accept-process-output proc)) + (while (re-search-forward "^thread:\\([^ ]+\\)" (point-max) t) + (push (match-string 1) thread-ids)) + (cl-call-next-method + engine server + ;; Completely replace the query with our new thread-based one. + (mapconcat (lambda (thrd) (concat "thread:" thrd)) + thread-ids " or ") + nil))) + (cl-call-next-method engine server query groups))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-notmuch) + (qstring string) + query &optional _groups) + ;; Theoretically we could use the GROUPS parameter to pass a + ;; --folder switch to notmuch, but I'm not confident of getting the + ;; format right. + (let ((limit (alist-get 'limit query)) + (thread (alist-get 'thread query))) + (with-slots (switches config-file) engine + `(,(format "--config=%s" config-file) + "search" + ,(if thread + "--output=threads" + "--output=files") + "--duplicate=1" ; I have found this necessary, I don't know why. + ,@switches + ,(if limit (format "--limit=%d" limit) "") + ,qstring + )))) + +;;; Mairix interface + +;; See the Gnus manual for why mairix searching is a bit weird. + +(cl-defmethod gnus-search-transform ((engine gnus-search-mairix) + (query list)) + "Transform QUERY for a Mairix engine. +Because Mairix doesn't accept parenthesized expressions, nor +\"or\" statements between different keys, results may differ from +other engines. We unpeel parenthesized expressions, and just +cross our fingers for the rest of it." + (let (clauses) + (mapc + (lambda (item) + (when-let ((expr (if (consp (car-safe item)) + (gnus-search-transform engine item) + (gnus-search-transform-expression engine item)))) + (push expr clauses))) + query) + (mapconcat #'identity (reverse clauses) " "))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix) + (expr (head not))) + "Transform Mairix \"not\". +Mairix negation requires a \"~\" preceding string search terms, +and \"-\" before marks." + (let ((next (gnus-search-transform-expression engine (cadr expr)))) + (replace-regexp-in-string + ":" + (if (eql (caadr expr) 'mark) + ":-" + ":~") + next))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix) + (expr (head or))) + "Handle Mairix \"or\" statement. +Mairix only accepts \"or\" expressions on homogenous keys. We +cast \"or\" expressions on heterogenous keys as \"and\", which +isn't quite right, but it's the best we can do. For date keys, +only keep one of the terms." + (let ((term1 (caadr expr)) + (term2 (caaddr expr)) + (val1 (gnus-search-transform-expression engine (nth 1 expr))) + (val2 (gnus-search-transform-expression engine (nth 2 expr)))) + (cond + ((or (listp term1) (listp term2)) + (concat val1 " " val2)) + ((and (member (symbol-name term1) gnus-search-date-keys) + (member (symbol-name term2) gnus-search-date-keys)) + (or val1 val2)) + ((eql term1 term2) + (if (and val1 val2) + (format "%s/%s" + val1 + (nth 1 (split-string val2 ":"))) + (or val1 val2))) + (t (concat val1 " " val2))))) + + +(cl-defmethod gnus-search-transform-expression ((_ gnus-search-mairix) + (expr (head mark))) + (gnus-search-mairix-handle-mark (cdr expr))) + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix) + (expr list)) + (let ((key (cl-case (car expr) + (sender "f") + (from "f") + (to "t") + (cc "c") + (subject "s") + (id "m") + (body "b") + (address "a") + (recipient "tc") + (text "bs") + (attachment "n") + (t nil)))) + (cond + ((consp (car expr)) + (gnus-search-transform engine expr)) + ((member (symbol-name (car expr)) gnus-search-date-keys) + (gnus-search-mairix-handle-date expr)) + ((memq (car expr) '(size smaller larger)) + (gnus-search-mairix-handle-size expr)) + ;; Drop regular expressions. + ((string-match-p "\\`/" (cdr expr)) + nil) + ;; Turn parenthesized phrases into multiple word terms. Again, + ;; this isn't quite what the user is asking for, but better to + ;; return false positives. + ((and key (string-match-p "[[:blank:]]" (cdr expr))) + (mapconcat + (lambda (s) (format "%s:%s" key s)) + (split-string (gnus-search-mairix-treat-string + (cdr expr))) + " ")) + (key (format "%s:%s" key + (gnus-search-mairix-treat-string + (cdr expr)))) + (t nil)))) + +(defun gnus-search-mairix-treat-string (str) + "Treat string for wildcards. +Mairix accepts trailing wildcards, but not leading. Also remove +double quotes." + (replace-regexp-in-string + "\\`\\*\\|\"" "" + (replace-regexp-in-string "\\*\\'" "=" str))) + +(defun gnus-search-mairix-handle-size (expr) + "Format a mairix size search. +Assume \"size\" key is equal to \"larger\"." + (format + (if (eql (car expr) 'smaller) + "z:-%s" + "z:%s-") + (cdr expr))) + +(defun gnus-search-mairix-handle-mark (expr) + "Format a mairix mark search." + (let ((mark + (pcase (cdr expr) + ("flag" "f") + ("read" "s") + ("seen" "s") + ("replied" "r") + (_ nil)))) + (when mark + (format "F:%s" mark)))) + +(defun gnus-search-mairix-handle-date (expr) + (let ((str + (pcase (cdr expr) + (`(nil ,m nil) + (substring + (nth (1- m) gnus-english-month-names) + 0 3)) + (`(nil nil ,y) + (number-to-string y)) + (`(,d ,m nil) + (format "%s%02d" + (substring + (nth (1- m) gnus-english-month-names) + 0 3) + d)) + (`(nil ,m ,y) + (format "%d%s" + y (substring + (nth (1- m) gnus-english-month-names) + 0 3))) + (`(,d ,m ,y) + (format "%d%02d%02d" y m d))))) + (format + (pcase (car expr) + ('date "d:%s") + ('since "d:%s-") + ('after "d:%s-") + ('before "d:-%s")) + str))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-mairix) + (qstring string) + query &optional _groups) + (with-slots (switches config-file) engine + (append `("--rcfile" ,config-file "-r") + switches + (when (alist-get 'thread query) (list "-t")) + (list qstring)))) + +;;; Find-grep interface + +(cl-defmethod gnus-search-transform-expression ((_engine gnus-search-find-grep) + (_ list)) + ;; Drop everything that isn't a plain string. + nil) + +(cl-defmethod gnus-search-run-search ((engine gnus-search-find-grep) + server query + &optional groups) + "Run find and grep to obtain matching articles." + (let* ((method (gnus-server-to-method server)) + (sym (intern + (concat (symbol-name (car method)) "-directory"))) + (directory (cadr (assoc sym (cddr method)))) + (regexp (alist-get 'grep query)) + (grep-options (slot-value engine 'grep-options)) + (grouplist (or groups (gnus-search-get-active server))) + (buffer (slot-value engine 'proc-buffer))) + (unless directory + (error "No directory found in method specification of server %s" + server)) + (apply + 'vconcat + (mapcar (lambda (x) + (let ((group x) + artlist) + (message "Searching %s using find-grep..." + (or group server)) + (save-window-excursion + (set-buffer buffer) + (if (> gnus-verbose 6) + (pop-to-buffer (current-buffer))) + (cd directory) ; Using relative paths simplifies + ; postprocessing. + (let ((group + (if (not group) + "." + ;; Try accessing the group literally as + ;; well as interpreting dots as directory + ;; separators so the engine works with + ;; plain nnml as well as the Gnus Cache. + (let ((group (gnus-group-real-name group))) + ;; Replace cl-func find-if. + (if (file-directory-p group) + group + (if (file-directory-p + (setq group + (replace-regexp-in-string + "\\." "/" + group nil t))) + group)))))) + (unless group + (error "Cannot locate directory for group")) + (save-excursion + (apply + 'call-process "find" nil t + "find" group "-maxdepth" "1" "-type" "f" + "-name" "[0-9]*" "-exec" + (slot-value engine 'grep-program) + `("-l" ,@(and grep-options + (split-string grep-options "\\s-" t)) + "-e" ,regexp "{}" "+")))) + + ;; Translate relative paths to group names. + (while (not (eobp)) + (let* ((path (split-string + (buffer-substring + (point) + (line-end-position)) "/" t)) + (art (string-to-number (car (last path))))) + (while (string= "." (car path)) + (setq path (cdr path))) + (let ((group (mapconcat #'identity + (cl-subseq path 0 -1) + "."))) + (push + (vector (gnus-group-full-name group server) art 0) + artlist)) + (forward-line 1))) + (message "Searching %s using find-grep...done" + (or group server)) + artlist))) + grouplist)))) + +(declare-function mm-url-insert "mm-url" (url &optional follow-refresh)) +(declare-function mm-url-encode-www-form-urlencoded "mm-url" (pairs)) + +;; gmane interface +(cl-defmethod gnus-search-run-search ((engine gnus-search-gmane) + srv query &optional groups) + "Run a search against a gmane back-end server." + (let* ((case-fold-search t) + (groupspec (mapconcat + (lambda (x) + (if (string-match-p "gmane" x) + (format "group:%s" (gnus-group-short-name x)) + (error "Can't search non-gmane groups: %s" x))) + groups " ")) + (buffer (slot-value engine 'proc-buffer)) + (search (concat (gnus-search-make-query-string engine query) + " " + groupspec)) + (gnus-inhibit-demon t) + artlist) + (require 'mm-url) + (with-current-buffer buffer + (erase-buffer) + (mm-url-insert + (concat + "http://search.gmane.org/nov.php" + "?" + (mm-url-encode-www-form-urlencoded + `(("query" . ,search) + ("HITSPERPAGE" . "999"))))) + (set-buffer-multibyte t) + (decode-coding-region (point-min) (point-max) 'utf-8) + (goto-char (point-min)) + (forward-line 1) + (while (not (eobp)) + (unless (or (eolp) (looking-at "\x0d")) + (let ((header (nnheader-parse-nov))) + (let ((xref (mail-header-xref header)) + (xscore (string-to-number (cdr (assoc 'X-Score + (mail-header-extra header)))))) + (when (string-match " \\([^:]+\\)[:/]\\([0-9]+\\)" xref) + (push + (vector + (gnus-group-prefixed-name (match-string 1 xref) srv) + (string-to-number (match-string 2 xref)) xscore) + artlist))))) + (forward-line 1))) + (apply #'vector (nreverse (delete-dups artlist))))) + +(cl-defmethod gnus-search-transform-expression ((_e gnus-search-gmane) + (_expr (head near))) + nil) + +;; Can Gmane handle OR or NOT keywords? +(cl-defmethod gnus-search-transform-expression ((_e gnus-search-gmane) + (_expr (head or))) + nil) + +(cl-defmethod gnus-search-transform-expression ((_e gnus-search-gmane) + (_expr (head not))) + nil) + +(cl-defmethod gnus-search-transform-expression ((_e gnus-search-gmane) + (expr list)) + "The only keyword value gmane can handle is author, ie from." + (cond + ((memq (car expr) '(from sender author address)) + (format "author:%s" (cdr expr))) + ((eql (car expr) 'body) + (cdr expr)))) + +;;; Util Code: + +(defun gnus-search-run-query (specs) + "Invoke appropriate search engine function." + ;; For now, run the searches synchronously. At some point + ;; multiple-server searches can each be run in their own thread, + ;; allowing concurrent searches of multiple backends. At present + ;; this causes problems when searching more than one server that + ;; uses `nntp-server-buffer', as their return values are written + ;; interleaved into that buffer. Anyway, that's the reason for the + ;; `mapc'. + (let* ((results []) + (prepared-query (gnus-search-prepare-query + (alist-get 'search-query-spec specs))) + (limit (alist-get 'limit prepared-query))) + (mapc + (pcase-lambda (`(,server . ,groups)) + (let ((search-engine (gnus-search-server-to-engine server))) + (setq results + (vconcat + (gnus-search-run-search + search-engine server prepared-query groups) + results)))) + (alist-get 'search-group-spec specs)) + ;; Some search engines do their own limiting, but some don't, so + ;; do it again here. This is bad because, if the user is + ;; searching multiple groups, they would reasonably expect the + ;; limiting to apply to the search results *after sorting*. Doing + ;; it this way is liable to, for instance, eliminate all results + ;; from a later group entirely. + (if limit + (seq-subseq results 0 (min limit (length results))) + results))) + +(defun gnus-search-prepare-query (query-spec) + "Accept a search query in raw format, and prepare it. +QUERY-SPEC is an alist produced by functions such as +`gnus-group-make-search-group', and contains at least a 'query +key, and possibly some meta keys. This function extracts any +additional meta keys from the 'query string, and parses the +remaining string, then adds all that to the top-level spec." + (let ((query (alist-get 'query query-spec)) + val) + (when (stringp query) + ;; Look for these meta keys: + (while (string-match + "\\(thread\\|grep\\|limit\\|raw\\):\\([^ ]+\\)" + query) + (setq val (match-string 2 query)) + (setf (alist-get (intern (match-string 1 query)) query-spec) + ;; This is stupid. + (cond + ((equal val "t")) + ((null (zerop (string-to-number val))) + (string-to-number val)) + (t val))) + (setq query + (string-trim (replace-match "" t t query 0))) + (setf (alist-get 'query query-spec) query))) + (when gnus-search-use-parsed-queries + (setf (alist-get 'parsed-query query-spec) + (gnus-search-parse-query query))) + query-spec)) + +;; This should be done once at Gnus startup time, when the servers are +;; first opened, and the resulting engine instance attached to the +;; server. +(defun gnus-search-server-to-engine (srv) + (let* ((method (gnus-server-to-method srv)) + (server + (or (assoc 'gnus-search-engine (cddr method)) + (assoc (car method) gnus-search-default-engines) + (when-let ((old (assoc 'nnir-search-engine + (cddr method)))) + (nnheader-message + 8 "\"nnir-search-engine\" is no longer a valid parameter") + (pcase old + ('notmuch 'gnus-search-notmuch) + ('namazu 'gnus-search-namazu) + ('find-grep 'gnus-search-find-grep))))) + (inst + (cond + ((null server) nil) + ((eieio-object-p (cadr server)) + (cadr server)) + ((class-p (cadr server)) + (make-instance (cadr server))) + (t nil)))) + (if inst + (when (cddr server) + (pcase-dolist (`(,key ,value) (cddr server)) + (condition-case nil + (setf (slot-value inst key) value) + ((invalid-slot-name invalid-slot-type) + (nnheader-message + 5 "Invalid search engine parameter: (%s %s)" + key value))))) + (nnheader-message 5 "No search engine defined for %s" srv)) + inst)) + +(declare-function gnus-registry-get-id-key "gnus-registry" (id key)) + +(defun gnus-search-thread (header) + "Make an nnselect 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* ((ids (cons (mail-header-id header) + (split-string + (or (mail-header-references header) + "")))) + (query + (list (cons 'query (mapconcat (lambda (i) + (format "id:%s" i)) + ids " or ")) + (cons 'thread t))) + (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-search-group nil (list + (cons 'search-query-spec query) + (cons 'search-group-spec server))) + (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header))))) + +(defun gnus-search-get-active (srv) + (let ((method (gnus-server-to-method srv)) + groups) + (gnus-request-list method) + (with-current-buffer nntp-server-buffer + (let ((cur (current-buffer))) + (goto-char (point-min)) + (unless (or (null gnus-search-ignored-newsgroups) + (string= gnus-search-ignored-newsgroups "")) + (delete-matching-lines gnus-search-ignored-newsgroups)) + (if (eq (car method) 'nntp) + (while (not (eobp)) + (ignore-errors + (push (gnus-group-decoded-name + (gnus-group-full-name + (buffer-substring + (point) + (progn + (skip-chars-forward "^ \t") + (point))) + method)) + groups)) + (forward-line)) + (while (not (eobp)) + (ignore-errors + (push (gnus-group-decoded-name + (if (eq (char-after) ?\") + (gnus-group-full-name (read cur) method) + (let ((p (point)) (name "")) + (skip-chars-forward "^ \t\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^ \t\\\\") + (setq name (concat name (buffer-substring + p (point))))) + (gnus-group-full-name name method)))) + groups)) + (forward-line))))) + groups)) + +(defvar gnus-search-minibuffer-map + (let ((km (make-sparse-keymap))) + (set-keymap-parent km minibuffer-local-map) + (define-key km (kbd "SPC") #'self-insert-command) + (define-key km (kbd "TAB") #'gnus-search-complete-key) + km)) + +(defun gnus-search-complete-key () + "Complete a search key at point. +Used when reading a search query from the minibuffer." + (interactive) + (when (completion-in-region + (save-excursion + (if (re-search-backward " " (minibuffer-prompt-end) t) + (1+ (point)) + (minibuffer-prompt-end))) + (point) gnus-search-expandable-keys) + (insert ":"))) + +(defun gnus-search-make-spec (arg) + (list (cons 'query + (read-from-minibuffer + "Query: " nil gnus-search-minibuffer-map + nil 'gnus-search-history)) + (cons 'raw arg))) + +(provide 'gnus-search) +;;; gnus-search.el ends here diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 21206b683c..ce2e99de05 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -36,10 +36,10 @@ ;; 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. +;; For example the search function `gnus-search-run-query' applied to +;; arguments specifying a search query (see "gnus-search.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: @@ -47,7 +47,7 @@ ;;; Setup: (require 'gnus-art) -(require 'nnir) +(require 'gnus-search) (eval-when-compile (require 'cl-lib)) @@ -372,25 +372,25 @@ nnselect-request-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))) + (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))) + (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 + (gnus-search-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)))) + (cons 'search-query-spec + (list (cons 'query `((id . ,article))) + (cons 'criteria "") (cons 'shortcut t))) + (cons 'search-group-spec servers)))) (unless (zerop (nnselect-artlist-length artlist)) (setq group-art @@ -603,26 +603,35 @@ nnselect-request-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))) + ;; Check if search-based thread referral is permitted, and + ;; available. + (if (and gnus-refer-thread-use-search + (gnus-search-server-to-engine + (gnus-method-to-server + (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 + (unless gnus-refer-thread-use-search artgroup))))) + (ids (cons (mail-header-id header) + (split-string + (or (mail-header-references header) + "")))) (query-spec - (list (cons 'query (nnimap-make-thread-query header)) - (cons 'criteria ""))) + (list (cons 'query (mapconcat (lambda (i) + (format "id:%s" i)) + ids " or ")) + (cons 'thread t))) (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)))) + (gnus-search-run-query + (list (cons 'search-query-spec query-spec) + (cons 'search-group-spec group-spec)))) old-arts seq headers) (mapc @@ -670,7 +679,7 @@ nnselect-request-thread group (cons 1 (nnselect-artlist-length gnus-newsgroup-selection)))) headers) - ;; If not an imap backend just warp to the original article + ;; If we can't or won't use search, just warp to the original ;; group and punt back to gnus-summary-refer-thread. (and (gnus-warp-to-article) (gnus-summary-refer-thread)))))) @@ -768,9 +777,15 @@ nnselect-search-thread 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 ""))) + (let* ((ids (cons (mail-header-id header) + (split-string + (or (mail-header-references header) + "")))) + (query + (list (cons 'query (mapconcat (lambda (i) + (format "id:%s" i)) + ids " or ")) + (cons 'thread t))) (server (list (list (gnus-method-to-server (gnus-find-method-for-group gnus-newsgroup-name))))) @@ -794,10 +809,10 @@ nnselect-search-thread (list (cons 'nnselect-specs (list - (cons 'nnselect-function 'nnir-run-query) + (cons 'nnselect-function 'gnus-search-run-query) (cons 'nnselect-args - (list (cons 'nnir-query-spec query) - (cons 'nnir-group-spec server))))) + (list (cons 'search-query-spec query) + (cons 'search-group-spec server))))) (cons 'nnselect-artlist nil))) (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header))))) @@ -929,18 +944,18 @@ nnselect-push-info (declare-function gnus-registry-get-id-key "gnus-registry" (id key)) -(defun gnus-summary-make-search-group (nnir-extra-parms) +(defun gnus-summary-make-search-group (no-parse) "Search a group from the summary buffer. -Pass NNIR-EXTRA-PARMS on to the search engine." +Pass NO-PARSE on to the search engine." (interactive "P") (gnus-warp-to-article) (let ((spec (list - (cons 'nnir-group-spec + (cons 'search-group-spec (list (list (gnus-group-server gnus-newsgroup-name) gnus-newsgroup-name)))))) - (gnus-group-make-search-group nnir-extra-parms spec))) + (gnus-group-make-search-group no-parse spec))) ;; The end. diff --git a/test/lisp/gnus/search-tests.el b/test/lisp/gnus/search-tests.el new file mode 100644 index 0000000000..7c0a856900 --- /dev/null +++ b/test/lisp/gnus/search-tests.el @@ -0,0 +1,99 @@ +;;; gnus-search-tests.el --- Tests for Gnus' search routines -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; Author: Eric Abrahamsen +;; Keywords: + +;; This program 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. + +;; This program 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 this program. If not, see . + +;;; Commentary: + +;; Tests for the search parsing, search engines, and their +;; transformations. + +;;; Code: + +(require 'ert) +(require 'gnus-search) + +(ert-deftest gnus-s-parse () + "Test basic structural parsing." + (let ((pairs + '(("string" . ("string")) + ("from:john" . ((from . "john"))) + ("here and there" . ("here" and "there")) + ("here or there" . ((or "here" "there"))) + ("here (there or elsewhere)" . ("here" ((or "there" "elsewhere")))) + ("here not there" . ("here" (not "there"))) + ("from:boss or not vacation" . ((or (from . "boss") (not "vacation"))))))) + (dolist (p pairs) + (should (equal (gnus-search-parse-query (car p)) (cdr p)))))) + +(ert-deftest gnus-s-expand-keyword () + "Test expansion of keywords" + (let ((gnus-search-expandable-keys + (default-value 'gnus-search-expandable-keys)) + (pairs + '(("su" . "subject") + ("f" . "from") + ("co-f" . "contact-from")))) + (dolist (p pairs) + (should (equal (gnus-search-query-expand-key (car p)) + (cdr p)))) + (should-error (gnus-search-query-expand-key "s") + :type 'gnus-search-parse-error) + (should-error (gnus-search-query-expand-key "c-f") + :type 'gnus-search-parse-error))) + +(ert-deftest gnus-s-parse-date () + "Test parsing of date expressions." + (let ((rel-date (encode-time 0 0 0 15 4 2017)) + (pairs + '(("January" . (nil 1 nil)) + ("2017" . (nil nil 2017)) + ("15" . (15 nil nil)) + ("January 15" . (15 1 nil)) + ("tuesday" . (11 4 2017)) + ("1d" . (14 4 2017)) + ("1w" . (8 4 2017))))) + (dolist (p pairs) + (should (equal (gnus-search-query-parse-date (car p) rel-date) + (cdr p)))))) + +(ert-deftest gnus-s-delimited-string () + "Test proper functioning of `gnus-search-query-return-string'." + (with-temp-buffer + (insert "one\ntwo words\nthree \"words with quotes\"\n\"quotes at start\"\n/alternate \"quotes\"/\n(more bits)") + (goto-char (point-min)) + (should (string= (gnus-search-query-return-string) + "one")) + (forward-line) + (should (string= (gnus-search-query-return-string) + "two")) + (forward-line) + (should (string= (gnus-search-query-return-string) + "three")) + (forward-line) + (should (string= (gnus-search-query-return-string "\"") + "\"quotes at start\"")) + (forward-line) + (should (string= (gnus-search-query-return-string "/") + "/alternate \"quotes\"/")) + (forward-line) + (should (string= (gnus-search-query-return-string ")" t) + "more bits")))) + +(provide 'gnus-search-tests) +;;; search-tests.el ends here -- 2.29.1