From d249e6bc4a30e54eeee659bde252b39d188207b4 Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen Date: Thu, 1 Jun 2017 22:16:55 +0800 Subject: [PATCH] Restore thread search behavior * lisp/gnus/gnus-search.el (gnus-search-thread): Make this function produce an engine-agnostic search query. (gnus-search-prepare-query): Fix dumb error. (gnus-search-indexed-search-command): Edit to handle the 'thread key. (gnus-search-run-search): In thread searches, have the imap implementation expand Message-Id searches to include the References header. Also, somewhere along the way we lost the `gnus-search-get-active' call. (gnus-search-run-search): For Notmuch, add an :around method on this function, which does a primary search for thread-ids, then passes off to the secondary search for the messages themselves. (gnus-search-transform-expression): Forgot that multiple nested ORs have to be parenthesized for IMAP. * lisp/gnus/nnselect.el (nnselect-request-thread): Alter function to pass in a generic thread search query; no longer calls imap-specific code. --- lisp/gnus/gnus-search.el | 95 +++++++++++++++++++++++++++++++--------- lisp/gnus/nnimap.el | 29 ++++++------ lisp/gnus/nnselect.el | 38 +++++++++++----- 3 files changed, 115 insertions(+), 47 deletions(-) diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el index debd1f82a5a..e799374553c 100644 --- a/lisp/gnus/gnus-search.el +++ b/lisp/gnus/gnus-search.el @@ -1146,6 +1146,7 @@ Responsible for handling and, or, and parenthetical expressions.") (gnus-inhibit-demon t) ;; We're using the message id to look for a single message. (single-search (gnus-search-single-p query)) + (grouplist (or groups (gnus-search-get-active srv))) q-string artlist group) (message "Opening server %s" server) ;; We should only be doing this once, in @@ -1166,7 +1167,16 @@ Responsible for handling and, or, and parenthetical expressions.") (setq q-string (gnus-search-make-query-string engine query)) - (while (and (setq group (pop groups)) + ;; If it's a thread query, make sure that all message-id + ;; searches are also references searches. + (when (alist-get 'thread query) + (setq q-string + (replace-regexp-in-string + "HEADER Message-Id \\([^ )]+\\)" + "(OR HEADER Message-Id \\1 HEADER References \\1)" + q-string))) + + (while (and (setq group (pop grouplist)) (or (null single-search) (null artlist))) (when (nnimap-change-group (gnus-group-short-name group) server) @@ -1237,7 +1247,10 @@ Other capabilities could be tested here." (let ((left (gnus-search-transform-expression engine (nth 1 expr))) (right (gnus-search-transform-expression engine (nth 2 expr)))) (if (and left right) - (format "OR %s %s" left right) + (format "(OR %s %s)" + left (format (if (eq 'or (car-safe (nth 2 expr))) + "(%s)" "%s") + right)) (or left right)))) (cl-defmethod gnus-search-transform-expression ((engine gnus-search-imap) @@ -1315,7 +1328,7 @@ boolean instead." (upcase (symbol-name (car expr))) (gnus-search-imap-handle-string engine (cdr expr)))) ((eq (car expr) 'id) - (format "HEADER Message-ID %s" (cdr expr))) + (format "HEADER Message-ID \"%s\"" (cdr expr))) ;; Treat what can't be handled as a HEADER search. Probably a bad ;; idea. (t (format "%sHEADER %s %s" @@ -1692,22 +1705,58 @@ Namazu provides a little more information, for instance a score." (format "date:%s.." (notmuch-date (cdr expr)))) (t (ignore-errors (cl-call-next-method)))))) +(cl-defmethod gnus-search-run-search :around ((engine gnus-search-notmuch) + server query groups) + "Handle notmuch's thread-search routine." + ;; Notmuch allows for searching threads, but only using its own + ;; thread ids. That means a thread search is a \"double-bounce\": + ;; once to find the relevant thread ids, and again to find the + ;; actual messages. This method performs the first \"bounce\". + (when (alist-get 'thread query) + (with-slots (program proc-buffer) engine + (let* ((qstring + (gnus-search-make-query-string engine query)) + (cp-list (gnus-search-indexed-search-command + engine qstring query groups)) + thread-ids proc) + (set-buffer proc-buffer) + (erase-buffer) + (setq proc (apply #'start-process (format "search-%s" server) + proc-buffer program cp-list)) + (while (process-live-p proc) + (accept-process-output proc)) + (while (re-search-forward "^thread:\\([^ ]+\\)" (point-max) t) + (push (match-string 1) thread-ids)) + ;; All of the following is to make sure that the secondary + ;; search ignores the original search query, and instead uses + ;; our new thread query. + (setf (alist-get 'thread query) nil + (alist-get 'raw query) t + groups nil + (alist-get 'query query) + (mapconcat (lambda (thrd) (concat "thread:" thrd)) + thread-ids " or "))))) + (cl-call-next-method engine server query groups)) + (cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-notmuch) (qstring string) query &optional _groups) ;; Theoretically we could use the GROUPS parameter to pass a ;; --folder switch to notmuch, but I'm not confident of getting the ;; format right. - (let ((limit (alist-get 'limit query))) - (with-slots (switches config-file) engine - `(,(format "--config=%s" config-file) - "search" - "--output=files" - "--duplicate=1" ; I have found this necessary, I don't know why. - ,@switches - ,(if limit (format "--limit=%d" limit) "") - ,qstring - )))) + (let ((limit (alist-get 'limit query)) + (thread (alist-get 'thread query))) + (with-slots (switches config-file) engine + `(,(format "--config=%s" config-file) + "search" + (if thread + "--output=threads" + "--output=files") + "--duplicate=1" ; I have found this necessary, I don't know why. + ,@switches + ,(if limit (format "--limit=%d" limit) "") + ,qstring + )))) ;;; Mairix interface @@ -2086,7 +2135,7 @@ remaining string, then adds all that to the top-level spec." (setf (alist-get (intern (match-string 1 query)) query-spec) ;; This is stupid. (cond - ((eql val 't)) + ((equal val "t")) ((null (zerop (string-to-number val))) (string-to-number val)) (t val))) @@ -2134,7 +2183,6 @@ remaining string, then adds all that to the top-level spec." (nnheader-message 5 "No search engine defined for %s" srv)) inst)) -(autoload 'nnimap-make-thread-query "nnimap") (declare-function gnus-registry-get-id-key "gnus-registry" (id key)) (defun gnus-search-thread (header) @@ -2142,11 +2190,18 @@ remaining string, then adds all that to the top-level spec." 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)))) + (let* ((ids (cons (mail-header-id header) + (split-string + (or (mail-header-references header) + "")))) + (query + (list (cons 'query (mapconcat (lambda (i) + (format "id:%s" i)) + ids " or ")) + (cons 'thread t))) (server (list (list (gnus-method-to-server - (gnus-find-method-for-group gnus-newsgroup-name))))) + (gnus-find-method-for-group gnus-newsgroup-name))))) (registry-group (and (bound-and-true-p gnus-registry-enabled) (car (gnus-registry-get-id-key @@ -2158,8 +2213,8 @@ article came from is also searched." (when registry-server (cl-pushnew (list registry-server) server :test #'equal)) (gnus-group-make-search-group nil (list - (cons 'gnus-search-query-spec query) - (cons 'gnus-search-group-spec server))) + (cons 'search-query-spec query) + (cons 'search-group-spec server))) (gnus-summary-goto-subject (gnus-id-to-article (mail-header-id header))))) (defun gnus-search-get-active (srv) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index 7a51f7f0591..4268fd12c6a 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1819,6 +1819,20 @@ If LIMIT, first try to limit the search to the N last articles." (cdr (assoc "SEARCH" (cdr result)))))) nil t)))))) +(defun nnimap-make-thread-query (header) + (let* ((id (mail-header-id header)) + (refs (split-string + (or (mail-header-references header) + ""))) + (value + (format + "(OR HEADER REFERENCES %S HEADER Message-Id %S)" + id id))) + (dolist (refid refs value) + (setq value (format + "(OR (OR HEADER Message-Id %S HEADER REFERENCES %S) %s)" + refid refid value))))) + (defun nnimap-change-group (group &optional server no-reconnect read-only) "Change group to GROUP if non-nil. If SERVER is set, check that server is connected, otherwise retry @@ -2212,21 +2226,6 @@ Return the server's response to the SELECT or EXAMINE command." group-art)) nnimap-incoming-split-list))) -(defun nnimap-make-thread-query (header) - (let* ((id (mail-header-id header)) - (refs (split-string - (or (mail-header-references header) - ""))) - (value - (format - "(OR HEADER References %S HEADER Message-Id %S)" - id id))) - (dolist (refid refs value) - (setq value (format - "(OR (OR HEADER Message-Id %S HEADER References %S) %s)" - refid refid value))))) - - (provide 'nnimap) ;;; nnimap.el ends here diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 2f2c9dd4c67..d5b6b5bdfb5 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -498,19 +498,27 @@ If this variable is nil, or if the provided function returns nil, (cl-some #'(lambda (x) (when (and x (> x 0)) x)) (gnus-articles-in-thread thread)))))))))) - ;; Check if we are dealing with an imap backend. - (if (eq 'nnimap - (car (gnus-find-method-for-group artgroup))) + ;; Check if search-based thread referral is permitted, and + ;; possible. + (if (and gnus-refer-thread-use-search + (gnus-search-server-to-engine + (gnus-method-to-server + (gnus-find-method-for-group artgroup)))) ;; If so we perform the query, massage the result, and return ;; the new headers back to the caller to incorporate into the ;; current summary buffer. (let* ((group-spec (list (delq nil (list - (or server (gnus-group-server artgroup)) - (unless gnus-refer-thread-use-search - artgroup))))) + (or server (gnus-group-server artgroup)))))) + (ids (cons (mail-header-id header) + (split-string + (or (mail-header-references header) + "")))) (query-spec - (list (cons 'query (nnimap-make-thread-query header)))) + (list (cons 'query (mapconcat (lambda (i) + (format "id:%s" i)) + ids " or ")) + (cons 'thread t))) (last (nnselect-artlist-length gnus-newsgroup-selection)) (first (1+ last)) (new-nnselect-artlist @@ -562,8 +570,8 @@ If this variable is nil, or if the provided function returns nil, group (cons 1 (nnselect-artlist-length gnus-newsgroup-selection)))) headers) - ;; If not an imap backend just warp to the original article - ;; group and punt back to gnus-summary-refer-thread. + ;; If we can't or won't use search, just warp to the original + ;; article group and punt back to gnus-summary-refer-thread. (and (gnus-warp-to-article) (gnus-summary-refer-thread))))) @@ -663,9 +671,15 @@ If this variable is nil, or if the provided function returns nil, The current server will be searched. If the registry is installed, the server that the registry reports the current article came from is also searched." - (let* ((query - (list (cons 'query (nnimap-make-thread-query header)) - (cons 'criteria ""))) + (let* ((ids (cons (mail-header-id header) + (split-string + (or (mail-header-references header) + "")))) + (query + (list (cons 'query (mapconcat (lambda (i) + (format "id:%s" i)) + ids " or ")) + (cons 'thread t))) (server (list (list (gnus-method-to-server (gnus-find-method-for-group gnus-newsgroup-name))))) -- 2.39.5