diff options
Diffstat (limited to 'lisp/gnus/gnus-search.el')
| -rw-r--r-- | lisp/gnus/gnus-search.el | 356 |
1 files changed, 272 insertions, 84 deletions
diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 424f11a6b96..369df81d9bd 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -105,9 +105,13 @@ (gnus-add-shutdown #'gnus-search-shutdown 'gnus) -(define-error 'gnus-search-parse-error "Gnus search parsing error") +(define-error 'gnus-search-error "Gnus search error") -(define-error 'gnus-search-config-error "Gnus search configuration error") +(define-error 'gnus-search-parse-error "Gnus search parsing error" + 'gnus-search-error) + +(define-error 'gnus-search-config-error "Gnus search configuration error" + 'gnus-search-error) ;;; User Customizable Variables: @@ -163,10 +167,9 @@ Instead, use this: This variable can also be set per-server." :type '(repeat string)) -(defcustom gnus-search-swish++-remove-prefix (concat (getenv "HOME") "/Mail/") +(defcustom gnus-search-swish++-remove-prefix (expand-file-name "Mail/" "~") "The prefix to remove from each file name returned by swish++ -in order to get a group name (albeit with / instead of .). This is a -regular expression. +in order to get a group name (albeit with / instead of .). This variable can also be set per-server." :type 'regexp) @@ -200,10 +203,9 @@ This variable can also be set per-server." :type '(repeat string) :version "28.1") -(defcustom gnus-search-swish-e-remove-prefix (concat (getenv "HOME") "/Mail/") +(defcustom gnus-search-swish-e-remove-prefix (expand-file-name "Mail/" "~") "The prefix to remove from each file name returned by swish-e -in order to get a group name (albeit with / instead of .). This is a -regular expression. +in order to get a group name (albeit with / instead of .). This variable can also be set per-server." :type 'regexp @@ -248,7 +250,7 @@ This variable can also be set per-server." :type '(repeat string) :version "28.1") -(defcustom gnus-search-namazu-remove-prefix (concat (getenv "HOME") "/Mail/") +(defcustom gnus-search-namazu-remove-prefix (expand-file-name "Mail/" "~") "The prefix to remove from each file name returned by Namazu in order to get a group name (albeit with / instead of .). @@ -292,10 +294,9 @@ This variable can also be set per-server." :type '(repeat string) :version "28.1") -(defcustom gnus-search-notmuch-remove-prefix (concat (getenv "HOME") "/Mail/") +(defcustom gnus-search-notmuch-remove-prefix (expand-file-name "Mail/" "~") "The prefix to remove from each file name returned by notmuch -in order to get a group name (albeit with / instead of .). This is a -regular expression. +in order to get a group name (albeit with / instead of .). This variable can also be set per-server." :type 'regexp @@ -335,10 +336,9 @@ This variable can also be set per-server." :version "28.1" :type '(repeat string)) -(defcustom gnus-search-mairix-remove-prefix (concat (getenv "HOME") "/Mail/") +(defcustom gnus-search-mairix-remove-prefix (expand-file-name "Mail/" "~") "The prefix to remove from each file name returned by mairix -in order to get a group name (albeit with / instead of .). This is a -regular expression. +in order to get a group name (albeit with / instead of .). This variable can also be set per-server." :version "28.1" @@ -349,6 +349,41 @@ This variable can also be set per-server." :version "28.1" :type 'boolean) +(defcustom gnus-search-mu-program "mu" + "Name of the mu search executable. +This can also be set per-server." + :version "29.1" + :type 'string) + +(defcustom gnus-search-mu-switches nil + "A list of strings, to be given as additional arguments to mu. +Note that this should be a list. I.e., do NOT use the following: + (setq gnus-search-mu-switches \"-u -r\") +Instead, use this: + (setq gnus-search-mu-switches \\='(\"-u\" \"-r\")) +This can also be set per-server." + :version "29.1" + :type '(repeat string)) + +(defcustom gnus-search-mu-remove-prefix (expand-file-name "~/Mail/") + "A prefix to remove from the mu results to get a group name. +Usually this will be set to the path to your mail directory. This +can also be set per-server." + :version "29.1" + :type 'directory) + +(defcustom gnus-search-mu-config-directory (expand-file-name "~/.cache/mu") + "Configuration directory for mu. +This can also be set per-server." + :version "29.1" + :type 'file) + +(defcustom gnus-search-mu-raw-queries-p nil + "If t, all mu engines will only accept raw search query strings. +This can also be set per-server." + :version "29.1" + :type 'boolean) + ;; Options for search language parsing. (defcustom gnus-search-expandable-keys @@ -568,15 +603,13 @@ REL-DATE, or (current-time) if REL-DATE is nil." ;; Time parsing doesn't seem to work with slashes. (let ((value (string-replace "/" "-" value)) (now (append '(0 0 0) - (seq-subseq (decode-time (or rel-date - (current-time))) - 3)))) + (seq-subseq (decode-time rel-date) 3)))) ;; Check for relative time parsing. (if (string-match "\\([[:digit:]]+\\)\\([dwmy]\\)" value) (seq-subseq (decode-time (time-subtract - (apply #'encode-time now) + (encode-time now) (days-to-time (* (string-to-number (match-string 1 value)) (cdr (assoc (match-string 2 value) @@ -595,7 +628,7 @@ REL-DATE, or (current-time) if REL-DATE is nil." ;; 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) + (time-subtract (encode-time now) (days-to-time (+ (if (> (seq-elt d-time 6) (seq-elt now 6)) @@ -760,6 +793,9 @@ the files in ARTLIST by that search key.") (generate-new-buffer " *gnus-search-"))) (cl-call-next-method engine slots)) +(defclass gnus-search-nnselect (gnus-search-engine) + nil) + (defclass gnus-search-imap (gnus-search-engine) ((literal-plus :initarg :literal-plus @@ -821,7 +857,7 @@ quirks.") :documentation "Location of the config file, if any.") (remove-prefix :initarg :remove-prefix - :initform (concat (getenv "HOME") "/Mail/") + :initform (expand-file-name "Mail/" "~") :type string :documentation "The path to the directory where the indexed mails are @@ -902,16 +938,30 @@ quirks.") (raw-queries-p :initform (symbol-value 'gnus-search-notmuch-raw-queries-p)))) +(defclass gnus-search-mu (gnus-search-indexed) + ((program + :initform (symbol-value 'gnus-search-mu-program)) + (remove-prefix + :initform (symbol-value 'gnus-search-mu-remove-prefix)) + (switches + :initform (symbol-value 'gnus-search-mu-switches)) + (config-directory + :initform (symbol-value 'gnus-search-mu-config-directory)) + (raw-queries-p + :initform (symbol-value 'gnus-search-mu-raw-queries-p)))) + (define-obsolete-variable-alias 'nnir-method-default-engines 'gnus-search-default-engines "28.1") -(defcustom gnus-search-default-engines '((nnimap . gnus-search-imap)) +(defcustom gnus-search-default-engines '((nnimap . gnus-search-imap) + (nnselect . gnus-search-nnselect)) "Alist of default search engines keyed by server method." :version "26.1" :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)) + (const nnfolder) (const nnmaildir) + (const nnselect)) (choice ,@(mapcar (lambda (el) (list 'const (intern (car el)))) @@ -1008,6 +1058,33 @@ Responsible for handling and, or, and parenthetical expressions.") unseen all old new or not) "Known IMAP search keys.") +(autoload 'nnselect-categorize "nnselect") +(autoload 'nnselect-get-artlist "nnselect" nil nil 'macro) +(autoload 'ids-by-group "nnselect") +;; nnselect interface +(cl-defmethod gnus-search-run-search ((_engine gnus-search-nnselect) + _srv query-spec groups) + (let ((artlist [])) + (dolist (group groups) + (let* ((gnus-newsgroup-selection (nnselect-get-artlist group)) + (group-spec + (nnselect-categorize + (mapcar 'car + (ids-by-group + (number-sequence 1 + (length gnus-newsgroup-selection)))) + (lambda (x) + (gnus-group-server x))))) + (setq artlist + (vconcat artlist + (seq-intersection + gnus-newsgroup-selection + (gnus-search-run-query + (list (cons 'search-query-spec query-spec) + (cons 'search-group-spec group-spec)))))))) + artlist)) + + ;; imap interface (cl-defmethod gnus-search-run-search ((engine gnus-search-imap) srv query groups) @@ -1018,7 +1095,7 @@ Responsible for handling and, or, and parenthetical expressions.") (single-search (gnus-search-single-p query)) (grouplist (or groups (gnus-search-get-active srv))) q-string artlist group) - (message "Opening server %s" server) + (gnus-message 7 "Opening server %s" server) (gnus-open-server srv) ;; We should only be doing this once, in ;; `nnimap-open-connection', but it's too frustrating to try to @@ -1058,11 +1135,11 @@ Responsible for handling and, or, and parenthetical expressions.") q-string))) (while (and (setq group (pop grouplist)) - (or (null single-search) (null artlist))) + (or (null single-search) (= 0 (length artlist)))) (when (nnimap-change-group (gnus-group-short-name group) server) (with-current-buffer (nnimap-buffer) - (message "Searching %s..." group) + (gnus-message 7 "Searching %s..." group) (let ((result (gnus-search-imap-search-command engine q-string))) (when (car result) @@ -1075,7 +1152,7 @@ Responsible for handling and, or, and parenthetical expressions.") (vector group artn 100)))) (cdr (assoc "SEARCH" (cdr result)))) artlist)))) - (message "Searching %s...done" group)))) + (gnus-message 7 "Searching %s...done" group)))) (nreverse artlist)))) (cl-defmethod gnus-search-imap-search-command ((engine gnus-search-imap) @@ -1084,7 +1161,8 @@ Responsible for handling and, or, and parenthetical expressions.") Currently takes into account support for the LITERAL+ capability. Other capabilities could be tested here." (with-slots (literal-plus) engine - (when literal-plus + (when (and literal-plus + (string-match-p "\n" query)) (setq query (split-string query "\n"))) (cond ((consp query) @@ -1234,8 +1312,7 @@ nil (except that (dd nil yyyy) is not allowed). Massage those numbers into the most recent past occurrence of whichever date elements are present." (pcase-let ((`(,nday ,nmonth ,nyear) - (seq-subseq (decode-time (current-time)) - 3 6)) + (seq-subseq (decode-time) 3 6)) (`(,dday ,dmonth ,dyear) date)) (unless (and dday dmonth dyear) (unless dday (setq dday 1)) @@ -1255,14 +1332,16 @@ elements are present." (setq dmonth 1)))) (format-time-string "%e-%b-%Y" - (apply #'encode-time - (append '(0 0 0) - (list dday dmonth dyear)))))) + (encode-time 0 0 0 dday dmonth dyear)))) (cl-defmethod gnus-search-imap-handle-string ((engine gnus-search-imap) (str string)) (with-slots (literal-plus) engine - (if (multibyte-string-p str) + ;; TODO: Figure out how Exchange IMAP servers actually work. They + ;; do not accept any CHARSET but US-ASCII, but they do report + ;; Literal+ capability. So what do we do? Will quoted strings + ;; always work? + (if (string-match-p "[^[:ascii:]]" str) ;; If LITERAL+ is available, use it and encode string as ;; UTF-8. (if literal-plus @@ -1318,19 +1397,17 @@ This method is common to all indexed search engines. Returns a list of [group article score] vectors." - (save-excursion - (let* ((qstring (gnus-search-make-query-string engine query)) - (program (slot-value engine 'program)) - (buffer (slot-value engine 'proc-buffer)) - (cp-list (gnus-search-indexed-search-command - engine qstring query groups)) - proc exitstatus) - (set-buffer buffer) + (let* ((qstring (gnus-search-make-query-string engine query)) + (program (slot-value engine 'program)) + (buffer (slot-value engine 'proc-buffer)) + (cp-list (gnus-search-indexed-search-command + engine qstring query groups)) + proc exitstatus) + (with-current-buffer buffer (erase-buffer) - (if groups - (message "Doing %s query on %s..." program groups) - (message "Doing %s query..." program)) + (gnus-message 7 "Doing %s query on %s..." program groups) + (gnus-message 7 "Doing %s query..." program)) (setq proc (apply #'start-process (format "search-%s" server) buffer program cp-list)) (while (process-live-p proc) @@ -1346,7 +1423,7 @@ Returns a list of [group article score] vectors." ;; wants it. (when (> gnus-verbose 6) (display-buffer buffer)) - nil)))) + nil)))) (cl-defmethod gnus-search-indexed-parse-output ((engine gnus-search-indexed) server query &optional groups) @@ -1367,18 +1444,27 @@ Returns a list of [group article score] vectors." (when (and f-name (file-readable-p f-name) (null (file-directory-p f-name))) - (setq group - (replace-regexp-in-string - "[/\\]" "." - (replace-regexp-in-string - "/?\\(cur\\|new\\|tmp\\)?/\\'" "" + ;; `expand-file-name' canoncalizes the file name, + ;; specifically collapsing multiple consecutive directory + ;; separators. + (setq f-name (expand-file-name f-name) + group + (delete + "" ; forward slash at root leaves an empty string + (file-name-split (replace-regexp-in-string - "\\`\\." "" - (string-remove-prefix + "\\`\\." "" ; why do we do this? + (string-remove-prefix prefix (file-name-directory f-name)) - nil t) - nil t) - nil t)) + nil t))) + ;; Turn file name segments into a Gnus group name. + group (mapconcat + #'identity + (if (member (car (last group)) + '("new" "tmp" "cur")) + (nbutlast group) + group) + ".")) (setq article (file-name-nondirectory f-name) article ;; TODO: Provide a cleaner way of producing final @@ -1600,19 +1686,26 @@ Namazu provides a little more information, for instance a score." (cp-list (gnus-search-indexed-search-command engine qstring query groups)) thread-ids proc) - (set-buffer proc-buffer) - (erase-buffer) - (setq proc (apply #'start-process (format "search-%s" server) - proc-buffer program cp-list)) - (while (process-live-p proc) - (accept-process-output proc)) - (while (re-search-forward "^thread:\\([^ ]+\\)" (point-max) t) - (push (match-string 1) thread-ids)) + (with-current-buffer proc-buffer + (erase-buffer) + (setq proc (apply #'start-process (format "search-%s" server) + proc-buffer program cp-list)) + (while (process-live-p proc) + (accept-process-output proc)) + (goto-char (point-min)) + (while (re-search-forward + "^thread:\\([^[:space:]\n]+\\)" + (point-max) t) + (cl-pushnew (match-string 1) thread-ids :test #'equal))) (cl-call-next-method engine server - ;; Completely replace the query with our new thread-based one. - (mapconcat (lambda (thrd) (concat "thread:" thrd)) - thread-ids " or ") + ;; If we found threads, completely replace the query with + ;; our new thread-based one. + (if thread-ids + `((query . ,(mapconcat (lambda (thrd) + (concat "thread:" thrd)) + thread-ids " or "))) + query) nil))) (cl-call-next-method engine server query groups))) @@ -1625,16 +1718,16 @@ Namazu provides a little more information, for instance a score." (let ((limit (alist-get 'limit query)) (thread (alist-get 'thread query))) (with-slots (switches config-file) engine - `(,(format "--config=%s" config-file) - "search" - ,(if thread - "--output=threads" - "--output=files") - "--duplicate=1" ; I have found this necessary, I don't know why. - ,@switches - ,(if limit (format "--limit=%d" limit) "") - ,qstring - )))) + (append + (list (format "--config=%s" config-file) + "search" + (if thread + "--output=threads" + "--output=files")) + (unless thread '("--duplicate=1")) + (when limit (list (format "--limit=%d" limit))) + switches + (list qstring))))) ;;; Mairix interface @@ -1807,6 +1900,101 @@ Assume \"size\" key is equal to \"larger\"." (when (alist-get 'thread query) (list "-t")) (list qstring)))) +;;; Mu interface + +(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mu) + (expr list)) + (cl-case (car expr) + (recipient (setf (car expr) 'recip)) + (address (setf (car expr) 'contact)) + (id (setf (car expr) 'msgid)) + (attachment (setf (car expr) 'file))) + (cl-flet () + (cond + ((consp (car expr)) + (format "(%s)" (gnus-search-transform engine expr))) + ;; Explicitly leave out 'date as gnus-search will encode it + ;; first; it is handled later + ((memq (car expr) '(cc c bcc h from f to t subject s body b + maildir m msgid i prio p flag g d + size z embed e file j mime y tag x + list v)) + (format "%s:%s" (car expr) + (if (string-match "\\`\\*" (cdr expr)) + (replace-match "" nil nil (cdr expr)) + (cdr expr)))) + ((eq (car expr) 'mark) + (format "flag:%s" (gnus-search-mu-handle-flag (cdr expr)))) + ((eq (car expr) 'date) + (format "date:%s" (gnus-search-mu-handle-date (cdr expr)))) + ((eq (car expr) 'before) + (format "date:..%s" (gnus-search-mu-handle-date (cdr expr)))) + ((eq (car expr) 'since) + (format "date:%s.." (gnus-search-mu-handle-date (cdr expr)))) + (t (ignore-errors (cl-call-next-method)))))) + +(defun gnus-search-mu-handle-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)) + ;; mu prefers ISO date YYYY-MM-DD HH:MM:SS + (`(,d ,m nil) + (let* ((ct (decode-time)) + (cm (decoded-time-month ct)) + (cy (decoded-time-year ct)) + (y (if (> cm m) + cy + (1- cy)))) + (format "%d-%02d-%02d" y m d))) + (`(nil ,m ,y) + (format "%d-%02d" y m)) + (`(,d ,m ,y) + (format "%d-%02d-%02d" y m d))))) + +(defun gnus-search-mu-handle-flag (flag) + ;; Only change what doesn't match + (cond ((string= flag "flag") + "flagged") + ((string= flag "read") + "seen") + (t + flag))) + +(cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-mu)) + (prog1 + (let ((bol (line-beginning-position)) + (eol (line-end-position))) + (list (buffer-substring-no-properties bol eol) + 100)) + (move-beginning-of-line 2))) + +(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-mu) + (qstring string) + query &optional groups) + (let ((limit (alist-get 'limit query)) + (thread (alist-get 'thread query))) + (with-slots (switches config-directory) engine + `("find" ; command must come first + "--nocolor" ; mu will always give coloured output otherwise + ,(format "--muhome=%s" config-directory) + ,@switches + ,(if thread "-r" "") + ,(if limit (format "--maxnum=%d" limit) "") + ,qstring + ,@(if groups + `("and" "(" + ,@(nbutlast (mapcan (lambda (x) + (list (concat "maildir:/" x) "or")) + groups)) + ")") + "") + "--format=plain" + "--fields=l")))) + ;;; Find-grep interface (cl-defmethod gnus-search-transform-expression ((_engine gnus-search-find-grep) @@ -1836,8 +2024,8 @@ Assume \"size\" key is equal to \"larger\"." (mapcar (lambda (x) (let ((group x) artlist) - (message "Searching %s using find-grep..." - (or group server)) + (gnus-message 7 "Searching %s using find-grep..." + (or group server)) (save-window-excursion (set-buffer buffer) (if (> gnus-verbose 6) @@ -1892,8 +2080,8 @@ Assume \"size\" key is equal to \"larger\"." (vector (gnus-group-full-name group server) art 0) artlist)) (forward-line 1))) - (message "Searching %s using find-grep...done" - (or group server)) + (gnus-message 7 "Searching %s using find-grep...done" + (or group server)) artlist))) grouplist)))) @@ -1926,7 +2114,7 @@ Assume \"size\" key is equal to \"larger\"." (apply #'nnheader-message 4 "Search engine for %s improperly configured: %s" server (cdr err)) - (signal 'gnus-search-config-error err))))) + (signal (car err) (cdr err)))))) (alist-get 'search-group-spec specs)) ;; Some search engines do their own limiting, but some don't, so ;; do it again here. This is bad because, if the user is @@ -1941,9 +2129,9 @@ Assume \"size\" key is equal to \"larger\"." (defun gnus-search-prepare-query (query-spec) "Accept a search query in raw format, and prepare it. QUERY-SPEC is an alist produced by functions such as -`gnus-group-make-search-group', and contains at least a 'query +`gnus-group-make-search-group', and contains at least a `query' key, and possibly some meta keys. This function extracts any -additional meta keys from the 'query string, and parses the +additional meta keys from the `query' string, and parses the remaining string, then adds all that to the top-level spec." (let ((query (alist-get 'query query-spec)) val) |