[Emacs-diffs] scratch/gnus-search d249e6b 2/4: Restore thread search behavior

[Eric Abrahamsen]

branch: scratch/gnus-search
commit d249e6bc4a30e54eeee659bde252b39d188207b4
Author: Eric Abrahamsen <address@hidden>
Commit: Eric Abrahamsen <address@hidden>

    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 debd1f8..e799374 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 7a51f7f..4268fd1 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 2f2c9dd..d5b6b5b 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)))))