From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED!not-for-mail From: Eric Abrahamsen Newsgroups: gmane.emacs.devel,gmane.emacs.gnus.general Subject: [RFC] Gnus generalized search, part II Date: Fri, 21 Apr 2017 14:35:06 -0700 Message-ID: <87zif930mt.fsf@ericabrahamsen.net> NNTP-Posting-Host: blaine.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: blaine.gmane.org 1492810589 25279 195.159.176.226 (21 Apr 2017 21:36:29 GMT) X-Complaints-To: usenet@blaine.gmane.org NNTP-Posting-Date: Fri, 21 Apr 2017 21:36:29 +0000 (UTC) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.0.50 (gnu/linux) Cc: ding@gnus.org To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Fri Apr 21 23:36:25 2017 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by blaine.gmane.org with esmtp (Exim 4.84_2) (envelope-from ) id 1d1gE3-0006SY-Fq for ged-emacs-devel@m.gmane.org; Fri, 21 Apr 2017 23:36:24 +0200 Original-Received: from localhost ([::1]:33285 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d1gE9-0000sE-A5 for ged-emacs-devel@m.gmane.org; Fri, 21 Apr 2017 17:36:29 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:53334) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d1gDN-0000rv-79 for emacs-devel@gnu.org; Fri, 21 Apr 2017 17:35:42 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d1gDK-0001K0-0S for emacs-devel@gnu.org; Fri, 21 Apr 2017 17:35:41 -0400 Original-Received: from [195.159.176.226] (port=37927 helo=blaine.gmane.org) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d1gDJ-0001Jb-Ba for emacs-devel@gnu.org; Fri, 21 Apr 2017 17:35:37 -0400 Original-Received: from list by blaine.gmane.org with local (Exim 4.84_2) (envelope-from ) id 1d1gDA-0005DB-OL for emacs-devel@gnu.org; Fri, 21 Apr 2017 23:35:28 +0200 X-Injected-Via-Gmane: http://gmane.org/ Original-Followup-To: gmane.emacs.devel Original-Lines: 2689 Original-X-Complaints-To: usenet@blaine.gmane.org Cancel-Lock: sha1:R5T/zxkO+vgEGyamJQR3du14B0k= X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] [fuzzy] X-Received-From: 195.159.176.226 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.org gmane.emacs.devel:214198 gmane.emacs.gnus.general:87465 Archived-At: --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: 8bit I've been working on a generalized searching for Gnus, where a single query language gets translated into different search-engine-appropriate strings. This allows searching multiple backends at once. It's more or less working, and I'm attaching the new version of the nnir.el file here which can be used as a drop-in replacement for the existing file. Ideally, if accepted, this would get rebased on top of Andy Cohen's reworking of nnir/nnselect. How it works: The query entered by the user is parsed into a sexp structure, and then each engine is responsible for interpreting that. For instance, you mark one IMAP group, and one maildir group (indexed with notmuch). Then you enter a query: "from:john after:1w or -mark:!" Internally, this becomes: ((from . "john") (or (since 14 4 2017) (not (mark . "flag")))) The imap engine turns that into: "FROM john OR SINCE 14-Apr-2017 UNFLAGGED" And the notmuch engine turns it into: "from:john date:4/14/2017.. or not tag:flag" Results from both servers are put in the same summary buffer. That's pretty much it, I hope people will be interested in this. I've started writing tests, and will do documentation if this is accepted. I've pasted the complete docstring of nnir-search-parse-query below. --------------------- Notes for the curious: The search engines are now implemented as classes. This allowed for factoring out a bunch of common code. I nearly set this up for running multiple searches each in their own thread, allowing for limited search concurrency. I backed off at the last minute because of weird IMAP behavior, but the code is pretty much set up for threads, if IMAP can get sorted out. I re-implemented a limited version of the IMAP LITERAL+ code I wrote years ago. If the server advertises support, searches for non-ASCII strings will make use the LITERAL+ mechanism. ¡¡Turning this on enforces CHARSET UTF-8!! Ie, the assumption is that if a server can handle LITERAL+, it can handle CHARSET UTF-8. This is probably totally wrong, but it would be easy to shut off, or fix if I can figure out how to DTRT. So far as I can tell, Hyrex and Swish-e are defunct. They're still in there, but their search transformation is lacking because there are no good docs. Namazu docs are also lacking: they give the examples of searching on "message-id", "from", and "subject" headers, but are there more? I don't know. I can't test because mknmz errors on my machine. Things I'd like to add: 1. Support for IMAP MULTISEARCH and FUZZY 2. A command to automatically update all engine indexes. 3. Regular expression searches for engines that support them. 4. Engines for lucene, solr, raw xapian, sphinx... What else are people using? There's a base class for locally-indexed search engines, so these should be easy to add. 5. Create an offline index of gmane messages, to be updated monthly. The gmane search engine would search locally but request remotely (only partly joking). ------------------------------ nnir-search-parse-query is a Lisp closure. (nnir-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 ‘nnir-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 ‘nnir-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. --=-=-= Content-Type: application/emacs-lisp Content-Disposition: attachment; filename=nnir.el Content-Transfer-Encoding: quoted-printable ;;; nnir.el --- Search mail with various search engines -*- lexical-bindin= g:t -*- ;; Copyright (C) 1998-2017 Free Software Foundation, Inc. ;; Author: Kai Gro=C3=9Fjohann ;; Swish-e and Swish++ backends by: ;; Christoph Conrad . ;; IMAP backend by: Simon Josefsson . ;; IMAP search by: Torsten Hilbrich gmx.net> ;; IMAP search improved by Daniel Pittman . ;; nnmaildir support for Swish-e, Swish++ and Namazu backends by: ;; Justus Piater Piater.name> ;; Keywords: news mail searching ir ;; This file is part of GNU Emacs. ;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . ;;; Commentary: ;; What does it do? Well, it allows you to search your mail using ;; some search engine (imap, namazu, gmane and others -- see ;; later) by typing `G G' in the Group buffer. You will then get a ;; buffer which shows all articles matching the query, sorted by ;; Retrieval Status Value (score). ;; When looking at the retrieval result (in the Summary buffer) you ;; can type `A W' (aka M-x gnus-warp-to-article RET) on an article. You ;; will be warped into the group this article came from. Typing `A T' ;; (aka M-x gnus-summary-refer-thread RET) will warp to the group and ;; also show the thread this article is part of. ;; The Lisp setup may involve setting a few variables and setting up the ;; search engine. You can define the variables in the server definition ;; like this : ;; (setq gnus-secondary-select-methods '( ;; (nnimap "" (nnimap-address "localhost") ;; (nnir-search-engine namazu) ;; ))) ;; The main variable to set is `nnir-search-engine'. Choose one of ;; the engines listed in `nnir-engines'. (Actually `nnir-engines' is ;; an alist, type `C-h v nnir-engines RET' for more information; this ;; includes examples for setting `nnir-search-engine', too.) ;; If you use one of the local indices (namazu, find-grep, swish) you ;; must also set up a search engine backend. ;; 1. Namazu ;; ;; The Namazu backend requires you to have one directory containing all ;; index files, this is controlled by the `nnir-namazu-index-directory' ;; variable. To function the `nnir-namazu-remove-prefix' variable must ;; also be correct, see the documentation for `nnir-namazu-remove-prefix' ;; above. ;; ;; It is particularly important not to pass any any switches to namazu ;; that will change the output format. Good switches to use include ;; `--sort', `--ascending', `--early' and `--late'. Refer to the Namazu ;; documentation for further information on valid switches. ;; ;; To index my mail with the `mknmz' program I use the following ;; configuration file: ;; ;; ,---- ;; | package conf; # Don't remove this line! ;; | ;; | # Paths which will not be indexed. Don't use `^' or `$' anchors. ;; | $EXCLUDE_PATH =3D "spam|sent"; ;; | ;; | # Header fields which should be searchable. case-insensitive ;; | $REMAIN_HEADER =3D "from|date|message-id|subject"; ;; | ;; | # Searchable fields. case-insensitive ;; | $SEARCH_FIELD =3D "from|date|message-id|subject"; ;; | ;; | # The max length of a word. ;; | $WORD_LENG_MAX =3D 128; ;; | ;; | # The max length of a field. ;; | $MAX_FIELD_LENGTH =3D 256; ;; `---- ;; ;; My mail is stored in the directories ~/Mail/mail/, ~/Mail/lists/ and ;; ~/Mail/archive/, so to index them I go to the directory set in ;; `nnir-namazu-index-directory' and issue the following command. ;; ;; mknmz --mailnews ~/Mail/archive/ ~/Mail/mail/ ~/Mail/lists/ ;; ;; For maximum searching efficiency I have a cron job set to run this ;; command every four hours. ;; 2. find-grep ;; ;; The find-grep engine simply runs find(1) to locate eligible ;; articles and searches them with grep(1). This, of course, is much ;; slower than using a proper search engine but OTOH doesn't require ;; maintenance of an index and is still faster than using any built-in ;; means for searching. The method specification of the server to ;; search must include a directory for this engine to work (E.g., ;; `nnml-directory'). The tools must be POSIX compliant. GNU Find ;; prior to version 4.2.12 (4.2.26 on Linux due to incorrect ARG_MAX ;; handling) does not work. ;; ,---- ;; | ;; find-grep configuration for searching the Gnus Cache ;; | ;; | (nnml "cache" ;; | (nnml-get-new-mail nil) ;; | (nnir-search-engine find-grep) ;; | (nnml-directory "~/News/cache/") ;; | (nnml-active-file "~/News/cache/active")) ;; `---- ;; Developer information: ;; I have tried to make the code expandable. Basically, it is divided ;; into two layers. The upper layer is somewhat like the `nnvirtual' ;; backend: given a specification of what articles to show from ;; another backend, it creates a group containing exactly those ;; articles. The lower layer issues a query to a search engine and ;; produces such a specification of what articles to show from the ;; other backend. ;; The interface between the two layers consists of the single ;; function `nnir-run-query', which dispatches the search to the ;; proper search function. The argument of `nnir-run-query' is an ;; alist with two keys: 'nnir-query-spec and 'nnir-group-spec. The ;; value for 'nnir-query-spec is an alist. The only required key/value ;; pair is (query . "query") specifying the search string to pass to ;; the query engine. Individual engines may have other elements. The ;; value of 'nnir-group-spec is a list with the specification of the ;; groups/servers to search. The format of the 'nnir-group-spec is ;; (("server1" ("group11" "group12")) ("server2" ("group21" ;; "group22"))). If any of the group lists is absent then all groups ;; on that server are searched. ;; The output of `nnir-run-query' is supposed to be a vector, each ;; element of which should in turn be a three-element vector. The ;; first element should be full group name of the article, the second ;; element should be the article number, and the third element should ;; be the Retrieval Status Value (RSV) as returned from the search ;; engine. An RSV is the score assigned to the document by the search ;; engine. For Boolean search engines, the RSV is always 1000 (or 1 ;; or 100, or whatever you like). ;; The sorting order of the articles in the summary buffer created by ;; nnir is based on the order of the articles in the above mentioned ;; vector, so that's where you can do the sorting you'd like. Maybe ;; it would be nice to have a way of displaying the search result ;; sorted differently? ;; So what do you need to do when you want to add another search ;; engine? You write a function that executes the query. Temporary ;; data from the search engine can be put in the buffer stored in the ;; engine's tmp-buffer slot. This function should return the list of ;; articles as a vector, as described above. Then, you need to ;; register this backend in `nnir-engines'. Then, users can choose ;; the backend by setting `nnir-search-engine' as a server variable. ;;; Code: ;;; Setup: (require 'nnoo) (require 'gnus-group) (require 'message) (require 'gnus-util) (require 'eieio) (eval-when-compile (require 'cl-lib)) (autoload 'eieio-build-class-alist "eieio-opt") (defvar gnus-inhibit-demon) (defvar gnus-english-month-names) ;;; Internal Variables: (defvar nnir-memo-query nil "Internal: stores current query.") (defvar nnir-memo-server nil "Internal: stores current server.") (defvar nnir-artlist nil "Internal: stores search result.") (defvar nnir-search-history () "Internal: the history for querying search options in nnir") (define-error 'gnus-search-parse-error "Gnus search parsing error") ;;; Helper macros ;; Data type article list. (defmacro nnir-artlist-length (artlist) "Returns number of articles in artlist." `(length ,artlist)) (defmacro nnir-artlist-article (artlist n) "Returns from ARTLIST the Nth artitem (counting starting at 1)." `(when (> ,n 0) (elt ,artlist (1- ,n)))) (defmacro nnir-artitem-group (artitem) "Returns the group from the ARTITEM." `(elt ,artitem 0)) (defmacro nnir-artitem-number (artitem) "Returns the number from the ARTITEM." `(elt ,artitem 1)) (defmacro nnir-artitem-rsv (artitem) "Returns the Retrieval Status Value (RSV, score) from the ARTITEM." `(elt ,artitem 2)) (defmacro nnir-article-group (article) "Returns the group for ARTICLE" `(nnir-artitem-group (nnir-artlist-article nnir-artlist ,article))) (defmacro nnir-article-number (article) "Returns the number for ARTICLE" `(nnir-artitem-number (nnir-artlist-article nnir-artlist ,article))) (defmacro nnir-article-rsv (article) "Returns the rsv for ARTICLE" `(nnir-artitem-rsv (nnir-artlist-article nnir-artlist ,article))) (defsubst nnir-article-ids (article) "Returns the pair `(nnir id . real id)' of ARTICLE" (cons article (nnir-article-number article))) (defmacro nnir-categorize (sequence keyfunc &optional valuefunc) "Sorts a sequence into categories and returns a list of the form `((key1 (element11 element12)) (key2 (element21 element22))'. The category key for a member of the sequence is obtained as `(keyfunc member)' and the corresponding element is just `member'. If `valuefunc' is non-nil, the element of the list is `(valuefunc member)'." `(unless (null ,sequence) (let (value) (mapc (lambda (member) (let ((y (,keyfunc member)) (x ,(if valuefunc `(,valuefunc member) 'member))) (if (assoc y value) (push x (cadr (assoc y value))) (push (list y (list x)) value)))) ,sequence) value))) ;;; Finish setup: (require 'gnus-sum) (nnoo-declare nnir) (nnoo-define-basics nnir) (gnus-declare-backend "nnir" 'mail 'virtual) ;;; User Customizable Variables: (defgroup nnir nil "Search groups in Gnus with assorted search engines." :group 'gnus) (defcustom nnir-ignored-newsgroups "" "A regexp to match newsgroups in the active file that should be skipped when searching." :version "24.1" :type '(regexp) :group 'nnir) (defcustom nnir-summary-line-format nil "The format specification of the lines in an nnir summary buffer. All the items from `gnus-summary-line-format' are available, along with three items unique to nnir summary buffers: %Z Search retrieval score value (integer) %G Article original full group name (string) %g Article original short group name (string) If nil this will use `gnus-summary-line-format'." :version "24.1" :type '(choice (const :tag "gnus-summary-line-format" nil) string) :group 'nnir) (defcustom nnir-retrieve-headers-override-function nil "If non-nil, a function that accepts an article list and group and populates the `nntp-server-buffer' with the retrieved headers. Must return either 'nov or 'headers indicating the retrieved header format. If this variable is nil, or if the provided function returns nil for a sear= ch result, `gnus-retrieve-headers' will be called instead." :version "24.1" :type '(choice (const :tag "gnus-retrieve-headers" nil) function) :group 'nnir) (defcustom nnir-swish++-configuration-file (expand-file-name "~/Mail/swish++.conf") "Location of Swish++ configuration file. This variable can also be set per-server." :type 'file :group 'nnir) (defcustom nnir-swish++-program "search" "Name of swish++ search executable. This variable can also be set per-server." :type '(string) :group 'nnir) (defcustom nnir-swish++-additional-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 nnir-swish++-additional-switches \"-i -w\") ; wrong Instead, use this: (setq nnir-swish++-additional-switches \\=3D'(\"-i\" \"-w\")) This variable can also be set per-server." :type '(repeat (string)) :group 'nnir) (defcustom nnir-swish++-remove-prefix (concat (getenv "HOME") "/Mail/") "The prefix to remove from each file name returned by swish++ in order to get a group name (albeit with / instead of .). This is a regular expression. This variable can also be set per-server." :type '(regexp) :group 'nnir) (defcustom nnir-swish-e-configuration-file (expand-file-name "~/Mail/swish-e.conf") "Configuration file for swish-e. This variable can also be set per-server." :type '(file) :group 'nnir) (defcustom nnir-swish-e-program "search" "Name of swish-e search executable. This variable can also be set per-server." :type '(string) :group 'nnir) (defcustom nnir-swish-e-additional-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 nnir-swish-e-additional-switches \"-i -w\") ; wrong Instead, use this: (setq nnir-swish-e-additional-switches \\=3D'(\"-i\" \"-w\")) This variable can also be set per-server." :type '(repeat (string)) :group 'nnir) (defcustom nnir-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/") "The prefix to remove from each file name returned by swish-e in order to get a group name (albeit with / instead of .). This is a regular expression. This variable can also be set per-server." :type '(regexp) :group 'nnir) (defcustom nnir-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) :group 'nnir) ;; HyREX engine, see (defcustom nnir-hyrex-program "nnir-search" "Name of the nnir-search executable. This variable can also be set per-server." :type '(string) :group 'nnir) (defcustom nnir-hyrex-additional-switches '() "A list of strings, to be given as additional arguments for nnir-search. Note that this should be a list. I.e., do NOT use the following: (setq nnir-hyrex-additional-switches \"-ddl ddl.xml -c nnir\") ; wrong ! Instead, use this: (setq nnir-hyrex-additional-switches \\=3D'(\"-ddl\" \"ddl.xml\" \"-c\"= \"nnir\")) This variable can also be set per-server." :type '(repeat (string)) :group 'nnir) (defcustom nnir-hyrex-index-directory (getenv "HOME") "Index directory for HyREX. This variable can also be set per-server." :type '(directory) :group 'nnir) (defcustom nnir-hyrex-remove-prefix (concat (getenv "HOME") "/Mail/") "The prefix to remove from each file name returned by HyREX in order to get a group name (albeit with / instead of .). For example, suppose that HyREX returns file names such as \"/home/john/Mail/mail/misc/42\". For this example, use the following setting: (setq nnir-hyrex-remove-prefix \"/home/john/Mail/\") Note the trailing slash. Removing this prefix gives \"mail/misc/42\". `nnir' 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) :group 'nnir) ;; Namazu engine, see (defcustom nnir-namazu-program "namazu" "Name of Namazu search executable. This variable can also be set per-server." :type '(string) :group 'nnir) (defcustom nnir-namazu-index-directory (expand-file-name "~/Mail/namazu/") "Index directory for Namazu. This variable can also be set per-server." :type '(directory) :group 'nnir) (defcustom nnir-namazu-additional-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 nnir-namazu-additional-switches \"-i -w\") ; wrong Instead, use this: (setq nnir-namazu-additional-switches \\=3D'(\"-i\" \"-w\")) This variable can also be set per-server." :type '(repeat (string)) :group 'nnir) (defcustom nnir-namazu-remove-prefix (concat (getenv "HOME") "/Mail/") "The prefix to remove from each file name returned by Namazu in order to get a group name (albeit with / instead of .). For example, suppose that Namazu returns file names such as \"/home/john/Mail/mail/misc/42\". For this example, use the following setting: (setq nnir-namazu-remove-prefix \"/home/john/Mail/\") Note the trailing slash. Removing this prefix gives \"mail/misc/42\". `nnir' 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) :group 'nnir) (defcustom nnir-notmuch-program "notmuch" "Name of notmuch search executable. This variable can also be set per-server." :version "24.1" :type '(string) :group 'nnir) (defcustom nnir-notmuch-configuration-file (expand-file-name "~/.notmuch-config") "Configuration file for notmuch. This variable can also be set per-server." :type '(file) :group 'nnir) (defcustom nnir-notmuch-additional-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 nnir-notmuch-additional-switches \"-i -w\") ; wrong Instead, use this: (setq nnir-notmuch-additional-switches \\=3D'(\"-i\" \"-w\")) This variable can also be set per-server." :version "24.1" :type '(repeat (string)) :group 'nnir) (defcustom nnir-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." :version "24.1" :type '(regexp) :group 'nnir) (defcustom nnir-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" "limit" "address" "tag") "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 'nnir :version "26.1" :type '(repeat string)) (defcustom nnir-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 `nnir-search-parse-query' for information on date parsing." :group 'nnir :version "26.1" :type '(repeat string)) (defcustom nnir-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 'nnir :version "26.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 nnir-read-and-parse-query (&optional prompt history) "Read a query string, and return parsed query. Optional arguments PROMPT and HISTORY are passed to `read-string'." (let ((prompt (or prompt "Query: ")) (history (or history 'nnir-search-history))) (nnir-search-parse-query (read-string prompt nil history)))) (defun nnir-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 `nnir-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 `nnir-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 (nnir-query-end-of-input)) (push (nnir-query-next-expr) out)) (reverse out)))) (defun nnir-query-next-expr (&optional count halt) "Return the next expression from the current buffer." (let ((term (nnir-query-next-term count)) (next (nnir-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 (nnir-query-next-expr 2))) ;; Handle 'near operator. ((and (eq next 'near)) (let ((near-next (nnir-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 nnir-query-next-term (&optional count) "Return the next TERM from the current buffer." (let ((term (nnir-query-next-symbol count))) ;; What sort of term is this? (cond ;; negated term ((eq term 'not) (list 'not (nnir-query-next-expr nil 'halt))) ;; generic term (t term)))) (defun nnir-query-peek-symbol () "Return the next symbol from the current buffer, but don't consume it." (save-excursion (nnir-query-next-symbol))) (defun nnir-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)) (nnir-query-next-symbol (1- count))) (let ((case-fold-search t)) ;; end of input stream? (unless (nnir-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 "(") (nnir-search-parse-query (nnir-query-return-string ")"))) ;; 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:]]\\|\\'\\)") (nnir-query-return-string (when (looking-at "\"") "\""))) ;; Assume a K:V expression. (t (let ((key (nnir-query-expand-key (buffer-substring (point) (progn (re-search-forward ":" (point-at-eol) t) (1- (point)))))) (value (nnir-query-return-string (when (looking-at "\"") "\"")))) (nnir-query-parse-kv key value))))))) (defun nnir-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. KEY comes in as a string, goes out as a symbol." (let (return) (cond ((member key nnir-search-date-keys) (when (string=3D "after" key) (setq key "since")) (setq value (nnir-query-parse-date value))) ((string-match-p "contact" key) (setq return (nnir-query-parse-contact key value))) ((equal key "address") (setq return `(or (sender . ,value) (recipient . ,value)))) ((equal key "limit") (setq value (string-to-number value))) ((equal key "mark") (setq value (nnir-query-parse-mark value)))) (or return (cons (intern key) value)))) (defun nnir-query-parse-date (value &optional rel-date) "Interpret VALUE as a date specification. See the docstring of `nnir-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 nnir-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 (=3D 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 nnir-query-parse-contact (key value) "Handle VALUE as the name of a contact. Runs VALUE through the elements of `nnir-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 nnir-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=3D 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" `(or (recipient . ,a) (sender . ,a))))) addresses))))) (defun nnir-query-expand-key (key) "Attempt to expand KEY to a full keyword." (let ((bits (split-string key "-")) bit out-bits comp) (if (try-completion (car bits) nnir-search-expandable-keys) (progn (while (setq bit (pop bits)) (setq comp (try-completion bit nnir-search-expandable-keys)) (if (stringp comp) (if (and (string=3D bit comp) (null (member comp nnir-search-expandable-keys))) (signal 'gnus-search-parse-error (list (format "Ambiguous keyword: %s" key))) (push comp out-bits)) (push bit out-bits))) (mapconcat #'identity (reverse out-bits) "-")) key))) ;; (defun nnir-query-expand-key (key) ;; "Attempt to expand (possibly abbreviated) KEY to a full keyword. ;; Can handle any non-ambiguous abbreviation, with hyphens as substring sep= arator." ;; (let* ((bits (split-string key "-")) ;; (bit (pop bits)) ;; (comp (all-completions bit nnir-search-expandable-keys))) ;; ;; Make a cl-labels recursive function, that accepts a rebuilt key a= nd ;; ;; results of `all-completions' back in as a COLLECTION argument. ;; (if (=3D 1 (length comp)) ;; (setq key (car comp)) ;; (when (setq comp (try-completion bit nnir-search-expandable-keys)) ;; (if (and (string=3D bit comp) ;; (null (member comp nnir-search-expandable-keys))) ;; (error "Ambiguous keyword: %s" key))) ;; (unless (eq t (try-completion key nnir-search-expandable-keys)))) ;; key)) (defun nnir-query-return-string (&optional delimiter) "Return a string from the current buffer. If DELIMITER is given, return everything between point and the next occurance of DELIMITER. Otherwise, return one word." (let ((start (point)) end) (if delimiter (progn (forward-char 1) ; skip the first delimiter. (while (not end) (unless (search-forward delimiter nil t) (signal 'gnus-search-parse-error (list (format "Unmatched delimited input with %s in query" delimite= r)))) (let ((here (point))) (unless (equal (buffer-substring (- here 2) (- here 1)) "\\") (setq end (1- (point)) start (1+ start)))))) (setq end (progn (re-search-forward "\\([[:blank:]]+\\|$\\)" (point-m= ax) t) (match-beginning 0)))) (buffer-substring start end))) (defun nnir-query-end-of-input () "Are we at the end of input?" (skip-chars-forward "[[:blank:]]") (looking-at "$")) (defmacro nnir-add-result (dirnam artno score prefix server artlist) "Ask `nnir-compose-result' to construct a result vector, and if it is non-nil, add it to artlist." `(let ((result (nnir-compose-result ,dirnam ,artno ,score ,prefix ,server= ) )) (when (not (null result)) (push result ,artlist)))) (autoload 'nnmaildir-base-name-to-article-number "nnmaildir") (defun nnir-compose-result (dirnam article score prefix server) "Extract the group from dirnam, and create a result vector ready to be added to the list of search results." ;; remove nnir-*-remove-prefix from beginning of dirnam filename (when (string-match (concat "^" (file-name-as-directory prefix)) dirnam) (setq dirnam (replace-match "" t t dirnam))) (when (file-readable-p (concat prefix dirnam article)) ;; remove trailing slash and, for nnmaildir, cur/new/tmp (setq dirnam (replace-regexp-in-string "/?\\(cur\\|new\\|tmp\\)?/\\'" "" dirnam)) ;; Set group to dirnam without any leading dots or slashes, ;; and with all subsequent slashes replaced by dots (let ((group (replace-regexp-in-string "[/\\]" "." (replace-regexp-in-string "^[./\\]" "" dirnam nil t) nil t))) (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)) (string-to-number score))))) ;;; 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 () ;; Searches run asynchronously, so each engine needs its own ;; temporary buffer. ((tmp-buffer :initarg :tmp-buffer :type buffer :documentation "A temporary buffer this engine can use for entering and reading its search results.")) :abstract t :documentation "Abstract base class for Gnus search engines.") (cl-defmethod shared-initialize ((engine gnus-search-engine) slots) (setq slots (plist-put slots :tmp-buffer (get-buffer-create (generate-new-buffer-name " *nnir-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 :iniformt 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.")) :documentation "The base IMAP search engine, using an IMAP server's search capabilites. This backend may be subclassed to handle particular IMAP servers' quirks.") (defclass gnus-search-find-grep (gnus-search-engine) nil) (defclass gnus-search-gmane (gnus-search-engine) 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) ((program :initarg :program :type string :documentation "The executable used for indexing and searching.") (prefix :initarg :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 in= dex accessed by a command line program.") (eieio-oset-default 'gnus-search-indexed '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 nnir-swish-e-program) (eieio-oset-default 'gnus-search-swish-e 'prefix nnir-swish-e-remove-prefix) (eieio-oset-default 'gnus-search-swish-e 'config-file nnir-swish-e-index-files) (eieio-oset-default 'gnus-search-swish-e 'switches nnir-swish-e-additional-switches) (defclass gnus-search-swish++ (gnus-search-indexed) ((config-file :init-arg :config-file :type string))) (eieio-oset-default 'gnus-search-swish++ 'program nnir-swish++-program) (eieio-oset-default 'gnus-search-swish++ 'prefix nnir-swish++-remove-prefix) (eieio-oset-default 'gnus-search-swish++ 'config-file nnir-swish++-configuration-file) (eieio-oset-default 'gnus-search-swish++ 'switches nnir-swish++-additional-switches) ;; Hyrex possibly bogus, why is the default program name ;; "nnir-search"? (defclass gnus-search-hyrex (gnus-search-indexed) ((index-dir :initarg :index :type string :custom directory))) (eieio-oset-default 'gnus-search-hyrex 'program nnir-hyrex-program) (eieio-oset-default 'gnus-search-hyrex 'index-dir nnir-hyrex-index-directory) (eieio-oset-default 'gnus-search-hyrex 'switches nnir-hyrex-additional-switches) (eieio-oset-default 'gnus-search-hyrex 'prefix nnir-hyrex-remove-prefix) (defclass gnus-search-namazu (gnus-search-indexed) ((index-dir :initarg :index-dir :type string :custom directory))) (eieio-oset-default 'gnus-search-namazu 'program nnir-namazu-program) (eieio-oset-default 'gnus-search-namazu 'index-dir nnir-namazu-index-directory) (eieio-oset-default 'gnus-search-namazu 'switches nnir-namazu-additional-switches) (eieio-oset-default 'gnus-search-namazu 'prefix nnir-namazu-remove-prefix) (defclass gnus-search-notmuch (gnus-search-indexed) ((config-file :init-arg :config-file :type string))) (eieio-oset-default 'gnus-search-notmuch 'program nnir-notmuch-program) (eieio-oset-default 'gnus-search-notmuch 'switches nnir-notmuch-additional-switches) (eieio-oset-default 'gnus-search-notmuch 'prefix nnir-notmuch-remove-prefix) (eieio-oset-default 'gnus-search-notmuch 'config-file nnir-notmuch-configuration-file) (defcustom nnir-method-default-engines '((nnimap gnus-search-imap) (nntp gnus-search-gmane)) "Alist of default search engines keyed by server method." :version "26.1" :group 'nnir :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 nnir-run-search (backend server query groups) "Run QUERY in GROUPS against SERVER, using search BACKEND. Should return results as a vector of vectors.") (cl-defgeneric nnir-search-transform-top-level (backend expression) "Transform sexp EXPRESSION into a string search query usable by BACKEND. Responsible for handling and, or, and parenthetical expressions.") (cl-defgeneric nnir-search-transform-expression (backend expression) "Transform a basic EXPRESSION into a string usable by BACKEND.") ;; Methods that are likely to be the same for all engines. (cl-defmethod nnir-search-transform-top-level ((engine gnus-search-engine) (query list)) (let (clauses) (mapc (lambda (item) (when-let ((expr (nnir-search-transform-expression engine item))) (push expr clauses))) query) (mapconcat #'identity (reverse clauses) " "))) ;; Most search engines want quoted string phrases. (cl-defmethod nnir-search-transform-expression ((_ gnus-search-engine) (expr string)) (if (string-match-p " " expr) (format "\"%s\"" expr) expr)) ;; Most search engines use implicit ANDs. (cl-defmethod nnir-search-transform-expression ((_ gnus-search-engine) (_expr (eql and))) nil) ;; Most search engines use explicit infixed ORs. (cl-defmethod nnir-search-transform-expression ((engine gnus-search-engine) (expr (head or))) (let ((left (nnir-search-transform-expression engine (nth 1 expr))) (right (nnir-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 nnir-search-transform-expression ((engine gnus-search-engine) (expr (head not))) (let ((next (nnir-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 nnir-run-search ((engine gnus-search-imap) srv query groups) (save-excursion (let ((server (cadr (gnus-server-to-method srv))) (gnus-inhibit-demon t)) (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))) (setq query (nnir-search-transform-top-level engine query)) (apply 'vconcat (mapcar (lambda (group) (let (artlist) (condition-case () (when (nnimap-change-group (gnus-group-short-name group) server) (with-current-buffer (nnimap-buffer) (message "Searching %s..." group) (let ((arts 0) (result (nnir-imap-search-command engine query))) (mapc (lambda (artnum) (let ((artn (string-to-number artnum))) (when (> artn 0) (push (vector group artn 100) artlist) (setq arts (1+ arts))))) (and (car result) (cdr (assoc "SEARCH" (cdr result))))) (message "Searching %s... %d matches" group arts))) (message "Searching %s...done" group)) (quit nil)) (nreverse artlist))) groups))))) (cl-defmethod nnir-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 nnir-imap-search-keys '(body cc from header keyword larger smaller subject text to uid) "Known IMAP search keys, excluding booleans and date keys.") (cl-defmethod nnir-search-transform-top-level ((_ gnus-search-imap) (_query null)) "ALL") (cl-defmethod nnir-search-transform-expression ((engine gnus-search-imap) (expr string)) (format "TEXT %s" (nnir-imap-handle-string engine expr))) (cl-defmethod nnir-search-transform-expression ((engine gnus-search-imap) (expr (head or))) (let ((left (nnir-search-transform-expression engine (nth 1 expr))) (right (nnir-search-transform-expression engine (nth 2 expr)))) (if (and left right) (format "OR %s %s" left right) (or left right)))) (cl-defmethod nnir-search-transform-expression ((engine gnus-search-imap) (expr (head near))) "Imap searches interpret \"near\" as \"or\"." (setcar expr 'or) (nnir-search-transform-expression engine expr)) (cl-defmethod nnir-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=3D (cdadr expr) "new") "OLD" (format "UN%s" (nnir-imap-handle-flag (cdadr expr)))) (format "NOT %s" (nnir-search-transform-expression engine (cadr expr))))) (cl-defmethod nnir-search-transform-expression ((_ gnus-search-imap) (expr (head mark))) (nnir-imap-handle-flag (cdr expr))) (cl-defmethod nnir-search-transform-expression ((engine gnus-search-imap) (expr list)) ;; Search keyword. All IMAP search keywords that take a value are ;; supported directly. Keywords that are boolean are supported ;; through other means (usually the "mark" keyword). (cl-case (car expr) (date (setcar expr 'on)) (tag (setcar expr 'keyword))) (cond ((consp (car expr)) (format "(%s)" (nnir-search-transform-top-level engine expr))) ((eq (car expr) 'sender) (format "FROM %s" (cdr expr))) ((eq (car expr) 'recipient) (format "OR (OR TO %s CC %s) BCC %s" (cdr expr) (cdr expr) (cdr expr))) ((memq (car expr) nnir-imap-search-keys) (format "%s %s" (upcase (symbol-name (car expr))) (nnir-imap-handle-string engine (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))) (nnir-imap-handle-date 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 "HEADER %s %s" (car expr) (nnir-imap-handle-string engine (cdr expr)))))) (cl-defmethod nnir-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 nnir-imap-handle-string ((engine gnus-search-imap) (str string)) (with-slots (literal-plus) engine ;; STR is not ASCII. (if (null (=3D (length str) (string-bytes str))) (if literal-plus ;; If LITERAL+ is available, use it and force UTF-8. (format "{%d+}\n%s" (string-bytes str) (encode-coding-string str 'utf-8)) ;; Other servers might be able to parse it if quoted. (format "\"%s\"" str)) (if (string-match-p " " str) (format "\"%s\"" str) str)))) (defun nnir-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 nnir-search-indexed-massage-output (engine server &optional = groups) "Massage the results of ENGINE's query against SERVER in GROUPS. Most indexed search engines return results as a list of filenames or something similar. Turn those results into something nnir understands.") (cl-defmethod nnir-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 vector of [group name, file name, score] vectors." (save-excursion (let* ((qstring (nnir-search-transform-top-level engine query)) (program (slot-value engine 'program)) (buffer (slot-value engine 'tmp-buffer)) (cp-list (nnir-search-indexed-search-command engine qstring groups)) proc exitstatus artlist) (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 "search" buffer program cp-list)) (accept-process-output proc) (setq exitstatus (process-exit-status proc)) (if (zerop exitstatus) ;; The search results have been put into the current buffer; ;; `massage-output' finds them there. (progn (setq artlist (nnir-search-indexed-massage-output engine server groups)) ;; Sort by score (apply #'vector (sort artlist (function (lambda (x y) (> (nnir-artitem-rsv x) (nnir-artitem-rsv y))))))) (nnheader-report 'nnir "%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)))))) ;; Swish++ (cl-defmethod nnir-search-transform-expression ((engine gnus-engine-swish++) (expr (head near))) (format "%s near %s" (nnir-search-transform-expression engine (nth 1 expr)) (nnir-search-transform-expression engine (nth 2 expr)))) (cl-defmethod nnir-search-transform-expression ((engine gnus-search-swish++) (expr list)) (cond ((listp (car expr)) (format "(%s)" (nnir-search-transform-top-level engine expr))) ;; Untested and likely wrong. ((and (stringp (cdr expr)) (string-prefix-p "(" (cdr expr))) (format "%s =3D %s" (car expr) (nnir-search-transform-top-level engine (nnir-search-parse-query (cdr expr))))) (t (format "%s =3D %s" (car expr) (cdr expr))))) (cl-defmethod nnir-search-indexed-search-command ((engine gnus-search-swish= ++) (qstring string)) (with-slots (config-file switches) engine `("--config-file" ,config-file ,@switches ,qstring ))) (cl-defmethod nnir-search-indexed-massage-output ((engine gnus-search-swish= ++) server &optional groups) (let ((groupspec (when groups (regexp-opt (mapcar (lambda (x) (gnus-group-real-name x)) groups)))) (prefix (slot-value engine 'prefix)) (article-pattern (if (string-match "\\`nnmaildir:" (gnus-group-server server)) ":[0-9]+" "^[0-9]+\\(\\.[a-z0-9]+\\)?$")) filenam dirnam artno score artlist) (goto-char (point-min)) (while (re-search-forward "\\(^[0-9]+\\) \\([^ ]+\\) [0-9]+ \\(.*\\)$" nil t) (setq score (match-string 1) filenam (match-string 2) artno (file-name-nondirectory filenam) dirnam (file-name-directory filenam)) ;; don't match directories (when (string-match article-pattern artno) (when (not (null dirnam)) ;; maybe limit results to matching groups. (when (or (not groupspec) (string-match groupspec dirnam)) (nnir-add-result dirnam artno score prefix server artlist))))))) ;; Swish-e ;; I didn't do the query transformation for Swish-e, because the ;; program seems no longer to exist. (cl-defmethod nnir-search-indexed-search-command ((engine gnus-search-swish= -e) (qstring string)) (with-slots (index-files switches) engine `("-f" ,@index-files ,@switches "-w" ,qstring ))) (cl-defmethod nnir-search-indexed-massage-output ((engine gnus-search-swish= -e) server &optional _groups) (let ((prefix (slot-value engine 'prefix)) group dirnam artno score artlist) (goto-char (point-min)) (while (re-search-forward "\\(^[0-9]+\\) \\([^ ]+\\) \"\\([^\"]+\\)\" [0-9]+$" nil t) (setq score (match-string 1) artno (match-string 3) dirnam (file-name-directory (match-string 2))) (when (string-match "^[0-9]+$" artno) (when (not (null dirnam)) ;; remove nnir-swish-e-remove-prefix from beginning of dirname (when (string-match (concat "^" prefix) dirnam) (setq dirnam (replace-match "" t t dirnam))) (setq dirnam (substring dirnam 0 -1)) ;; eliminate all ".", "/", "\" from beginning. Always matches. (string-match "^[./\\]*\\(.*\\)$" dirnam) ;; "/" -> "." (setq group (replace-regexp-in-string "/" "." (match-string 1 dirnam))) ;; Windows "\\" -> "." (setq group (replace-regexp-in-string "\\\\" "." group)) (push (vector (gnus-group-full-name group server) (string-to-number artno) (string-to-number score)) artlist)))))) ;; HyREX interface ;; I have no idea what the hyrex search language looks like, and ;; suspect that the software isn't even supported anymore. (cl-defmethod nnir-search-indexed-search-command ((engine gnus-search-hyrex) (qstring string)) (with-slots (program index-dir switches) engine `("-i" ,index-dir ,@switches ,qstring ; the query, in hyrex-search format ))) (cl-defmethod nnir-search-indexed-massage-output ((engine gnus-search-hyrex) server &optional groups) (let ((groupspec (when groups (regexp-opt (mapcar (lambda (x) (gnus-group-real-name x)) groups)))) (prefix (slot-value engine 'prefix)) dirnam artno score artlist) (goto-char (point-min)) (keep-lines "^\\S + [0-9]+ [0-9]+$") ;; HyREX doesn't search directly in groups -- so filter out here. (when groupspec (keep-lines groupspec)) ;; extract data from result lines (goto-char (point-min)) (while (re-search-forward "\\(\\S +\\) \\([0-9]+\\) \\([0-9]+\\)" nil t) (setq dirnam (match-string 1) artno (match-string 2) score (match-string 3)) (when (string-match prefix dirnam) (setq dirnam (replace-match "" t t dirnam))) (push (vector (gnus-group-full-name (replace-regexp-in-string "/" "." dirnam) server) (string-to-number artno) (string-to-number score)) artlist)) artlist)) ;; Namazu interface (cl-defmethod nnir-search-transform-expression ((engine gnus-search-namazu) (expr list)) (cond ((listp (car expr)) (format "(%s)" (nnir-search-transform-top-level engine 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))) ((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 nnir-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 search-indexed-search-command ((engine gnus-search-namazu) (qstring string)) (with-slots (switches index-dir) engine `("-q" ; don't be verbose "-a" ; show all matches "-s" ; use short format ,@switches ,qstring ; the query, in namazu format ,index-dir ; index directory ))) (cl-defmethod nnir-search-indexed-massage-output ((engine gnus-search-namaz= u) server &optional groups) ;; Namazu output looks something like this: ;; 2. Re: Gnus agent expire broken (score: 55) ;; /home/henrik/Mail/mail/sent/1310 (4,138 bytes) (let ((article-pattern (if (string-match "\\'nnmaildir:" (gnus-group-server server)) ":[0-9]+" "^[0-9]+$")) (prefix (slot-value engine 'prefix)) (group-regexp (when groups (regexp-opt (mapcar (lambda (x) (gnus-group-real-name x)) groups)))) score group article artlist) (goto-char (point-min)) (while (re-search-forward "^\\([0-9,]+\\.\\).*\\((score: \\([0-9]+\\)\\))\n\\([^ ]+\\)" nil t) (setq score (match-string 3) group (file-name-directory (match-string 4)) article (file-name-nondirectory (match-string 4))) ;; make sure article and group is sane (when (and (string-match article-pattern article) (not (null group)) (or (null group-regexp) (string-match-p group-regexp group))) (nnir-add-result group article score prefix server artlist))) artlist)) ;; Notmuch interface (cl-defmethod nnir-search-transform-top-level ((_engine gnus-search-notmuch) (_query null)) "*") (cl-defmethod nnir-search-transform-expression ((engine gnus-search-notmuch) (expr (head near))) (format "%s near %s" (nnir-search-transform-expression engine (nth 1 expr)) (nnir-search-transform-expression engine (nth 2 expr)))) (cl-defmethod nnir-search-transform-expression ((engine gnus-search-notmuch) (expr list)) ;; Swap keywords as necessary. (cl-case (car expr) (sender (setcar expr 'from)) (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)") (nnir-search-transform-top-level engine expr)) ((memq (car expr) '(from to subject attachment mimetype tag id thread folder path lastmod query property)) (format "%s:%s" (car expr) (if (string-match-p " " (cdr expr)) (format "\"%s\"" (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 nnir-search-indexed-search-command ((engine gnus-search-notmu= ch) (qstring string) &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. (with-slots (switches config-file) engine `("search" ,(format "--config=3D%s" config-file) "--format=3Dtext" "--output=3Dfiles" ,@switches ,qstring ; the query, in notmuch format ))) (cl-defmethod nnir-search-indexed-massage-output ((engine gnus-search-notmu= ch) server &optional groups) ;; The results are output in the format of: ;; absolute-path-name (let ((article-pattern (if (string-match "\\`nnmaildir:" (gnus-group-server server)) ":[0-9]+" "^[0-9]+$")) (prefix (slot-value engine 'prefix)) (group-regexp (when groups (regexp-opt (mapcar (lambda (x) (gnus-group-real-name x)) groups)))) artno dirnam filenam artlist) (goto-char (point-min)) (while (not (eobp)) (setq filenam (buffer-substring-no-properties (line-beginning-positio= n) (line-end-position)) artno (file-name-nondirectory filenam) dirnam (file-name-directory filenam)) (forward-line 1) ;; don't match directories (when (string-match article-pattern artno) (when (not (null dirnam)) ;; maybe limit results to matching groups. (when (or (not groups) (string-match-p group-regexp dirnam)) (nnir-add-result dirnam artno "" prefix server artlist))))) artlist)) ;;; Find-grep interface (cl-defmethod nnir-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 (cdr (assoc 'query query))) ;; `grep-options' will actually come out of the parsed query. (grep-options (cdr (assoc 'grep-options query))) (grouplist (or groups (nnir-get-active server))) (buffer (slot-value engine 'tmp-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" "grep" `("-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=3D "." (car path)) (setq path (cdr path))) (let ((group (mapconcat #'identity ;; Replace cl-func: ;; (subseq path 0 -1) (let ((end (1- (length path))) res) (while (>=3D (setq end (1- end)) 0) (push (pop path) res)) (nreverse res)) "."))) (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 nnir-run-search ((engine gnus-search-gmane) srv query &optional groups) "Run a search against a gmane back-end server." (let* ((case-fold-search t) (qlist (cdr (assq 'query query))) (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 'tmp-buffer)) (search (format "%s %s" (nnir-search-transform-top-level qlist) 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 nnir-search-transform-expression ((_e gnus-engine-gmane) (_expr (head near))) nil) ;; Can Gmane handle OR or NOT keywords? (cl-defmethod nnir-search-transform-expression ((_e gnus-engine-gmane) (_expr (head or))) nil) (cl-defmethod nnir-search-transform-expression ((_e gnus-engine-gmane) (_expr (head not))) nil) (cl-defmethod nnir-search-transform-expression ((_e gnus-engine-gmane) (expr list)) "The only keyword value gmane can handle is author, ie from." (when (memq (car expr) '(from sender author)) (format "author:%s" (cdr expr)))) ;;; Util Code: (defun gnus-nnir-group-p (group) "Say whether GROUP is nnir or not." (if (gnus-group-prefixed-p group) (eq 'nnir (car (gnus-find-method-for-group group))) (and group (string-match "^nnir" group)))) (defun nnir-run-query (specs) "Invoke appropriate search engine function." ;; For now, run the searches synchronously. At some point each ;; search can be run in its own thread, allowing concurrent searches ;; of multiple backends. At present this causes problems when ;; multiple IMAP servers are searched at the same time, apparently ;; because the threads are somehow fighting for control, or the ;; `nntp-server-buffer' variable is getting clobbered, or something ;; else. (let ((results []) (query (cddr (assq 'nnir-query-spec specs)))) (mapc (lambda (x) (let* ((server (car x)) (search-engine (nnir-server-to-search-engine server)) (groups (cadr x))) (setq results (vconcat (nnir-run-search search-engine server query groups) results)))) (cdr (assq 'nnir-group-spec specs))) results)) ;; 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 nnir-server-to-search-engine (server) (let* ((server (or (assoc 'nnir-search-engine (cddr (gnus-server-to-method server))) (assoc (car (gnus-server-to-method server)) nnir-method-default-engines))) (inst (cond ((null server) nil) ((eieio-object-p (cadr server)) (car server)) ((class-p (cadr server)) (make-instance (cadr server))) (t nil)))) (when 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))) inst))) (defun nnir-read-server-parm (key server &optional not-global) "Returns the parameter value corresponding to `key' for `server'. If no server-specific value is found consult the global environment unless `not-global' is non-nil." (let ((method (gnus-server-to-method server))) (cond ((and method (assq key (cddr method))) (nth 1 (assq key (cddr method)))) ((and (not not-global) (boundp key)) (symbol-value key)) (t nil)))) (defun nnir-possibly-change-group (group &optional server) (or (not server) (nnir-server-opened server) (nnir-open-server server)) (when (gnus-nnir-group-p group) (setq nnir-artlist (gnus-group-get-parameter (gnus-group-prefixed-name (gnus-group-short-name group) '(nnir "nnir")) 'nnir-artlist t)))) (defun nnir-server-opened (&optional server) (let ((backend (car (gnus-server-to-method server)))) (nnoo-current-server-p (or backend 'nnir) server))) (autoload 'nnimap-make-thread-query "nnimap") (declare-function gnus-registry-get-id-key "gnus-registry" (id key)) (defun nnir-search-thread (header) "Make an nnir group based on the thread containing the article header. The current server will be searched. If the registry is installed, the server that the registry reports the current article came from is also searched." (let* ((query (list (cons 'query (nnimap-make-thread-query header)))) (server (list (list (gnus-method-to-server (gnus-find-method-for-group gnus-newsgroup-name))))) (registry-group (and (bound-and-true-p gnus-registry-enabled) (car (gnus-registry-get-id-key (mail-header-id header) 'group)))) (registry-server (and registry-group (gnus-method-to-server (gnus-find-method-for-group registry-group))))) (when registry-server (cl-pushnew (list registry-server) server :test #'equal)) (gnus-group-make-nnir-group nil (list (cons 'nnir-query-spec query) (cons 'nnir-group-spec server))) (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header))= ))) (defun nnir-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 nnir-ignored-newsgroups) (string=3D nnir-ignored-newsgroups "")) (delete-matching-lines nnir-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)) ;; Behind gnus-registry-enabled test. (declare-function gnus-registry-action "gnus-registry" (action data-header from &optional to method)) (defun nnir-registry-action (action data-header _from &optional to method) "Call `gnus-registry-action' with the original article group." (gnus-registry-action action data-header (nnir-article-group (mail-header-number data-header)) to method)) (defun nnir-mode () (when (eq (car (gnus-find-method-for-group gnus-newsgroup-name)) 'nnir) (setq gnus-summary-line-format (or nnir-summary-line-format gnus-summary-line-format)) (when (bound-and-true-p gnus-registry-enabled) (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action = t) (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action t) (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action = t) (add-hook 'gnus-summary-article-delete-hook 'nnir-registry-action t t) (add-hook 'gnus-summary-article-move-hook 'nnir-registry-action t t) (add-hook 'gnus-summary-article-expire-hook 'nnir-registry-action t t= )))) (defun gnus-summary-create-nnir-group () (interactive) (or (nnir-server-opened "") (nnir-open-server "nnir")) (let ((name (gnus-read-group "Group name: ")) (method '(nnir "")) (pgroup (gnus-group-guess-full-name-from-command-method gnus-newsgroup-name))) (with-current-buffer gnus-group-buffer (gnus-group-make-group name method nil (gnus-group-find-parameter pgroup))))) ;; Gnus glue. (declare-function gnus-group-topic-name "gnus-topic" ()) (defun gnus-group-make-nnir-group (&optional specs) "Create an nnir group. Prompt for a search query and determine the groups to search as follows: if called from the *Server* buffer search all groups belonging to the server on the current line; if called from the *Group* buffer search any marked groups, or the group on the current line, or all the groups under the current topic. Calling with a prefix-arg prompts for additional search-engine specific constraints. A non-nil `specs' arg must be an alist with `nnir-query-spec' and `nnir-group-spec' keys, and skips all prompting." (interactive "P") (let* ((group-spec (or (cdr (assq 'nnir-group-spec specs)) (if (gnus-server-server-name) (list (list (gnus-server-server-name))) (nnir-categorize (or gnus-group-marked (if (gnus-group-group-name) (list (gnus-group-group-name)) (cdr (assoc (gnus-group-topic-name) gnus-topic-alist)))) gnus-group-server)))) (query-spec (or (cdr (assq 'nnir-query-spec specs)) (apply 'append (list (cons 'query (nnir-read-and-parse-query))))))) (gnus-group-read-ephemeral-group (concat "nnir-" (message-unique-id)) (list 'nnir "nnir") nil ; (cons (current-buffer) gnus-current-window-configuration) nil nil nil (list (cons 'nnir-specs (list (cons 'nnir-query-spec query-spec) (cons 'nnir-group-spec group-spec))) (cons 'nnir-artlist nil))))) ;; TODO: What was `nnir-extra-parms' supposed to be? ;; `gnus-group-make-nnir-group' doesn't accept two arguments. (defun gnus-summary-make-nnir-group (_nnir-extra-parms) "Search a group from the summary buffer." (interactive "P") (gnus-warp-to-article) (let ((spec (list (cons 'nnir-group-spec (list (list (gnus-group-server gnus-newsgroup-name) (list gnus-newsgroup-name))))))) (gnus-group-make-nnir-group spec))) ;; Gnus backend interface functions. (deffoo nnir-open-server (server &optional definitions) ;; Just set the server variables appropriately. (let ((backend (car (gnus-server-to-method server)))) (if backend (nnoo-change-server backend server definitions) (add-hook 'gnus-summary-mode-hook 'nnir-mode) (nnoo-change-server 'nnir server definitions)))) (deffoo nnir-request-group (group &optional server dont-check _info) (nnir-possibly-change-group group server) (let ((pgroup (gnus-group-guess-full-name-from-command-method group)) length) ;; Check for cached search result or run the query and cache the ;; result. (unless (and nnir-artlist dont-check) (gnus-group-set-parameter pgroup 'nnir-artlist (setq nnir-artlist (nnir-run-query (gnus-group-get-parameter pgroup 'nnir-specs t)))) (nnir-request-update-info pgroup (gnus-get-info pgroup))) (with-current-buffer nntp-server-buffer (if (zerop (setq length (nnir-artlist-length nnir-artlist))) (progn (nnir-close-group group) (nnheader-report 'nnir "Search produced empty results.")) (nnheader-insert "211 %d %d %d %s\n" length ; total # 1 ; first # length ; last # group)))) ; group name nnir-artlist) (deffoo nnir-retrieve-headers (articles &optional _group _server _fetch-old) (with-current-buffer nntp-server-buffer (let ((gnus-inhibit-demon t) (articles-by-group (nnir-categorize articles nnir-article-group nnir-article-ids)) headers) (while (not (null articles-by-group)) (let* ((group-articles (pop articles-by-group)) (artgroup (car group-articles)) (articleids (cadr group-articles)) (artlist (sort (mapcar 'cdr articleids) '<)) (server (gnus-group-server artgroup)) (gnus-override-method (gnus-server-to-method server)) parsefunc) ;; (nnir-possibly-change-group nil server) (erase-buffer) (pcase (setq gnus-headers-retrieved-by (or (and nnir-retrieve-headers-override-function (funcall nnir-retrieve-headers-override-function artlist artgroup)) (gnus-retrieve-headers artlist artgroup nil))) ('nov (setq parsefunc 'nnheader-parse-nov)) ('headers (setq parsefunc 'nnheader-parse-head)) (_ (error "Unknown header type %s while requesting articles \ of group %s" gnus-headers-retrieved-by artgroup))) (goto-char (point-min)) (while (not (eobp)) (let* ((novitem (funcall parsefunc)) (artno (and novitem (mail-header-number novitem))) (art (car (rassq artno articleids)))) (when art (mail-header-set-number novitem art) (push novitem headers)) (forward-line 1))))) (setq headers (sort headers (lambda (x y) (< (mail-header-number x) (mail-header-number y))))) (erase-buffer) (mapc 'nnheader-insert-nov headers) 'nov))) (deffoo nnir-request-article (article &optional group server to-buffer) (nnir-possibly-change-group group server) (let ((search-engine (nnir-server-to-search-engine server))) (save-excursion (let ((article article) query) (when (stringp article) (setq gnus-override-method (gnus-server-to-method server)) (setq query (list (cons 'query `((id . ,article))))) (unless (and nnir-artlist (equal query nnir-memo-query) (equal server nnir-memo-server)) (setq nnir-artlist (nnir-run-search search-engine query server) nnir-memo-query query nnir-memo-server server)) (setq article 1)) (unless (zerop (nnir-artlist-length nnir-artlist)) (let ((artfullgroup (nnir-article-group article)) (artno (nnir-article-number article))) (message "Requesting article %d from group %s" artno artfullgroup) (if to-buffer (with-current-buffer to-buffer (let ((gnus-article-decode-hook nil)) (gnus-request-article-this-buffer artno artfullgroup))) (gnus-request-article artno artfullgroup)) (cons artfullgroup artno))))))) (deffoo nnir-request-move-article (article group server accept-form &optional last _internal-move-group) (nnir-possibly-change-group group server) (let* ((artfullgroup (nnir-article-group article)) (artno (nnir-article-number article)) (to-newsgroup (nth 1 accept-form)) (to-method (gnus-find-method-for-group to-newsgroup)) (from-method (gnus-find-method-for-group artfullgroup)) (move-is-internal (gnus-server-equal from-method to-method))) (unless (gnus-check-backend-function 'request-move-article artfullgroup) (error "The group %s does not support article moving" artfullgroup)) (gnus-request-move-article artno artfullgroup (nth 1 from-method) accept-form last (and move-is-internal to-newsgroup ; Not respooling (gnus-group-real-name to-newsgroup))))) (deffoo nnir-request-expire-articles (articles group &optional server force) (nnir-possibly-change-group group server) (if force (let ((articles-by-group (nnir-categorize articles nnir-article-group nnir-article-ids)) not-deleted) (while (not (null articles-by-group)) (let* ((group-articles (pop articles-by-group)) (artgroup (car group-articles)) (articleids (cadr group-articles)) (artlist (sort (mapcar 'cdr articleids) '<))) (unless (gnus-check-backend-function 'request-expire-articles artgroup) (error "The group %s does not support article deletion" artgroup)) (unless (gnus-check-server (gnus-find-method-for-group artgroup)) (error "Couldn't open server for group %s" artgroup)) (push (gnus-request-expire-articles artlist artgroup force) not-deleted))) (sort (delq nil not-deleted) '<)) articles)) (deffoo nnir-warp-to-article () (nnir-possibly-change-group gnus-newsgroup-name) (let* ((cur (if (> (gnus-summary-article-number) 0) (gnus-summary-article-number) (error "Can't warp to a pseudo-article"))) (backend-article-group (nnir-article-group cur)) (backend-article-number (nnir-article-number cur)) ;(quit-config (gnus-ephemeral-group-p gnus-newsgroup-name)) ) ;; what should we do here? we could leave all the buffers around ;; and assume that we have to exit from them one by one. or we can ;; try to clean up directly ;;first exit from the nnir summary buffer. ; (gnus-summary-exit) ;; and if the nnir summary buffer in turn came from another ;; summary buffer we have to clean that summary up too. ; (when (not (eq (cdr quit-config) 'group)) ; (gnus-summary-exit)) (gnus-summary-read-group-1 backend-article-group t t nil nil (list backend-article-number)))) (deffoo nnir-request-update-mark (_group article mark) (let ((artgroup (nnir-article-group article)) (artnumber (nnir-article-number article))) (or (and artgroup artnumber (gnus-request-update-mark artgroup artnumber mark)) mark))) (deffoo nnir-request-set-mark (group actions &optional server) (nnir-possibly-change-group group server) (let (mlist) (dolist (action actions) (cl-destructuring-bind (range action marks) action (let ((articles-by-group (nnir-categorize (gnus-uncompress-range range) nnir-article-group nnir-article-number))) (dolist (artgroup articles-by-group) (push (list (car artgroup) (list (gnus-compress-sequence (sort (cadr artgroup) '<)) action marks)) mlist))))) (dolist (request (nnir-categorize mlist car cadr)) (gnus-request-set-mark (car request) (cadr request))))) (deffoo nnir-request-update-info (group info &optional server) (nnir-possibly-change-group group server) ;; clear out all existing marks. (gnus-info-set-marks info nil) (gnus-info-set-read info nil) (let ((group (gnus-group-guess-full-name-from-command-method group)) (articles-by-group (nnir-categorize (gnus-uncompress-range (cons 1 (nnir-artlist-length nnir-artlist))) nnir-article-group nnir-article-ids))) (gnus-set-active group (cons 1 (nnir-artlist-length nnir-artlist))) (while (not (null articles-by-group)) (let* ((group-articles (pop articles-by-group)) (articleids (reverse (cadr group-articles))) (group-info (gnus-get-info (car group-articles))) (marks (gnus-info-marks group-info)) (read (gnus-info-read group-info))) (gnus-info-set-read info (gnus-add-to-range (gnus-info-read info) (delq nil (mapcar #'(lambda (art) (when (gnus-member-of-range (cdr art) read) (car art))) articleids)))) (dolist (mark marks) (cl-destructuring-bind (type . range) mark (gnus-add-marked-articles group type (delq nil (mapcar #'(lambda (art) (when (gnus-member-of-range (cdr art) range) (car art))) articleids))))))))) (deffoo nnir-close-group (group &optional server) (nnir-possibly-change-group group server) (let ((pgroup (gnus-group-guess-full-name-from-command-method group))) (when (and nnir-artlist (not (gnus-ephemeral-group-p pgroup))) (gnus-group-set-parameter pgroup 'nnir-artlist nnir-artlist)) (setq nnir-artlist nil) (when (gnus-ephemeral-group-p pgroup) (gnus-kill-ephemeral-group pgroup) (setq gnus-ephemeral-servers (delq (assq 'nnir gnus-ephemeral-servers) gnus-ephemeral-servers))))) ;; (gnus-opened-servers-remove ;; (car (assoc '(nnir "nnir-ephemeral" (nnir-address "nnir")) ;; gnus-opened-servers)))) (deffoo nnir-request-create-group (group &optional _server args) (message "Creating nnir group %s" group) (let* ((group (gnus-group-prefixed-name group '(nnir "nnir"))) (specs (assq 'nnir-specs args)) (query-spec (or (cdr (assq 'nnir-query-spec specs)) (list (cons 'query (nnir-read-and-parse-query))))) (group-spec (or (cdr (assq 'nnir-group-spec specs)) (list (list (read-string "Server: " nil nil))))) (nnir-specs (list (cons 'nnir-query-spec query-spec) (cons 'nnir-group-spec group-spec)))) (gnus-group-set-parameter group 'nnir-specs nnir-specs) (gnus-group-set-parameter group 'nnir-artlist (or (cdr (assq 'nnir-artlist args)) (nnir-run-query nnir-specs))) (nnir-request-update-info group (gnus-get-info group))) t) (deffoo nnir-request-delete-group (_group &optional _force _server) t) (deffoo nnir-request-list (&optional _server) t) (deffoo nnir-request-scan (_group _method) t) (deffoo nnir-request-close () t) (nnoo-define-skeleton nnir) ;; The end. (provide 'nnir) ;;; nnir.el ends here --=-=-=--