From: Eric Abrahamsen <eric@ericabrahamsen.net>
Date: Mon, 1 May 2017 20:57:46 +0000 (-0700)
Subject: Add Mairix search engine
X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=fcf327bcdce948795dd8faa6ecdeb281ca4c5cf5;p=emacs.git

Add Mairix search engine
---

diff --git a/lisp/gnus/gnus-search.el b/lisp/gnus/gnus-search.el
index 942a9bd6933..727892643ca 100644
--- a/lisp/gnus/gnus-search.el
+++ b/lisp/gnus/gnus-search.el
@@ -313,6 +313,60 @@ This variable can also be set per-server."
   :type 'boolean
   :group 'gnus-search)
 
+(defcustom gnus-search-mairix-program "mairix"
+  "Name of mairix search executable.
+
+This variable can also be set per-server."
+  :version "26.3"
+  :type 'string
+  :group 'gnus-search)
+
+(defcustom gnus-search-mairix-configuration-file
+  (expand-file-name "~/.mairixrc")
+  "Configuration file for mairix.
+
+This variable can also be set per-server."
+  :version "26.3"
+  :type 'file
+  :group 'gnus-search)
+
+(defcustom gnus-search-mairix-additional-switches '()
+  "A list of strings, to be given as additional arguments to mairix.
+
+Note that this should be a list.  I.e., do NOT use the following:
+    (setq gnus-search-mairix-additional-switches \"-i -w\") ; wrong
+Instead, use this:
+    (setq gnu-search-mairix-additional-switches \\='(\"-i\" \"-w\"))
+
+This variable can also be set per-server."
+  :version "26.3"
+  :type '(repeat string)
+  :group 'gnus-search)
+
+(defcustom gnus-search-mairix-remove-prefix (concat (getenv "HOME") "/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.
+
+This variable can also be set per-server."
+  :version "26.3"
+  :type 'regexp
+  :group 'gnus-search)
+
+(defcustom gnus-search-mairix-raw-queries-p nil
+  "If t, all Mairix engines will only accept raw search query
+  strings."
+  :version "26.3"
+  :type 'boolean
+  :group 'gnus-search)
+
+(defcustom gnus-search-imap-raw-queries-p nil
+  "If t, all IMAP engines will only accept raw search query
+  strings."
+  :version "26.3"
+  :type 'boolean
+  :group 'gnus-search)
+
 ;; Options for search language parsing.
 
 (defcustom gnus-search-expandable-keys
@@ -1638,6 +1692,182 @@ absolute filepaths to standard out."
 	    (gnus-search-add-result dirnam artno "" prefix server artlist)))))
     artlist))
 
+;;; Mairix interface
+
+;; See the Gnus manual for why mairix searching is a bit weird.
+
+(cl-defmethod gnus-search-transform ((engine gnus-search-mairix)
+				     (query list))
+  "Transform QUERY for a Mairix engine.
+
+Because Mairix doesn't accept parenthesized expressions, nor
+\"or\" statements between different keys, results may differ from
+other engines.  We unpeel parenthesized expressions, and just
+cross our fingers for the rest of it."
+  (let (clauses)
+    (mapc
+     (lambda (item)
+       (when-let ((expr (if (consp (car-safe item))
+			    (gnus-search-transform engine item)
+			  (gnus-search-transform-expression engine item))))
+	 (push expr clauses)))
+     query)
+    (mapconcat #'identity (reverse clauses) " ")))
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix)
+						(expr (head not)))
+  "Transform Mairix \"not\".
+
+Mairix negation requires a \"~\" preceding string search terms,
+and \"-\" before marks."
+  (let ((next (gnus-search-transform-expression engine (cadr expr))))
+    (replace-regexp-in-string
+     ":"
+     (if (eql (caadr expr) 'mark)
+	 ":-"
+       ":~")
+     next)))
+
+(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
+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))
+	(term2 (caaddr expr))
+	(val1 (gnus-search-transform-expression engine (nth 1 expr)))
+	(val2 (gnus-search-transform-expression engine (nth 2 expr))))
+    (cond
+     ((or (listp term1) (listp term2))
+      (concat val1 " " val2))
+     ((and (member (symbol-name term1) gnus-search-date-keys)
+	   (member (symbol-name term2) gnus-search-date-keys))
+      (or val1 val2))
+     ((eql term1 term2)
+      (if (and val1 val2)
+	  (format "%s/%s"
+		  val1
+		  (nth 1 (split-string val2 ":")))
+	(or val1 val2)))
+     (t (concat val1 " " val2)))))
+
+
+(cl-defmethod gnus-search-transform-expression ((_ gnus-search-mairix)
+						(expr (head mark)))
+  (gnus-search-mairix-handle-mark (cdr expr)))
+
+(cl-defmethod gnus-search-transform-expression ((engine gnus-search-mairix)
+						(expr list))
+  (let ((key (cl-case (car expr)
+	       (sender "f")
+	       (from "f")
+	       (to "t")
+	       (cc "c")
+	       (subject "s")
+	       (id "m")
+	       (body "b")
+	       (address "a")
+	       (recipient "tc")
+	       (text "bs")
+	       (attachment "n")
+	       (t nil))))
+    (cond
+     ((consp (car expr))
+      (gnus-search-transform engine expr))
+     ((member (symbol-name (car expr)) gnus-search-date-keys)
+      (gnus-search-mairix-handle-date expr))
+     ((memq (car expr) '(size smaller larger))
+      (gnus-search-mairix-handle-size expr))
+     ;; Drop regular expressions.
+     ((string-match-p "\\`/" (cdr expr))
+      nil)
+     ;; Turn parenthesized phrases into multiple word terms.  Again,
+     ;; this isn't quite what the user is asking for, but better to
+     ;; return false positives.
+     ((and key (string-match-p "[[:blank:]]" (cdr expr)))
+      (mapconcat
+       (lambda (s) (format "%s:%s" key s))
+       (split-string (gnus-search-mairix-treat-string
+		      (cdr expr)))
+       " "))
+     (key (format "%s:%s" key
+		  (gnus-search-mairix-treat-string
+		   (cdr expr))))
+     (t nil))))
+
+(defun gnus-search-mairix-treat-string (str)
+  "Treat string for wildcards.
+
+Mairix accepts trailing wildcards, but not leading.  Also remove
+double quotes."
+  (replace-regexp-in-string
+   "\\`\\*\\|\"" ""
+   (replace-regexp-in-string "\\*\\'" "=" str)))
+
+(defun gnus-search-mairix-handle-size (expr)
+  "Format a mairix size search.
+
+Assume \"size\" key is equal to \"larger\"."
+  (format
+   (if (eql (car expr) 'smaller)
+       "z:-%s"
+     "z:%s-")
+   (cdr expr)))
+
+(defun gnus-search-mairix-handle-mark (expr)
+  "Format a mairix mark search."
+  (let ((mark
+	 (pcase (cdr expr)
+	   ("flag" "f")
+	   ("read" "s")
+	   ("seen" "s")
+	   ("replied" "r")
+	   (_ nil))))
+    (when mark
+      (format "F:%s" mark))))
+
+(defun gnus-search-mairix-handle-date (expr)
+  (let ((str
+	 (pcase (cdr expr)
+	   (`(nil ,m nil)
+	    (substring
+	     (nth (1- m) gnus-english-month-names)
+	     0 3))
+	   (`(nil nil ,y)
+	    (number-to-string y))
+	   (`(,d ,m nil)
+	    (format "%s%02d"
+		    (substring
+		     (nth (1- m) gnus-english-month-names)
+		     0 3)
+		    d))
+	   (`(nil ,m ,y)
+	    (format "%d%s"
+		    y (substring
+		       (nth (1- m) gnus-english-month-names)
+		       0 3)))
+	   (`(,d ,m ,y)
+	    (format "%d%02d%02d" y m d)))))
+    (format
+     (pcase (car expr)
+       ('date "d:%s")
+       ('since "d:%s-")
+       ('after "d:%s-")
+       ('before "d:-%s"))
+     str)))
+
+(cl-defmethod gnus-search-indexed-search-command ((engine gnus-search-mairix)
+						  (qstring string)
+						  query &optional _groups)
+  (with-slots (switches config-file) engine
+    (nconc `("--rcfile" ,config-file "-r")
+	   switches
+	   (when (alist-get 'thread query) (list "-t"))
+	   (list qstring))))
+
 ;;; Find-grep interface
 
 (cl-defmethod gnus-search-run-search ((engine gnus-search-find-grep)