[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] scratch/gnus-search 62896f7: WIP on a generalized search q
|
From: |
Eric Abrahamsen |
|
Subject: |
[Emacs-diffs] scratch/gnus-search 62896f7: WIP on a generalized search query language for Gnus |
|
Date: |
Mon, 24 Apr 2017 16:05:43 -0400 (EDT) |
branch: scratch/gnus-search
commit 62896f73bbd02822f089988ad21c41e1b4f89b59
Author: Eric Abrahamsen <address@hidden>
Commit: Eric Abrahamsen <address@hidden>
WIP on a generalized search query language for Gnus
* lisp/gnus/nnir.el (nnir-search-parse-query, nnir-query-next-expr,
nnir-query-next-term, nnir-query-next-symbol,
nnir-query-peek-symbol, nnir-query-end-of-input,
nnir-query-parse-kv, nnir-query-parse-date nnir-query-parse-mark,
nnir-query-parse-contact): Functions for reading the generalized
search query language and parsing it into a sexp.
(gnus-search-engine, gnus-search-process, gnus-search-indexed): Base
classes for creating search-engine specific engine classes.
(nnir-run-search): Method for running one engine's search routine.
(nnir-search-transform-top-level, nnir-search-transform-expression):
Methods for transforming the parsed sexp query format into a
backend-specific string.
(nnir-search-indexed-search-command,
nnir-search-indexed-massage-output): Methods used by indexed
backends to retrieve their results.
* test/lisp/gnus/search-tests.el: Basic set of tests for the parsing
routine.
---
lisp/gnus/nnir.el | 2939 ++++++++++++++++++++++++----------------
test/lisp/gnus/search-tests.el | 78 ++
2 files changed, 1883 insertions(+), 1134 deletions(-)
diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el
index 9640f2c..9bb126a 100644
--- a/lisp/gnus/nnir.el
+++ b/lisp/gnus/nnir.el
@@ -8,7 +8,7 @@
;; IMAP backend by: Simon Josefsson <address@hidden>.
;; IMAP search by: Torsten Hilbrich <torsten.hilbrich <at> gmx.net>
;; IMAP search improved by Daniel Pittman <address@hidden>.
-;; nnmaildir support for Swish++ and Namazu backends by:
+;; nnmaildir support for Swish-e, Swish++ and Namazu backends by:
;; Justus Piater <Justus <at> Piater.name>
;; Keywords: news mail searching ir
@@ -30,7 +30,7 @@
;;; Commentary:
;; What does it do? Well, it allows you to search your mail using
-;; some search engine (imap, namazu, swish-e, gmane and others -- see
+;; 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).
@@ -161,11 +161,11 @@
;; So what do you need to do when you want to add another search
;; engine? You write a function that executes the query. Temporary
-;; data from the search engine can be put in `nnir-tmp-buffer'. This
-;; function should return the list of articles as a vector, as
-;; described above. Then, you need to register this backend in
-;; `nnir-engines'. Then, users can choose the backend by setting
-;; `nnir-search-engine' as a server variable.
+;; 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:
@@ -175,7 +175,12 @@
(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:
@@ -191,28 +196,7 @@
(defvar nnir-search-history ()
"Internal: the history for querying search options in nnir")
-(defconst nnir-tmp-buffer " *nnir*"
- "Internal: temporary buffer.")
-
-
-;; Imap variables
-
-(defvar nnir-imap-search-arguments
- '(("whole message" . "TEXT")
- ("subject" . "SUBJECT")
- ("to" . "TO")
- ("from" . "FROM")
- ("body" . "BODY")
- ("imap" . ""))
- "Mapping from user readable keys to IMAP search items for use in nnir")
-
-(defvar nnir-imap-search-other "HEADER %S"
- "The IMAP search item to use for anything other than
- `nnir-imap-search-arguments'. By default this is the name of an
- email header field")
-
-(defvar nnir-imap-search-argument-history ()
- "The history for querying search options in nnir")
+(define-error 'gnus-search-parse-error "Gnus search parsing error")
;;; Helper macros
@@ -285,13 +269,26 @@ is `(valuefunc member)'."
(gnus-declare-backend "nnir" 'mail 'virtual)
-
;;; User Customizable Variables:
(defgroup nnir nil
"Search groups in Gnus with assorted search engines."
:group 'gnus)
+(defcustom nnir-use-parsed-queries t
+ "When t, use Gnus' generalized search language.
+
+The generalized search language is a sort of \"meta 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 "26.3"
+ :type 'boolean
+ :group 'nnir)
+
(defcustom nnir-ignored-newsgroups ""
"A regexp to match newsgroups in the active file that should
be skipped when searching."
@@ -326,23 +323,18 @@ result, `gnus-retrieve-headers' will be called instead."
:type '(choice (const :tag "gnus-retrieve-headers" nil) function)
:group 'nnir)
-(defcustom nnir-imap-default-search-key "whole message"
- "The default IMAP search key for an nnir search. Must be one of
- the keys in `nnir-imap-search-arguments'. To use raw imap queries
- by default set this to \"imap\"."
- :version "24.1"
- :type `(choice ,@(mapcar (lambda (elem) (list 'const (car elem)))
- nnir-imap-search-arguments))
- :group 'nnir)
-
(defcustom nnir-swish++-configuration-file
(expand-file-name "~/Mail/swish++.conf")
- "Configuration file for swish++."
- :type '(file)
+ "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."
+ "Name of swish++ search executable.
+
+This variable can also be set per-server."
:type '(string)
:group 'nnir)
@@ -352,7 +344,9 @@ result, `gnus-retrieve-headers' will be called instead."
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 \\='(\"-i\" \"-w\"))"
+ (setq nnir-swish++-additional-switches \\='(\"-i\" \"-w\"))
+
+This variable can also be set per-server."
:type '(repeat (string))
:group 'nnir)
@@ -361,37 +355,29 @@ Instead, use this:
in order to get a group name (albeit with / instead of .). This is a
regular expression.
-This variable is very similar to `nnir-namazu-remove-prefix', except
-that it is for swish++, not Namazu."
+This variable can also be set per-server."
:type '(regexp)
:group 'nnir)
-;; Swish-E.
-;; URL: http://swish-e.org/
-;; Variables `nnir-swish-e-index-file', `nnir-swish-e-program' and
-;; `nnir-swish-e-additional-switches'
-
-(make-obsolete-variable 'nnir-swish-e-index-file
- 'nnir-swish-e-index-files "Emacs 23.1")
-(defcustom nnir-swish-e-index-file
- (expand-file-name "~/Mail/index.swish-e")
- "Index file for swish-e.
-This could be a server parameter.
-It is never consulted once `nnir-swish-e-index-files', which should be
-used instead, has been customized."
- :type '(file)
+(defcustom nnir-swish++-raw-queries-p nil
+ "If t, all Swish++ engines will only accept raw search query
+ strings."
+ :type 'boolean
+ :version "26.3"
:group 'nnir)
-(defcustom nnir-swish-e-index-files
- (list nnir-swish-e-index-file)
- "List of index files for swish-e.
-This could be a server parameter."
- :type '(repeat (file))
+(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 "swish-e"
+(defcustom nnir-swish-e-program "search"
"Name of swish-e search executable.
-This cannot be a server parameter."
+
+This variable can also be set per-server."
:type '(string)
:group 'nnir)
@@ -403,7 +389,7 @@ Note that this should be a list. I.e., do NOT use the
following:
Instead, use this:
(setq nnir-swish-e-additional-switches \\='(\"-i\" \"-w\"))
-This could be a server parameter."
+This variable can also be set per-server."
:type '(repeat (string))
:group 'nnir)
@@ -412,17 +398,30 @@ This could be a server parameter."
in order to get a group name (albeit with / instead of .). This is a
regular expression.
-This variable is very similar to `nnir-namazu-remove-prefix', except
-that it is for swish-e, not Namazu.
-
-This could be a server parameter."
+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)
+
+(defcustom nnir-swish-e-raw-queries-p nil
+ "If t, all Swish-e engines will only accept raw search query
+ strings."
+ :type 'boolean
+ :version "26.3"
+ :group 'nnir)
+
;; HyREX engine, see <URL:http://ls6-www.cs.uni-dortmund.de/>
(defcustom nnir-hyrex-program "nnir-search"
- "Name of the nnir-search executable."
+ "Name of the nnir-search executable.
+
+This variable can also be set per-server."
:type '(string)
:group 'nnir)
@@ -431,12 +430,16 @@ This could be a server parameter."
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 \\='(\"-ddl\" \"ddl.xml\" \"-c\"
\"nnir\"))"
+ (setq nnir-hyrex-additional-switches \\='(\"-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."
+ "Index directory for HyREX.
+
+This variable can also be set per-server."
:type '(directory)
:group 'nnir)
@@ -449,19 +452,32 @@ For example, suppose that HyREX returns file names such as
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\"."
+arrive at the correct group name, \"mail.misc\".
+
+This variable can also be set per-server."
:type '(directory)
:group 'nnir)
+(defcustom nnir-hyrex-raw-queries-p nil
+ "If t, all Hyrex engines will only accept raw search query
+ strings."
+ :type 'boolean
+ :version "26.3"
+ :group 'nnir)
+
;; Namazu engine, see <URL:http://www.namazu.org/>
(defcustom nnir-namazu-program "namazu"
- "Name of Namazu search executable."
+ "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."
+ "Index directory for Namazu.
+
+This variable can also be set per-server."
:type '(directory)
:group 'nnir)
@@ -473,7 +489,9 @@ 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 \\='(\"-i\" \"-w\"))"
+ (setq nnir-namazu-additional-switches \\='(\"-i\" \"-w\"))
+
+This variable can also be set per-server."
:type '(repeat (string))
:group 'nnir)
@@ -486,23 +504,44 @@ For example, suppose that Namazu returns file names such
as
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\"."
+arrive at the correct group name, \"mail.misc\".
+
+This variable can also be set per-server."
:type '(directory)
:group 'nnir)
+(defcustom nnir-namazu-raw-queries-p nil
+ "If t, all Namazu engines will only accept raw search query
+ strings."
+ :type 'boolean
+ :version "26.3"
+ :group 'nnir)
+
(defcustom nnir-notmuch-program "notmuch"
- "Name of notmuch search executable."
+ "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 \\='(\"-i\" \"-w\"))"
+ (setq nnir-notmuch-additional-switches \\='(\"-i\" \"-w\"))
+
+This variable can also be set per-server."
:version "24.1"
:type '(repeat (string))
:group 'nnir)
@@ -512,826 +551,1122 @@ Instead, use this:
in order to get a group name (albeit with / instead of .). This is a
regular expression.
-This variable is very similar to `nnir-namazu-remove-prefix', except
-that it is for notmuch, not Namazu."
+This variable can also be set per-server."
:version "24.1"
:type '(regexp)
:group 'nnir)
-;;; Developer Extension Variable:
-
-(defvar nnir-engines
- `((imap nnir-run-imap
- ((criteria
- "Imap Search in" ; Prompt
- ,(mapcar 'car nnir-imap-search-arguments) ; alist for completing
- nil ; allow any user input
- nil ; initial value
- nnir-imap-search-argument-history ; the history to use
- ,nnir-imap-default-search-key ; default
- )))
- (gmane nnir-run-gmane
- ((gmane-author . "Gmane Author: ")))
- (swish++ nnir-run-swish++
- ((swish++-group . "Swish++ Group spec (regexp): ")))
- (swish-e nnir-run-swish-e
- ((swish-e-group . "Swish-e Group spec (regexp): ")))
- (namazu nnir-run-namazu
- ())
- (notmuch nnir-run-notmuch
- ())
- (hyrex nnir-run-hyrex
- ((hyrex-group . "Hyrex Group spec (regexp): ")))
- (find-grep nnir-run-find-grep
- ((grep-options . "Grep options: "))))
- "Alist of supported search engines.
-Each element in the alist is a three-element list (ENGINE FUNCTION ARGS).
-ENGINE is a symbol designating the searching engine. FUNCTION is also
-a symbol, giving the function that does the search. The third element
-ARGS is a list of cons pairs (PARAM . PROMPT). When issuing a query,
-the FUNCTION will issue a query for each of the PARAMs, using PROMPT.
-
-The value of `nnir-search-engine' must be one of the ENGINE symbols.
-For example, for searching a server using namazu include
- (nnir-search-engine namazu)
-in the server definition. Note that you have to set additional
-variables for most backends. For example, the `namazu' backend
-needs the variables `nnir-namazu-program',
-`nnir-namazu-index-directory' and `nnir-namazu-remove-prefix'.
-
-Add an entry here when adding a new search engine.")
-
-(defcustom nnir-method-default-engines '((nnimap . imap) (nntp . gmane))
- "Alist of default search engines keyed by server method."
- :version "24.1"
+(defcustom nnir-notmuch-raw-queries-p nil
+ "If t, all Notmuch engines will only accept raw search query
+ strings."
+ :type 'boolean
+ :version "26.3"
+ :group 'nnir)
+
+(defcustom nnir-imap-raw-queries-p nil
+ "If t, all IMAP engines will only accept raw search query
+ strings."
+ :version "26.3"
+ :type 'boolean
+ :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" "address" "tag" "size")
+ "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
- :type `(repeat (cons (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 (elem) (list 'const (car elem)))
- nnir-engines)))))
+ :version "26.1"
+ :type '(repeat string))
-;; Gnus glue.
+(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.
-(declare-function gnus-group-topic-name "gnus-topic" ())
+See the docstring of `nnir-search-parse-query' for information on
+date parsing."
-(defun gnus-group-make-nnir-group (nnir-extra-parms &optional specs)
- "Create an nnir group. Prompt for a search query and determine
-the groups to search as follows: if called from the *Server*
-buffer search all groups belonging to the server on the current
-line; if called from the *Group* buffer search any marked groups,
-or the group on the current line, or all the groups under the
-current topic. Calling with a prefix-arg prompts for additional
-search-engine specific constraints. A non-nil `specs' arg must be
-an alist with `nnir-query-spec' and `nnir-group-spec' keys, and
-skips all prompting."
- (interactive "P")
- (let* ((group-spec
- (or (cdr (assq 'nnir-group-spec specs))
- (if (gnus-server-server-name)
- (list (list (gnus-server-server-name)))
- (nnir-categorize
- (or gnus-group-marked
- (if (gnus-group-group-name)
- (list (gnus-group-group-name))
- (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
- (read-string "Query: " nil 'nnir-search-history)))
- (when nnir-extra-parms
- (mapcar
- (lambda (x)
- (nnir-read-parms (nnir-server-to-search-engine (car x))))
- group-spec))))))
- (gnus-group-read-ephemeral-group
- (concat "nnir-" (message-unique-id))
- (list 'nnir "nnir")
- nil
-; (cons (current-buffer) gnus-current-window-configuration)
- nil
- nil nil
- (list
- (cons 'nnir-specs (list (cons 'nnir-query-spec query-spec)
- (cons 'nnir-group-spec group-spec)))
- (cons 'nnir-artlist nil)))))
+ :group 'nnir
+ :version "26.1"
+ :type '(repeat string))
-(defun gnus-summary-make-nnir-group (nnir-extra-parms)
- "Search a group from the summary buffer."
- (interactive "P")
- (gnus-warp-to-article)
- (let ((spec
- (list
- (cons 'nnir-group-spec
- (list (list
- (gnus-group-server gnus-newsgroup-name)
- (list gnus-newsgroup-name)))))))
- (gnus-group-make-nnir-group nnir-extra-parms spec)))
+(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)))))
-;; Gnus backend interface functions.
+;;; Search language
-(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))))
+;; This "language" was generalized from the original IMAP search query
+;; parsing routine.
-(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)
+(defun nnir-search-parse-query (string)
+ "Turn STRING into an s-expression based query.
-(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)))
+The resulting query structure is passed to the various search
+backends, each of which adapts it as needed.
-(deffoo nnir-request-article (article &optional group server to-buffer)
- (nnir-possibly-change-group group server)
- (if (and (stringp article)
- (not (eq 'nnimap (car (gnus-server-to-method server)))))
- (nnheader-report
- 'nnir
- "nnir-request-article only groks message ids for nnimap servers: %s"
- server)
- (save-excursion
- (let ((article article)
- query)
- (when (stringp article)
- (setq gnus-override-method (gnus-server-to-method server))
- (setq query
- (list
- (cons 'query (format "HEADER Message-ID %s" article))
- (cons 'criteria "")
- (cons 'shortcut t)))
- (unless (and nnir-artlist (equal query nnir-memo-query)
- (equal server nnir-memo-server))
- (setq nnir-artlist (nnir-run-imap query server)
- nnir-memo-query query
- nnir-memo-server server))
- (setq article 1))
- (unless (zerop (nnir-artlist-length nnir-artlist))
- (let ((artfullgroup (nnir-article-group article))
- (artno (nnir-article-number article)))
- (message "Requesting article %d from group %s"
- artno artfullgroup)
- (if to-buffer
- (with-current-buffer to-buffer
- (let ((gnus-article-decode-hook nil))
- (gnus-request-article-this-buffer artno artfullgroup)))
- (gnus-request-article artno artfullgroup))
- (cons artfullgroup artno)))))))
+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.
-(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)))))
+A key that matches the name of a mail header will search that
+header.
-(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))
+Search keys can be abbreviated so long as they remain
+unambiguous, ie \"f\" will search the \"from\" header. \"s\" will
+raise an error.
-(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)))
+Other keys:
- ;; 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
+\"address\" will search all sender and recipient headers.
- ;;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))))
+\"recipient\" will search \"To\", \"Cc\", and \"Bcc\".
-(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)))
+\"before\" will search messages sent before the specified
+date (date specifications to come later). Date is exclusive.
-(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)))))
+\"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.
-(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))))
-
-
-
-
-(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")
-
-;; Helper function currently used by the Swish++ and Namazu backends;
-;; perhaps useful for other backends as well
-(defun nnir-compose-result (dirnam article score prefix server)
- "Extract the group from dirnam, and create a result vector
-ready to be added to the list of search results."
-
- ;; remove nnir-*-remove-prefix from beginning of dirnam filename
- (when (string-match (concat "^" prefix) dirnam)
- (setq dirnam (replace-match "" t t dirnam)))
+\"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.
- (when (file-readable-p (concat prefix dirnam article))
- ;; remove trailing slash and, for nnmaildir, cur/new/tmp
- (setq dirnam
- (substring dirnam 0
- (if (string-match "\\`nnmaildir:" (gnus-group-server
server))
- -5 -1)))
+\"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.
- ;; 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)))
+\"contact-from\" does what you'd expect.
- (vector (gnus-group-full-name group server)
- (if (string-match "\\`nnmaildir:" (gnus-group-server server))
- (nnmaildir-base-name-to-article-number
- (substring article 0 (string-match ":" article))
- group nil)
- (string-to-number article))
- (string-to-number score)))))
+\"contact-to\" searches the same headers as \"recipient\".
-;;; Search Engine Interfaces:
+Other keys can be specified, provided that the search backends
+know how to interpret them.
-(autoload 'nnimap-change-group "nnimap")
-(declare-function nnimap-buffer "nnimap" ())
-(declare-function nnimap-command "nnimap" (&rest args))
+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.
-;; imap interface
-(defun nnir-run-imap (query srv &optional groups)
- "Run a search against an IMAP back-end server.
-This uses a custom query language parser; see `nnir-imap-make-query' for
-details on the language and supported extensions."
- (save-excursion
- (let ((qstring (cdr (assq 'query query)))
- (server (cadr (gnus-server-to-method srv)))
- (defs (nth 2 (gnus-server-to-method srv)))
- (criteria (or (cdr (assq 'criteria query))
- (cdr (assoc nnir-imap-default-search-key
- nnir-imap-search-arguments))))
- (gnus-inhibit-demon t)
- (groups (or groups (nnir-get-active srv))))
- (message "Opening server %s" server)
- (apply
- 'vconcat
- (catch 'found
- (mapcar
- #'(lambda (group)
- (let (artlist)
- (condition-case ()
- (when (nnimap-change-group
- (gnus-group-short-name group) server)
- (with-current-buffer (nnimap-buffer)
- (message "Searching %s..." group)
- (let ((arts 0)
- (result (nnimap-command "UID SEARCH %s"
- (if (string= criteria "")
- qstring
- (nnir-imap-make-query
- criteria qstring)))))
- (mapc
- (lambda (artnum)
- (let ((artn (string-to-number artnum)))
- (when (> artn 0)
- (push (vector group artn 100)
- artlist)
- (when (assq 'shortcut query)
- (throw 'found (list artlist)))
- (setq arts (1+ arts)))))
- (and (car result)
- (cdr (assoc "SEARCH" (cdr result)))))
- (message "Searching %s... %d matches" group arts)))
- (message "Searching %s...done" group))
- (quit nil))
- (nreverse artlist)))
- groups))))))
-
-(defun nnir-imap-make-query (criteria qstring)
- "Parse the query string and criteria into an appropriate IMAP search
-expression, returning the string query to make.
-
-This implements a little language designed to return the expected results
-to an arbitrary query string to the end user.
-
-The search is always case-insensitive, as defined by RFC2060, and supports
-the following features (inspired by the Google search input language):
-
-Automatic \"and\" queries
- If you specify multiple words then they will be treated as an \"and\"
- expression intended to match all components.
-
-Phrase searches
- If you wrap your query in double-quotes then it will be treated as a
- literal string.
-
-Negative terms
- If you precede a term with \"-\" then it will negate that.
-
-\"OR\" queries
- If you include an upper-case \"OR\" in your search it will cause the
- term before it and the term after it to be treated as alternatives.
-
-In future the following will be added to the language:
- * support for date matches
- * support for location of text matching within the query
- * from/to/etc headers
- * additional search terms
- * flag based searching
- * anything else that the RFC supports, basically."
- ;; Walk through the query and turn it into an IMAP query string.
- (nnir-imap-query-to-imap criteria (nnir-imap-parse-query qstring)))
-
-
-(defun nnir-imap-query-to-imap (criteria query)
- "Turn a s-expression format query into IMAP."
- (mapconcat
- ;; Turn the expressions into IMAP text
- (lambda (item)
- (nnir-imap-expr-to-imap criteria item))
- ;; The query, already in s-expr format.
- query
- ;; Append a space between each expression
- " "))
-
-
-(defun nnir-imap-expr-to-imap (criteria expr)
- "Convert EXPR into an IMAP search expression on CRITERIA"
- ;; What sort of expression is this, eh?
- (cond
- ;; Simple string term
- ((stringp expr)
- (format "%s %S" criteria expr))
- ;; Trivial term: and
- ((eq expr 'and) nil)
- ;; Composite term: or expression
- ((eq (car-safe expr) 'or)
- (format "OR %s %s"
- (nnir-imap-expr-to-imap criteria (nth 1 expr))
- (nnir-imap-expr-to-imap criteria (nth 2 expr))))
- ;; Composite term: just the fax, mam
- ((eq (car-safe expr) 'not)
- (format "NOT (%s)" (nnir-imap-query-to-imap criteria (cdr expr))))
- ;; Composite term: just expand it all.
- ((consp expr)
- (format "(%s)" (nnir-imap-query-to-imap criteria expr)))
- ;; Complex value, give up for now.
- (t (error "Unhandled input: %S" expr))))
-
-
-(defun nnir-imap-parse-query (string)
- "Turn STRING into an s-expression based query based on the IMAP
-query language as defined in `nnir-imap-make-query'.
-
-This involves turning individual tokens into higher level terms
-that the search language can then understand and use."
+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-imap-end-of-input))
- (push (nnir-imap-next-expr) out))
+ (while (not (nnir-query-end-of-input))
+ (push (nnir-query-next-expr) out))
(reverse out))))
-
-(defun nnir-imap-next-expr (&optional count)
+(defun nnir-query-next-expr (&optional count halt)
"Return the next expression from the current buffer."
- (let ((term (nnir-imap-next-term count))
- (next (nnir-imap-peek-symbol)))
- ;; Are we looking at an 'or' expression?
+ (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'
- ((eq next 'or)
- (list 'or term (nnir-imap-next-expr 2)))
+ ((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-imap-next-term (&optional count)
+(defun nnir-query-next-term (&optional count)
"Return the next TERM from the current buffer."
- (let ((term (nnir-imap-next-symbol count)))
+ (let ((term (nnir-query-next-symbol count)))
;; What sort of term is this?
(cond
- ;; and -- just ignore it
- ((eq term 'and) 'and)
;; negated term
- ((eq term 'not) (list 'not (nnir-imap-next-expr)))
+ ((eq term 'not) (list 'not (nnir-query-next-expr nil 'halt)))
;; generic term
(t term))))
-
-(defun nnir-imap-peek-symbol ()
+(defun nnir-query-peek-symbol ()
"Return the next symbol from the current buffer, but don't consume it."
(save-excursion
- (nnir-imap-next-symbol)))
+ (nnir-query-next-symbol)))
-(defun nnir-imap-next-symbol (&optional count)
+(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-imap-next-symbol (1- count)))
+ (nnir-query-next-symbol (1- count)))
(let ((case-fold-search t))
;; end of input stream?
- (unless (nnir-imap-end-of-input)
+ (unless (nnir-query-end-of-input)
;; No, return the next symbol from the stream.
(cond
- ;; negated expression -- return it and advance one char.
+ ;; Negated expression -- return it and advance one char.
((looking-at "-") (forward-char 1) 'not)
- ;; quoted string
- ((looking-at "\"") (nnir-imap-delimited-string "\""))
- ;; list expression -- we parse the content and return this as a list.
+ ;; List expression -- we parse the content and return this as a list.
((looking-at "(")
- (nnir-imap-parse-query (nnir-imap-delimited-string ")")))
- ;; keyword input -- return a symbol version
+ (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)
- ;; Simple, boring keyword
- (t (let ((start (point))
- (end (if (search-forward-regexp "[[:blank:]]" nil t)
- (prog1
- (match-beginning 0)
- ;; unskip if we hit a non-blank terminal character.
- (when (string-match "[^[:blank:]]" (match-string 0))
- (backward-char 1)))
- (goto-char (point-max)))))
- (buffer-substring start end)))))))
-
-(defun nnir-imap-delimited-string (delimiter)
- "Return a delimited string from the current buffer."
+ ((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= "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 "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 (= 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= 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= 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
separator."
+;; (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 and
+;; ;; results of `all-completions' back in as a COLLECTION argument.
+;; (if (= 1 (length comp))
+;; (setq key (car comp))
+;; (when (setq comp (try-completion bit nnir-search-expandable-keys))
+;; (if (and (string= 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)
- (forward-char 1) ; skip the first delimiter.
- (while (not end)
- (unless (search-forward delimiter nil t)
- (error "Unmatched delimited input with %s in query" delimiter))
- (let ((here (point)))
- (unless (equal (buffer-substring (- here 2) (- here 1)) "\\")
- (setq end (point)))))
- (buffer-substring (1+ start) (1- end))))
-
-(defun nnir-imap-end-of-input ()
+ (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" delimiter))))
+ (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-max)
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))))
-;; Swish++ interface.
-;; -cc- Todo
-;; Search by
-;; - group
-;; Sort by
-;; - rank (default)
-;; - article number
-;; - file size
-;; - group
-(defun nnir-run-swish++ (query server &optional group)
- "Run QUERY against swish++.
-Returns a vector of (group name, file name) pairs (also vectors,
-actually).
+(autoload 'nnmaildir-base-name-to-article-number "nnmaildir")
-Tested with swish++ 4.7 on GNU/Linux and with swish++ 5.0b2 on
-Windows NT 4.0."
+(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."
- ;; (when group
- ;; (error "The swish++ backend cannot search specific groups"))
+ ;; 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)))
- (save-excursion
- (let ( (qstring (cdr (assq 'query query)))
- (groupspec (cdr (assq 'swish++-group query)))
- (prefix (nnir-read-server-parm 'nnir-swish++-remove-prefix server))
- artlist
- ;; nnml-use-compressed-files might be any string, but probably this
- ;; is sufficient. Note that we can't only use the value of
- ;; nnml-use-compressed-files because old articles might have been
- ;; saved with a different value.
- (article-pattern (if (string-match "\\`nnmaildir:"
- (gnus-group-server server))
- ":[0-9]+"
- "^[0-9]+\\(\\.[a-z0-9]+\\)?$"))
- score artno dirnam filenam)
-
- (when (equal "" qstring)
- (error "swish++: You didn't enter anything"))
-
- (set-buffer (get-buffer-create nnir-tmp-buffer))
- (erase-buffer)
+ (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))
- (if groupspec
- (message "Doing swish++ query %s on %s..." qstring groupspec)
- (message "Doing swish++ query %s..." qstring))
-
- (let* ((cp-list `( ,nnir-swish++-program
- nil ; input from /dev/null
- t ; output
- nil ; don't redisplay
- "--config-file" ,(nnir-read-server-parm
'nnir-swish++-configuration-file server)
- ,@(nnir-read-server-parm
'nnir-swish++-additional-switches server)
- ,qstring ; the query, in swish++ format
- ))
- (exitstatus
- (progn
- (message "%s args: %s" nnir-swish++-program
- (mapconcat #'identity (nthcdr 4 cp-list) " ")) ;; ???
- (apply #'call-process cp-list))))
- (unless (or (null exitstatus)
- (zerop exitstatus))
- (nnheader-report 'nnir "Couldn't run swish++: %s" exitstatus)
- ;; swish++ failure reason is in this buffer, show it if
- ;; the user wants it.
- (when (> gnus-verbose 6)
- (display-buffer nnir-tmp-buffer))))
-
- ;; The results are output in the format of:
- ;; V 4.7 Linux
- ;; rank relative-path-name file-size file-title
- ;; V 5.0b2:
- ;; rank relative-path-name file-size topic??
- ;; where rank is an integer from 1 to 100.
- (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))
+ ;; 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)))
- ;; maybe limit results to matching groups.
- (when (or (not groupspec)
- (string-match groupspec dirnam))
- (nnir-add-result dirnam artno score prefix server artlist)))))
+ (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 ()
+ ((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-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 " *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. Currently unimplemented.")
+ (fuzzy
+ :initarg :fuzzy
+ :iniformt 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 unimplemented."))
+ :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
+ nnir-imap-raw-queries-p)
+
+(defclass gnus-search-find-grep (gnus-search-engine gnus-search-process)
+ 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)
+ ((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 index
+ 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 'index-files
+ nnir-swish-e-index-files)
+
+(eieio-oset-default 'gnus-search-swish-e 'switches
+ nnir-swish-e-additional-switches)
+
+(eieio-oset-default 'gnus-search-swish-e 'raw-queries-p
+ nnir-swish-e-raw-queries-p)
+
+(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)
+
+(eieio-oset-default 'gnus-search-swish++ 'raw-queries-p
+ nnir-swish++-raw-queries-p)
+
+;; 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)
+
+(eieio-oset-default 'gnus-search-hyrex 'raw-queries-p
+ nnir-hyrex-raw-queries-p)
+
+(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)
- (message "Massaging swish++ output...done")
+(eieio-oset-default 'gnus-search-namazu 'index-dir
+ nnir-namazu-index-directory)
+
+(eieio-oset-default 'gnus-search-namazu 'switches
+ nnir-namazu-additional-switches)
- ;; Sort by score
- (apply #'vector
- (sort artlist
- (function (lambda (x y)
- (> (nnir-artitem-rsv x)
- (nnir-artitem-rsv y)))))))))
+(eieio-oset-default 'gnus-search-namazu 'prefix
+ nnir-namazu-remove-prefix)
-;; Swish-E interface.
-(defun nnir-run-swish-e (query server &optional group)
- "Run given query against swish-e.
-Returns a vector of (group name, file name) pairs (also vectors,
-actually).
+(eieio-oset-default 'gnus-search-namazu 'raw-queries-p
+ nnir-namazu-raw-queries-p)
-Tested with swish-e-2.0.1 on Windows NT 4.0."
+(defclass gnus-search-notmuch (gnus-search-indexed)
+ ((config-file
+ :init-arg :config-file
+ :type string)))
- ;; swish-e crashes with empty parameter to "-w" on commandline...
- ;; (when group
- ;; (error "The swish-e backend cannot search specific groups"))
+(eieio-oset-default 'gnus-search-notmuch 'program
+ nnir-notmuch-program)
- (save-excursion
- (let ((qstring (cdr (assq 'query query)))
- (prefix
- (or (nnir-read-server-parm 'nnir-swish-e-remove-prefix server)
- (error "Missing parameter `nnir-swish-e-remove-prefix'")))
- artlist score artno dirnam group )
+(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)
+
+(eieio-oset-default 'gnus-search-notmuch 'raw-queries-p
+ nnir-notmuch-raw-queries-p)
+
+(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))
- (when (equal "" qstring)
- (error "swish-e: You didn't enter anything"))
+;; 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)))
+ (when (listp query)
+ (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= (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 (= (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."
- (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (save-excursion
+ (let* ((qstring (if (listp query)
+ (nnir-search-transform-top-level engine query)
+ query))
+ (program (slot-value engine 'program))
+ (buffer (slot-value engine 'proc-buffer))
+ (cp-list (nnir-search-indexed-search-command
+ engine qstring groups))
+ proc exitstatus artlist)
+ (set-buffer buffer)
(erase-buffer)
- (message "Doing swish-e query %s..." query)
- (let* ((index-files
- (or (nnir-read-server-parm
- 'nnir-swish-e-index-files server)
- (error "Missing parameter `nnir-swish-e-index-files'")))
- (additional-switches
- (nnir-read-server-parm
- 'nnir-swish-e-additional-switches server))
- (cp-list `(,nnir-swish-e-program
- nil ; input from /dev/null
- t ; output
- nil ; don't redisplay
- "-f" ,@index-files
- ,@additional-switches
- "-w"
- ,qstring ; the query, in swish-e format
- ))
- (exitstatus
- (progn
- (message "%s args: %s" nnir-swish-e-program
- (mapconcat #'identity (nthcdr 4 cp-list) " "))
- (apply #'call-process cp-list))))
- (unless (or (null exitstatus)
- (zerop exitstatus))
- (nnheader-report 'nnir "Couldn't run swish-e: %s" exitstatus)
- ;; swish-e failure reason is in this buffer, show it if
- ;; the user wants it.
- (when (> gnus-verbose 6)
- (display-buffer nnir-tmp-buffer))))
-
- ;; The results are output in the format of:
- ;; rank path-name file-title file-size
- (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)))
-
- ;; don't match directories
- (when (string-match "^[0-9]+$" artno)
+ (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-search-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 = %s" (car expr) (nnir-search-transform-top-level
+ engine
+ (nnir-search-parse-query (cdr expr)))))
+ (t (format "%s = %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
@@ -1350,242 +1685,230 @@ Tested with swish-e-2.0.1 on Windows NT 4.0."
(push (vector (gnus-group-full-name group server)
(string-to-number artno)
(string-to-number score))
- artlist))))
-
- (message "Massaging swish-e output...done")
-
- ;; Sort by score
- (apply #'vector
- (sort artlist
- (function (lambda (x y)
- (> (nnir-artitem-rsv x)
- (nnir-artitem-rsv y)))))))))
+ artlist))))))
;; HyREX interface
-(defun nnir-run-hyrex (query server &optional group)
- (save-excursion
- (let ((artlist nil)
- (groupspec (cdr (assq 'hyrex-group query)))
- (qstring (cdr (assq 'query query)))
- (prefix (nnir-read-server-parm 'nnir-hyrex-remove-prefix server))
- score artno dirnam)
- (when (and (not groupspec) group)
- (setq groupspec
- (regexp-opt
- (mapcar (lambda (x) (gnus-group-real-name x)) group))))
- (set-buffer (get-buffer-create nnir-tmp-buffer))
- (erase-buffer)
- (message "Doing hyrex-search query %s..." query)
- (let* ((cp-list
- `( ,nnir-hyrex-program
- nil ; input from /dev/null
- t ; output
- nil ; don't redisplay
- "-i",(nnir-read-server-parm 'nnir-hyrex-index-directory
server) ; index directory
- ,@(nnir-read-server-parm 'nnir-hyrex-additional-switches
server)
- ,qstring ; the query, in hyrex-search format
- ))
- (exitstatus
- (progn
- (message "%s args: %s" nnir-hyrex-program
- (mapconcat #'identity (nthcdr 4 cp-list) " "))
- (apply #'call-process cp-list))))
- (unless (or (null exitstatus)
- (zerop exitstatus))
- (nnheader-report 'nnir "Couldn't run hyrex-search: %s" exitstatus)
- ;; nnir-search failure reason is in this buffer, show it if
- ;; the user wants it.
- (when (> gnus-verbose 6)
- (display-buffer nnir-tmp-buffer)))) ;; FIXME: Don't clear buffer !
- (message "Doing hyrex-search query \"%s\"...done" qstring)
- (sit-for 0)
- ;; nnir-search returns:
- ;; for nnml/nnfolder: "filename mailid weight"
- ;; for nnimap: "group mailid weight"
- (goto-char (point-min))
- (delete-non-matching-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))
- (message "Massaging hyrex-search output...done.")
- (apply #'vector
- (sort artlist
- (function (lambda (x y)
- (if (string-lessp (nnir-artitem-group x)
- (nnir-artitem-group y))
- t
- (< (nnir-artitem-number x)
- (nnir-artitem-number y)))))))
- )))
-
-;; Namazu interface
-(defun nnir-run-namazu (query server &optional group)
- "Run given query against Namazu. Returns a vector of (group name, file name)
-pairs (also vectors, actually).
-
-Tested with Namazu 2.0.6 on a GNU/Linux system."
- ;; (when group
- ;; (error "The Namazu backend cannot search specific groups"))
- (save-excursion
- (let ((article-pattern (if (string-match "\\`nnmaildir:"
- (gnus-group-server server))
- ":[0-9]+"
- "^[0-9]+$"))
- artlist
- (qstring (cdr (assq 'query query)))
- (prefix (nnir-read-server-parm 'nnir-namazu-remove-prefix server))
- score group article
- (process-environment (copy-sequence process-environment)))
- (setenv "LC_MESSAGES" "C")
- (set-buffer (get-buffer-create nnir-tmp-buffer))
- (erase-buffer)
- (let* ((cp-list
- `( ,nnir-namazu-program
- nil ; input from /dev/null
- t ; output
- nil ; don't redisplay
- "-q" ; don't be verbose
- "-a" ; show all matches
- "-s" ; use short format
- ,@(nnir-read-server-parm 'nnir-namazu-additional-switches
server)
- ,qstring ; the query, in namazu format
- ,(nnir-read-server-parm 'nnir-namazu-index-directory server)
; index directory
- ))
- (exitstatus
- (progn
- (message "%s args: %s" nnir-namazu-program
- (mapconcat #'identity (nthcdr 4 cp-list) " "))
- (apply #'call-process cp-list))))
- (unless (or (null exitstatus)
- (zerop exitstatus))
- (nnheader-report 'nnir "Couldn't run namazu: %s" exitstatus)
- ;; Namazu failure reason is in this buffer, show it if
- ;; the user wants it.
- (when (> gnus-verbose 6)
- (display-buffer nnir-tmp-buffer))))
-
- ;; Namazu output looks something like this:
- ;; 2. Re: Gnus agent expire broken (score: 55)
- ;; /home/henrik/Mail/mail/sent/1310 (4,138 bytes)
- (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)))
- (nnir-add-result group article score prefix server artlist)))
-
- ;; sort artlist by score
- (apply #'vector
- (sort artlist
- (function (lambda (x y)
- (> (nnir-artitem-rsv x)
- (nnir-artitem-rsv y)))))))))
-
-(defun nnir-run-notmuch (query server &optional group)
- "Run QUERY against notmuch.
-Returns a vector of (group name, file name) pairs (also vectors,
-actually)."
-
- ;; (when group
- ;; (error "The notmuch backend cannot search specific groups"))
-
- (save-excursion
- (let ( (qstring (cdr (assq 'query query)))
- (groupspec (cdr (assq 'notmuch-group query)))
- (prefix (nnir-read-server-parm 'nnir-notmuch-remove-prefix server))
- artlist
- (article-pattern (if (string-match "\\`nnmaildir:"
- (gnus-group-server server))
- ":[0-9]+"
- "^[0-9]+$"))
- artno dirnam filenam)
-
- (when (equal "" qstring)
- (error "notmuch: You didn't enter anything"))
-
- (set-buffer (get-buffer-create nnir-tmp-buffer))
- (erase-buffer)
-
- (if groupspec
- (message "Doing notmuch query %s on %s..." qstring groupspec)
- (message "Doing notmuch query %s..." qstring))
-
- (let* ((cp-list `( ,nnir-notmuch-program
- nil ; input from /dev/null
- t ; output
- nil ; don't redisplay
- "search"
- "--format=text"
- "--output=files"
- ,@(nnir-read-server-parm
'nnir-notmuch-additional-switches server)
- ,qstring ; the query, in notmuch format
- ))
- (exitstatus
- (progn
- (message "%s args: %s" nnir-notmuch-program
- (mapconcat #'identity (nthcdr 4 cp-list) " ")) ;; ???
- (apply #'call-process cp-list))))
- (unless (or (null exitstatus)
- (zerop exitstatus))
- (nnheader-report 'nnir "Couldn't run notmuch: %s" exitstatus)
- ;; notmuch failure reason is in this buffer, show it if
- ;; the user wants it.
- (when (> gnus-verbose 6)
- (display-buffer nnir-tmp-buffer))))
-
- ;; The results are output in the format of:
- ;; absolute-path-name
- (goto-char (point-min))
- (while (not (eobp))
- (setq filenam (buffer-substring-no-properties (line-beginning-position)
- (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))
+;; 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))
- ;; maybe limit results to matching groups.
- (when (or (not groupspec)
- (string-match groupspec dirnam))
- (nnir-add-result dirnam artno "" prefix server artlist)))))
+;; Namazu interface
- (message "Massaging notmuch output...done")
+(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
+ )))
- artlist)))
+(cl-defmethod nnir-search-indexed-massage-output ((engine gnus-search-namazu)
+ 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-notmuch)
+ (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
+ `(,(format "--config=%s" config-file)
+ "search"
+ "--format=text"
+ "--output=files"
+ ,@switches
+ ,qstring ; the query, in notmuch format
+ )))
-(defun nnir-run-find-grep (query server &optional grouplist)
+(cl-defmethod nnir-search-indexed-massage-output ((engine gnus-search-notmuch)
+ 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-position)
+ (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 grouplist (nnir-get-active server))))
+ (grouplist (or groups (nnir-get-active server)))
+ (buffer (slot-value engine 'proc-buffer)))
(unless directory
(error "No directory found in method specification of server %s"
server))
@@ -1597,10 +1920,10 @@ actually)."
(message "Searching %s using find-grep..."
(or group server))
(save-window-excursion
- (set-buffer (get-buffer-create nnir-tmp-buffer))
+ (set-buffer buffer)
(if (> gnus-verbose 6)
(pop-to-buffer (current-buffer)))
- (cd directory) ; Using relative paths simplifies
+ (cd directory) ; Using relative paths simplifies
; postprocessing.
(let ((group
(if (not group)
@@ -1657,58 +1980,78 @@ actually)."
(message "Searching %s using find-grep...done"
(or group server))
artlist)))
- grouplist))))
+ 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
-(defun nnir-run-gmane (query srv &optional groups)
+(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)
- (qstring (cdr (assq 'query query)))
- (server (cadr (gnus-server-to-method srv)))
- (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 " "))
- (authorspec
- (if (assq 'gmane-author query)
- (format "author:%s" (cdr (assq 'gmane-author query))) ""))
- (search (format "%s %s %s"
- qstring groupspec authorspec))
- (gnus-inhibit-demon t)
- artlist)
- (require 'mm-url)
- (with-current-buffer (get-buffer-create nnir-tmp-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)))))
+ (let* ((case-fold-search t)
+ (query (plist-get 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 'proc-buffer))
+ (search (format "%s %s"
+ (if (listp query)
+ (nnir-search-transform-top-level query)
+ 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 nnir-search-transform-expression ((_e gnus-search-gmane)
+ (_expr (head near)))
+ nil)
+
+;; Can Gmane handle OR or NOT keywords?
+(cl-defmethod nnir-search-transform-expression ((_e gnus-search-gmane)
+ (_expr (head or)))
+ nil)
+
+(cl-defmethod nnir-search-transform-expression ((_e gnus-search-gmane)
+ (_expr (head not)))
+ nil)
+
+(cl-defmethod nnir-search-transform-expression ((_e gnus-search-gmane)
+ (expr list))
+ "The only keyword value gmane can handle is author, ie from."
+ (when (memq (car expr) '(from sender author address))
+ (format "author:%s" (cdr expr))))
;;; Util Code:
@@ -1718,40 +2061,65 @@ actually)."
(eq 'nnir (car (gnus-find-method-for-group group)))
(and group (string-match "^nnir" group))))
-(defun nnir-read-parms (nnir-search-engine)
- "Reads additional search parameters according to `nnir-engines'."
- (let ((parmspec (nth 2 (assoc nnir-search-engine nnir-engines))))
- (mapcar #'nnir-read-parm parmspec)))
-
-(defun nnir-read-parm (parmspec)
- "Reads a single search parameter.
-`parmspec' is a cons cell, the car is a symbol, the cdr is a prompt."
- (let ((sym (car parmspec))
- (prompt (cdr parmspec)))
- (if (listp prompt)
- (let* ((result (apply #'gnus-completing-read prompt))
- (mapping (or (assoc result nnir-imap-search-arguments)
- (cons nil nnir-imap-search-other))))
- (cons sym (format (cdr mapping) result)))
- (cons sym (read-string prompt)))))
-
(defun nnir-run-query (specs)
- "Invoke appropriate search engine function (see `nnir-engines')."
- (apply #'vconcat
- (mapcar
- (lambda (x)
- (let* ((server (car x))
- (search-engine (nnir-server-to-search-engine server))
- (search-func (cadr (assoc search-engine nnir-engines))))
- (and search-func
- (funcall search-func (cdr (assq 'nnir-query-spec specs))
- server (cadr x)))))
- (cdr (assq 'nnir-group-spec 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 [])
+ (q-spec (plist-get specs :nnir-query-spec))
+ (unparsed-query (plist-get q-spec :query))
+ (prepped-query (if (and nnir-use-parsed-queries
+ (null (plist-get q-spec :no-parse)))
+ (nnir-search-parse-query unparsed-query)
+ unparsed-query)))
+ (mapc
+ (lambda (x)
+ (let* ((server (car x))
+ (search-engine (nnir-server-to-search-engine server))
+ (groups (cadr x))
+ (use-query (if (slot-value search-engine 'raw-queries-p)
+ unparsed-query
+ prepped-query)))
+ (setq results
+ (vconcat
+ (nnir-run-search
+ search-engine server use-query groups)
+ results))))
+ (plist-get specs :nnir-group-spec))
+ 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)
- (or (nnir-read-server-parm 'nnir-search-engine server t)
- (cdr (assoc (car (gnus-server-to-method server))
- nnir-method-default-engines))))
+ (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
@@ -1784,8 +2152,7 @@ header. The current server will be searched. If the
registry is
installed, the server that the registry reports the current
article came from is also searched."
(let* ((query
- (list (cons 'query (nnimap-make-thread-query header))
- (cons 'criteria "")))
+ (list (cons 'query (nnimap-make-thread-query header))))
(server
(list (list (gnus-method-to-server
(gnus-find-method-for-group gnus-newsgroup-name)))))
@@ -1809,8 +2176,7 @@ article came from is also searched."
groups)
(gnus-request-list method)
(with-current-buffer nntp-server-buffer
- (let ((cur (current-buffer))
- name)
+ (let ((cur (current-buffer)))
(goto-char (point-min))
(unless (or (null nnir-ignored-newsgroups)
(string= nnir-ignored-newsgroups ""))
@@ -1818,7 +2184,7 @@ article came from is also searched."
(if (eq (car method) 'nntp)
(while (not (eobp))
(ignore-errors
- (push (string-as-unibyte
+ (push (gnus-group-decoded-name
(gnus-group-full-name
(buffer-substring
(point)
@@ -1830,7 +2196,7 @@ article came from is also searched."
(forward-line))
(while (not (eobp))
(ignore-errors
- (push (string-as-unibyte
+ (push (gnus-group-decoded-name
(if (eq (char-after) ?\")
(gnus-group-full-name (read cur) method)
(let ((p (point)) (name ""))
@@ -1851,7 +2217,7 @@ article came from is also searched."
(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)
+(defun nnir-registry-action (action data-header _from &optional to method)
"Call `gnus-registry-action' with the original article group."
(gnus-registry-action
action
@@ -1872,7 +2238,6 @@ article came from is also searched."
(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"))
@@ -1885,20 +2250,326 @@ article came from is also searched."
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 arg)
+ "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
+ (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
+ (list :query
+ (read-string "Query: " nil nnir-search-history)
+ :no-parse arg)))
+ (gnus-group-read-ephemeral-group
+ (concat "nnir-" (message-unique-id))
+ (list 'nnir "nnir")
+ nil nil nil nil
+ (list
+ (cons 'nnir-specs (list :nnir-query-spec query-spec
+ :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)
+(deffoo nnir-request-create-group (group &optional _server args)
(message "Creating nnir group %s" group)
(let* ((group (gnus-group-prefixed-name group '(nnir "nnir")))
(specs (assq 'nnir-specs args))
(query-spec
- (or (cdr (assq 'nnir-query-spec specs))
- (list (cons 'query
- (read-string "Query: " nil 'nnir-search-history)))))
+ (list :query
+ (read-string "Query: " nil nnir-search-history)))
(group-spec
- (or (cdr (assq 'nnir-group-spec specs))
- (list (list (read-string "Server: " nil nil)))))
- (nnir-specs (list (cons 'nnir-query-spec query-spec)
- (cons 'nnir-group-spec group-spec))))
+ (list (list (read-string "Server: " nil nil))))
+ (nnir-specs (list :nnir-query-spec query-spec
+ :nnir-group-spec group-spec)))
(gnus-group-set-parameter group 'nnir-specs nnir-specs)
(gnus-group-set-parameter
group 'nnir-artlist
@@ -1907,13 +2578,13 @@ article came from is also searched."
(nnir-request-update-info group (gnus-get-info group)))
t)
-(deffoo nnir-request-delete-group (group &optional force server)
+(deffoo nnir-request-delete-group (_group &optional _force _server)
t)
-(deffoo nnir-request-list (&optional server)
+(deffoo nnir-request-list (&optional _server)
t)
-(deffoo nnir-request-scan (group method)
+(deffoo nnir-request-scan (_group _method)
t)
(deffoo nnir-request-close ()
diff --git a/test/lisp/gnus/search-tests.el b/test/lisp/gnus/search-tests.el
new file mode 100644
index 0000000..1e3bc67
--- /dev/null
+++ b/test/lisp/gnus/search-tests.el
@@ -0,0 +1,78 @@
+;;; gnus-search-tests.el --- Tests for Gnus' search routines -*-
lexical-binding: t; -*-
+
+;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;; Author: Eric Abrahamsen <address@hidden>
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Tests for the search parsing, search engines, and their
+;; transformations.
+
+;;; Code:
+
+(require 'ert)
+(require 'nnir)
+
+(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 (nnir-search-parse-query (car p)) (cdr p))))))
+
+(ert-deftest gnus-s-expand-keyword ()
+ "Test expansion of keywords"
+ (let ((nnir-search-expandable-keys
+ (default-value 'nnir-search-expandable-keys))
+ (pairs
+ '(("su" . "subject")
+ ("f" . "from")
+ ("co-f" . "contact-from"))))
+ (dolist (p pairs)
+ (should (equal (nnir-query-expand-key (car p))
+ (cdr p))))
+ (should-error (nnir-query-expand-key "s")
+ :type 'gnus-search-parse-error)
+ (should-error (nnir-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 (nnir-query-parse-date (car p) rel-date)
+ (cdr p))))))
+
+
+
+(provide 'gnus-search-tests)
+;;; search-tests.el ends here