diff options
Diffstat (limited to 'lisp/gnus/gnus-search.el')
| -rw-r--r-- | lisp/gnus/gnus-search.el | 201 |
1 files changed, 106 insertions, 95 deletions
diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index 21602f825c1..2a8069d400c 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -4,18 +4,20 @@ ;; Author: Eric Abrahamsen <eric@ericabrahamsen.net> -;; This program is free software; you can redistribute it and/or modify +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <http://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. ;;; Commentary: @@ -363,7 +365,7 @@ This variable can also be set per-server." "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 +\"subj\" or even \"su\", though \"s\" is ambiguous between \"subject\" and \"since\". Ambiguous abbreviations will raise an error." @@ -400,7 +402,7 @@ 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 +are implicitly 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 @@ -446,10 +448,10 @@ auto-completion of contact names and addresses for keys like Date values (any key in `gnus-search-date-keys') can be provided in any format that `parse-time-string' can parse (note that this can produce weird results). Dates with missing bits will be -interpreted as the most recent occurance thereof (ie \"march 03\" -is the most recent March 3rd). Lastly, relative specifications -such as 1d (one day ago) are understood. This also accepts w, m, -and y. m is assumed to be 30 days. +interpreted as the most recent occurrence thereof (i.e. \"march +03\" is the most recent March 3rd). Lastly, relative +specifications such as 1d (one day ago) are understood. This +also accepts w, m, and y. m is assumed to be 30 days. This function will accept pretty much anything as input. Its only job is to parse the query into a sexp, and pass that on -- @@ -547,7 +549,7 @@ structure. In the simplest case, they are simply consed together. String KEY is converted to a symbol." - (let (return) + (let () ;; return (cond ((member key gnus-search-date-keys) (when (string= "after" key) @@ -557,7 +559,7 @@ KEY is converted to a symbol." (setq value (gnus-search-query-parse-mark value))) ((string= "message-id" key) (setq key "id"))) - (or return + (or nil ;; return (cons (intern key) value)))) (defun gnus-search-query-parse-date (value &optional rel-date) @@ -570,7 +572,7 @@ 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)) + (let ((value (string-replace "/" "-" value)) (now (append '(0 0 0) (seq-subseq (decode-time (or rel-date (current-time))) @@ -627,25 +629,30 @@ gnus-*-mark marks, and return an appropriate string." mark)) (defun gnus-search-query-expand-key (key) - (cond ((test-completion key gnus-search-expandable-keys) - ;; We're done! - key) - ;; There is more than one possible completion. - ((consp (cdr (completion-all-completions - key gnus-search-expandable-keys #'stringp 0))) - (signal 'gnus-search-parse-error - (list (format "Ambiguous keyword: %s" key)))) - ;; Return KEY, either completed or untouched. - ((car-safe (completion-try-completion - key gnus-search-expandable-keys - #'stringp 0))))) + "Attempt to expand KEY to a full keyword. +Use `gnus-search-expandable-keys' as a completion table; return +KEY directly if it can't be completed. Raise an error if KEY is +ambiguous, meaning that it is a prefix of multiple known +keywords. This means that it's not possible to enter a custom +keyword that happens to be a prefix of a known keyword." + (let ((comp (try-completion key gnus-search-expandable-keys))) + (if (or (eql comp 't) ; Already a key. + (null comp)) ; An unknown key. + key + (if (null (member comp gnus-search-expandable-keys)) + ;; KEY is a prefix of multiple known keywords, and could not + ;; be completed to something unique. + (signal 'gnus-search-parse-error + (list (format "Ambiguous keyword: %s" key))) + ;; We completed to a unique known key. + comp)))) (defun gnus-search-query-return-string (&optional delimited trim) "Return a string from the current buffer. If DELIMITED is non-nil, assume the next character is a delimiter character, and return everything between point and the next -occurance of the delimiter, including the delimiters themselves. -If TRIM is non-nil, do not return the delimiters. Otherwise, +occurrence of the delimiter, including the delimiters themselves. +If TRIM is non-nil, do not return the delimiters. Otherwise, return one word." ;; This function cannot handle nested delimiters, as it's not a ;; proper parser. Ie, you cannot parse "to:bob or (from:bob or @@ -787,7 +794,7 @@ the files in ARTLIST by that search key.") (raw-queries-p :initform (symbol-value 'gnus-search-imap-raw-queries-p))) :documentation - "The base IMAP search engine, using an IMAP server's search capabilites. + "The base IMAP search engine, using an IMAP server's search capabilities. This backend may be subclassed to handle particular IMAP servers' quirks.") @@ -973,7 +980,7 @@ Responsible for handling and, or, and parenthetical expressions.") ;; Most search engines use implicit ANDs. (cl-defmethod gnus-search-transform-expression ((_ gnus-search-engine) - (_expr (eql and))) + (_expr (eql 'and))) nil) ;; Most search engines use explicit infixed ORs. @@ -1080,7 +1087,7 @@ Responsible for handling and, or, and parenthetical expressions.") (cl-defmethod gnus-search-imap-search-command ((engine gnus-search-imap) (query string)) "Create the IMAP search command for QUERY. -Currenly takes into account support for the LITERAL+ capability. +Currently takes into account support for the LITERAL+ capability. Other capabilities could be tested here." (with-slots (literal-plus) engine (when literal-plus @@ -1276,24 +1283,30 @@ elements are present." str))) (defun gnus-search-imap-handle-flag (flag) - "Make sure string FLAG is something IMAP will recognize." - ;; What else? What about the KEYWORD search key? + "Adjust string FLAG to help IMAP recognize it. +If it's one of the RFC3501 flags, make sure it's upcased. +Otherwise, if FLAG starts with a \"$\", treat as a KEYWORD +search. Otherwise, drop the flag." (setq flag (pcase flag ("flag" "flagged") ("read" "seen") ("replied" "answered") (_ flag))) - (if (member flag '("seen" "answered" "deleted" "draft" "flagged")) - (upcase flag) - "")) + (cond + ((member flag '("seen" "answered" "deleted" "draft" "flagged" "recent")) + (upcase flag)) + ((string-prefix-p "$" flag) + (format "KEYWORD %s" flag)) + ;; TODO: Provide a user option to treat *all* marks as a KEYWORDs? + (t ""))) ;;; Methods for the indexed search engines. ;; First, some common methods. -(cl-defgeneric gnus-search-indexed-parse-output (engine server &optional groups) - "Parse the results of ENGINE's query against SERVER in GROUPS. +(cl-defgeneric gnus-search-indexed-parse-output (engine server query &optional groups) + "Parse the results of ENGINE's QUERY against SERVER in GROUPS. Locally-indexed search engines return results as a list of filenames, sometimes with additional information. Returns a list of viable results, in the form of a list of [group article score] @@ -1343,63 +1356,61 @@ Returns a list of [group article score] vectors." (cl-defmethod gnus-search-indexed-parse-output ((engine gnus-search-indexed) server query &optional groups) - (let ((prefix (slot-value engine 'remove-prefix)) - (group-regexp (when groups - (mapconcat - (lambda (x) - (replace-regexp-in-string - ;; Accept any of [.\/] as path separators. - "[.\\/]" "[.\\\\/]" - (gnus-group-real-name x))) - groups "\\|"))) - artlist vectors article group) + (let ((prefix (or (slot-value engine 'remove-prefix) + "")) + (groups (mapcar #'gnus-group-short-name groups)) + artlist article group) (goto-char (point-min)) - (while (not (eobp)) + ;; Prep prefix, we want to at least be removing the root + ;; filesystem separator. + (when (stringp prefix) + (setq prefix (file-name-as-directory + (expand-file-name prefix "/")))) + (while (not (or (eobp) + (looking-at-p + "\\(?:[[:space:]\n]+\\)?Process .+ finished"))) (pcase-let ((`(,f-name ,score) (gnus-search-indexed-extract engine))) - (when (and (file-readable-p f-name) - (null (file-directory-p f-name)) - (or (null groups) - (and (gnus-search-single-p query) - (alist-get 'thread query)) - (string-match-p group-regexp f-name))) - (push (list f-name score) artlist)))) + (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\\)?/\\'" "" + (replace-regexp-in-string + "\\`\\." "" + (string-remove-prefix + prefix (file-name-directory f-name)) + nil t) + nil t) + nil t)) + (setq article (file-name-nondirectory f-name) + article + ;; TODO: Provide a cleaner way of producing final + ;; article numbers for the various backends. + (if (string-match-p "\\`[[:digit:]]+\\'" article) + (string-to-number article) + (nnmaildir-base-name-to-article-number + (substring article 0 (string-search ":" article)) + group (string-remove-prefix "nnmaildir:" server)))) + (when (and (numberp article) + (or (null groups) + (member group groups))) + (push (list f-name article group score) + artlist))))) ;; Are we running an additional grep query? (when-let ((grep-reg (alist-get 'grep query))) (setq artlist (gnus-search-grep-search engine artlist grep-reg))) - ;; Prep prefix. - (when (and prefix (null (string-empty-p prefix))) - (setq prefix (file-name-as-directory (expand-file-name prefix)))) - ;; Turn (file-name score) into [group article score]. - (pcase-dolist (`(,f-name ,score) artlist) - (setq article (file-name-nondirectory f-name) - group (file-name-directory f-name)) - ;; Remove prefix. - (when prefix - (setq group (string-remove-prefix prefix group))) - ;; Break the directory name down until it's something that - ;; (probably) can be used as a group name. - (setq group - (replace-regexp-in-string - "[/\\]" "." - (replace-regexp-in-string - "/?\\(cur\\|new\\|tmp\\)?/\\'" "" - (replace-regexp-in-string - "^[./\\]" "" - group nil t) - nil t) - nil t)) - - (push (vector (gnus-group-full-name group server) - (if (string-match-p "\\`[[:digit:]]+\\'" article) - (string-to-number article) - (nnmaildir-base-name-to-article-number - (substring article 0 (string-match ":" article)) - group (string-remove-prefix "nnmaildir:" server))) - (if (numberp score) - score - (string-to-number score))) - vectors)) - vectors)) + ;; Munge into the list of vectors expected by nnselect. + (mapcar (pcase-lambda (`(,_ ,article ,group ,score)) + (vector + (gnus-group-full-name group server) + article + (if (numberp score) + score + (string-to-number score)))) + artlist))) (cl-defmethod gnus-search-indexed-extract ((_engine gnus-search-indexed)) "Base implementation treats the whole line as a filename, and @@ -1658,7 +1669,7 @@ cross our fingers for the rest of it." Mairix negation requires a \"~\" preceding string search terms, and \"-\" before marks." (let ((next (gnus-search-transform-expression engine (cadr expr)))) - (replace-regexp-in-string + (string-replace ":" (if (eql (caadr expr) 'mark) ":-" @@ -1668,8 +1679,8 @@ and \"-\" before marks." (cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix) (expr (head or))) "Handle Mairix \"or\" statement. -Mairix only accepts \"or\" expressions on homogenous keys. We -cast \"or\" expressions on heterogenous keys as \"and\", which +Mairix only accepts \"or\" expressions on homogeneous keys. We +cast \"or\" expressions on heterogeneous keys as \"and\", which isn't quite right, but it's the best we can do. For date keys, only keep one of the terms." (let ((term1 (caadr expr)) @@ -1852,9 +1863,9 @@ Assume \"size\" key is equal to \"larger\"." group (if (file-directory-p (setq group - (replace-regexp-in-string - "\\." "/" - group nil t))) + (string-replace + "." "/" + group))) group)))))) (unless group (signal 'gnus-search-config-error @@ -2125,7 +2136,7 @@ article came from is also searched." ;; If the value contains spaces, make sure it's ;; quoted. (when (and (memql status '(exact finished)) - (or (string-match-p " " str) + (or (string-search " " str) in-string)) (unless (looking-at-p "\\s\"") (insert "\"")) |