diff lisp/mh-e/mh-index.el @ 49578:b35587af8747

Upgraded to MH-E version 7.2. See etc/MH-E-NEWS and lisp/mh-e/ChangeLog for details.

--- a/lisp/mh-e/mh-index.el	Mon Feb 03 16:39:05 2003 +0000
+++ b/lisp/mh-e/mh-index.el	Mon Feb 03 20:55:30 2003 +0000
@@ -40,13 +40,14 @@
 
 ;;; Change Log:
 
-;; $Id: mh-index.el,v 1.2 2003/01/08 23:21:16 wohler Exp $
+;; $Id: mh-index.el,v 1.83 2003/01/27 04:16:47 wohler Exp $
 
 ;;; Code:
 
 (require 'cl)
 (require 'mh-e)
 (require 'mh-mime)
+(require 'mh-pick)
 
 (autoload 'gnus-local-map-property "gnus-util")
 (autoload 'gnus-eval-format "gnus-spec")
@@ -56,15 +57,22 @@
 ;; Support different indexing programs
 (defvar mh-indexer-choices
   '((swish++
-     mh-swish++-binary mh-swish++-execute-search mh-swish++-next-result)
+     mh-swish++-binary mh-swish++-execute-search mh-swish++-next-result
+     mh-swish++-regexp-builder)
     (swish
-     mh-swish-binary mh-swish-execute-search mh-swish-next-result)
+     mh-swish-binary mh-swish-execute-search mh-swish-next-result nil)
+    (mairix
+     mh-mairix-binary mh-mairix-execute-search mh-mairix-next-result
+     mh-mairix-regexp-builder)
     (namazu
-     mh-namazu-binary mh-namazu-execute-search mh-namazu-next-result)
+     mh-namazu-binary mh-namazu-execute-search mh-namazu-next-result nil)
     (glimpse
-     mh-glimpse-binary mh-glimpse-execute-search mh-glimpse-next-result)
+     mh-glimpse-binary mh-glimpse-execute-search mh-glimpse-next-result nil)
+    (pick
+     mh-pick-binary mh-pick-execute-search mh-pick-next-result
+     mh-pick-regexp-builder)
     (grep
-     mh-grep-binary mh-grep-execute-search mh-grep-next-result))
+     mh-grep-binary mh-grep-execute-search mh-grep-next-result nil))
   "List of possible indexer choices.")
 (defvar mh-indexer nil
   "Chosen index program.")
@@ -72,6 +80,8 @@
   "Function which executes the search program.")
 (defvar mh-index-next-result-function nil
   "Function to parse the next line of output.")
+(defvar mh-index-regexp-builder nil
+  "Function used to construct search regexp.")
 
 ;; FIXME: This should be a defcustom...
 (defvar mh-index-folder "+mhe-index"
@@ -254,16 +264,26 @@
   "Given STRING generate a name which is suitable for use as a folder name.
 White space from the beginning and end are removed. All spaces in the name are
 replaced with underscores and all / are replaced with $. If STRING is longer
-than 20 it is truncated too."
+than 20 it is truncated too. STRING could be a list of strings in which case
+they are concatenated to construct the base name."
   (with-temp-buffer
-    (insert string)
+    (if (stringp string)
+        (insert string)
+      (when (car string) (insert (car string)))
+      (dolist (s (cdr string))
+        (insert "_" s)))
+    (setq string (mh-replace-string "-lbrace" " "))
+    (setq string (mh-replace-string "-rbrace" " "))
+    (subst-char-in-region (point-min) (point-max) ?( ?  t)
+    (subst-char-in-region (point-min) (point-max) ?) ?  t)
+    (subst-char-in-region (point-min) (point-max) ?- ?  t)
     (goto-char (point-min))
-    (while (and (not (eobp)) (memq (char-after) '(?  ?\t ?\n ?\r)))
+    (while (and (not (eobp)) (memq (char-after) '(?  ?\t ?\n ?\r ?_)))
       (delete-char 1))
     (goto-char (point-max))
-    (while (and (not (bobp)) (memq (char-before) '(?  ?\t ?\n ?\r)))
+    (while (and (not (bobp)) (memq (char-before) '(?  ?\t ?\n ?\r ?_)))
       (delete-backward-char 1))
-    (subst-char-in-region (point-min) (point-max) ? ?_ t)
+    (subst-char-in-region (point-min) (point-max) ?  ?_ t)
     (subst-char-in-region (point-min) (point-max) ?\t ?_ t)
     (subst-char-in-region (point-min) (point-max) ?\n ?_ t)
     (subst-char-in-region (point-min) (point-max) ?\r ?_ t)
@@ -271,13 +291,16 @@
     (truncate-string-to-width (buffer-substring (point-min) (point-max)) 20)))
 
 ;;;###mh-autoload
-(defun mh-index-search (redo-search-flag folder search-regexp)
+(defun* mh-index-search (redo-search-flag folder search-regexp
+                        &optional window-config)
   "Perform an indexed search in an MH mail folder.
 
 If REDO-SEARCH-FLAG is non-nil and the current folder buffer was generated by a
 index search, then the search is repeated. Otherwise, FOLDER is searched with
 SEARCH-REGEXP and the results are presented in an MH-E folder. If FOLDER is
-\"+\" then mail in all folders are searched.
+\"+\" then mail in all folders are searched. Optional argument WINDOW-CONFIG
+stores the window configuration that will be restored after the user quits the
+folder containing the index search results.
 
 Four indexing programs are supported; if none of these are present, then grep
 is used. This function picks the first program that is available on your
@@ -289,9 +312,16 @@
 
     - `mh-swish++-execute-search'
     - `mh-swish-execute-search'
+    - `mh-mairix-execute-search'
     - `mh-namazu-execute-search'
     - `mh-glimpse-execute-search'
 
+If none of these programs are present then we use pick. If desired grep can be
+used instead. Details about these methods can be found in:
+
+    - `mh-pick-execute-search'
+    - `mh-grep-execute-search'
+
 This and related functions use an X-MHE-Checksum header to cache the MD5
 checksum of a message. This means that already present X-MHE-Checksum headers
 in the incoming email could result in messages not being found. The following
@@ -306,18 +336,28 @@
          (progn
            (unless mh-find-path-run (mh-find-path))
            (or (and current-prefix-arg (car mh-index-previous-search))
-               (mh-prompt-for-folder "Search" "+" nil "all")))
+               (mh-prompt-for-folder "Search" "+" nil "all" t)))
          (progn
            ;; Yes, we do want to call mh-index-choose every time in case the
            ;; user has switched the indexer manually.
            (unless (mh-index-choose) (error "No indexing program found"))
            (or (and current-prefix-arg (cadr mh-index-previous-search))
+               mh-index-regexp-builder
                (read-string (format "%s regexp: "
                                     (upcase-initials
-                                     (symbol-name mh-indexer))))))))
+                                     (symbol-name mh-indexer))))))
+         (if (and (not
+                   (and current-prefix-arg (cadr mh-index-previous-search)))
+                  mh-index-regexp-builder)
+             (current-window-configuration)
+           nil)))
+  (when (symbolp search-regexp)
+    (mh-search-folder folder window-config)
+    (setq mh-searching-function 'mh-index-do-search)
+    (return-from mh-index-search))
   (mh-checksum-choose)
   (let ((result-count 0)
-        (old-window-config mh-previous-window-config)
+        (old-window-config (or window-config mh-previous-window-config))
         (previous-search mh-index-previous-search)
         (index-folder (format "%s/%s" mh-index-folder
                               (mh-index-generate-pretty-name search-regexp))))
@@ -373,7 +413,7 @@
       (mh-recenter nil)
 
       ;; Maintain history
-      (when (and redo-search-flag previous-search)
+      (when (or (and redo-search-flag previous-search) window-config)
         (setq mh-previous-window-config old-window-config))
       (setq mh-index-previous-search (list folder search-regexp))
 
@@ -385,6 +425,123 @@
                      count (> (hash-table-count msg-hash) 0))))))
 
 ;;;###mh-autoload
+(defun mh-index-do-search ()
+  "Construct appropriate regexp and call `mh-index-search'."
+  (interactive)
+  (unless (mh-index-choose) (error "No indexing program found"))
+  (let* ((regexp-list (mh-pick-parse-search-buffer))
+         (pattern (funcall mh-index-regexp-builder regexp-list)))
+    (if pattern
+        (mh-index-search nil mh-current-folder pattern
+                         mh-previous-window-config)
+      (error "No search terms"))))
+
+(defun mh-replace-string (old new)
+  "Replace all occurrences of OLD with NEW in the current buffer."
+  (goto-char (point-min))
+  (while (search-forward old nil t)
+    (replace-match new)))
+
+;;;###mh-autoload
+(defun mh-index-parse-search-regexp (input-string)
+  "Construct parse tree for INPUT-STRING.
+All occurrences of &, |, ! and ~ in INPUT-STRING are replaced by AND, OR and
+NOT as appropriate. Then the resulting string is parsed."
+  (let (input)
+    (with-temp-buffer
+      (insert input-string)
+      (downcase-region (point-min) (point-max))
+      ;; replace tabs
+      (mh-replace-string "\t" " ")
+      ;; synonyms of AND
+      (mh-replace-string "&" " and ")
+      (mh-replace-string " -and " " and ")
+      ;; synonyms of OR
+      (mh-replace-string "|" " or ")
+      (mh-replace-string " -or " " or ")
+      ;; synonyms of NOT
+      (mh-replace-string "!" " not ")
+      (mh-replace-string "~" " not ")
+      (mh-replace-string " -not " " not ")
+      ;; synonyms of left brace
+      (mh-replace-string "(" " ( ")
+      (mh-replace-string " -lbrace " " ( ")
+      ;; synonyms of right brace
+      (mh-replace-string ")" " ) ")
+      (mh-replace-string " -rbrace " " ) ")
+      ;; get the normalized input
+      (setq input (format "( %s )" (buffer-substring (point-min) (point-max)))))
+
+    (let ((tokens (mh-index-add-implicit-ops (split-string input)))
+          (op-stack ())
+          (operand-stack ())
+          oper1)
+      (dolist (token tokens)
+        (cond ((equal token "(") (push 'paren op-stack))
+              ((equal token "not") (push 'not op-stack))
+              ((equal token "or") (push 'or op-stack))
+              ((equal token "and") (push 'and op-stack))
+              ((equal token ")")
+               (multiple-value-setq (op-stack operand-stack)
+                 (mh-index-evaluate op-stack operand-stack))
+               (when (eq (car op-stack) 'not)
+                 (pop op-stack)
+                 (push `(not ,(pop operand-stack)) operand-stack))
+               (when (eq (car op-stack) 'and)
+                 (pop op-stack)
+                 (setq oper1 (pop operand-stack))
+                 (push `(and ,(pop operand-stack) ,oper1) operand-stack)))
+              ((eq (car op-stack) 'not)
+               (pop op-stack)
+               (push `(not ,token) operand-stack)
+               (when (eq (car op-stack) 'and)
+                 (pop op-stack)
+                 (setq oper1 (pop operand-stack))
+                 (push `(and ,(pop operand-stack) ,oper1) operand-stack)))
+              ((eq (car op-stack) 'and)
+               (pop op-stack)
+               (push `(and ,(pop operand-stack) ,token) operand-stack))
+              (t (push token operand-stack))))
+      (prog1 (pop operand-stack)
+        (when (or op-stack operand-stack)
+          (error "Invalid regexp: %s" input))))))
+
+(defun mh-index-add-implicit-ops (tokens)
+  "Add implicit operators in the list TOKENS."
+  (let ((result ())
+        (literal-seen nil)
+        current)
+    (while tokens
+      (setq current (pop tokens))
+      (cond ((or (equal current ")") (equal current "and") (equal current "or"))
+             (setq literal-seen nil)
+             (push current result))
+            ((and literal-seen
+                  (push "and" result)
+                  (setq literal-seen nil)
+                  nil))
+            (t
+             (push current result)
+             (unless (or (equal current "(") (equal current "not"))
+               (setq literal-seen t)))))
+    (nreverse result)))
+
+(defun mh-index-evaluate (op-stack operand-stack)
+  "Read expression till starting paren based on OP-STACK and OPERAND-STACK."
+  (block mh-index-evaluate
+    (let (op oper1)
+      (while op-stack
+        (setq op (pop op-stack))
+        (cond ((eq op 'paren)
+               (return-from mh-index-evaluate (values op-stack operand-stack)))
+              ((eq op 'not)
+               (push `(not ,(pop operand-stack)) operand-stack))
+              ((or (eq op 'and) (eq op 'or))
+               (setq oper1 (pop operand-stack))
+               (push `(,op ,(pop operand-stack) ,oper1) operand-stack))))
+      (error "Ran out of tokens"))))
+
+;;;###mh-autoload
 (defun mh-index-next-folder (&optional backward-flag)
   "Jump to the next folder marker.
 The function is only applicable to folders displaying index search results.
@@ -446,9 +603,9 @@
                    (setq chosen-name new-name)
                    (return-from unique-name)))))
     (mh-exec-cmd-quiet nil "folder" "-create" "-fast" chosen-name)
+    (mh-remove-from-sub-folders-cache chosen-name)
     (when (boundp 'mh-speed-folder-map)
       (mh-speed-add-folder chosen-name))
-    (push (list chosen-name) mh-folder-list)
     chosen-name))
 
 ;;;###mh-autoload
@@ -476,6 +633,9 @@
   (let ((cur-msg (mh-get-msg-num nil))
         (old-buffer-modified-flag (buffer-modified-p))
         (buffer-read-only nil))
+    (while (and (not cur-msg) (not (eobp)))
+      (forward-line)
+      (setq cur-msg (mh-get-msg-num nil)))
     (goto-char (point-min))
     (while (not (eobp))
       (if (or (char-equal (char-after) ?+) (char-equal (char-after) 10))
@@ -620,6 +780,43 @@
 
 
 
+;; Pick interface
+
+(defvar mh-index-pick-folder)
+(defvar mh-pick-binary "pick")
+
+(defun mh-pick-execute-search (folder-path search-regexp)
+  "Execute pick.
+
+Unlike the other index search programs \"pick\" only searches messages present
+in the folder itself and does not descend into any sub-folders that may be
+present.
+
+FOLDER-PATH is the directory containing the mails to be searched and
+SEARCH-REGEXP is the pattern that pick gets."
+  (set-buffer (get-buffer-create mh-index-temp-buffer))
+  (erase-buffer)
+  (setq mh-index-pick-folder
+        (concat "+" (substring folder-path (length mh-user-path))))
+  (apply #'call-process (expand-file-name "pick" mh-progs) nil '(t nil) nil
+         mh-index-pick-folder "-list" search-regexp)
+  (goto-char (point-min)))
+
+(defun mh-pick-next-result ()
+  "Return the next pick search result."
+  (prog1 (block nil
+           (when (eobp) (return nil))
+           (unless (re-search-forward "^[1-9][0-9]*$" (line-end-position) t)
+             (return 'error))
+           (list mh-index-pick-folder
+                 (car (read-from-string (buffer-substring-no-properties
+                                         (line-beginning-position)
+                                         (line-end-position))))
+                 nil))
+    (forward-line)))
+
+
+
 ;; Grep interface
 
 (defvar mh-grep-binary (executable-find "grep"))
@@ -669,6 +866,140 @@
 
 
 
+;; Mairix interface
+
+(defvar mh-mairix-binary (executable-find "mairix"))
+(defvar mh-mairix-directory ".mairix")
+(defvar mh-mairix-folder nil)
+
+(defun mh-mairix-execute-search (folder-path search-regexp-list)
+  "Execute mairix and read the results.
+
+In the examples below replace /home/user/Mail with the path to your MH
+directory.
+
+First create the directory /home/user/Mail/.mairix. Then create the file
+/home/user/Mail/.mairix/config with the following contents:
+
+   # This should contain the same thing as your `mh-user-path'
+   base=/home/user/Mail
+   
+   # List of folders that should be indexed. 3 dots at the end means there are
+   # subfolders within the folder
+   mh_folders=archive...:inbox:drafts:news:sent:trash
+   
+   vfolder_format=raw
+   database=/home/user/Mail/mairix/database
+
+Use the following command line to generate the mairix index. Run this daily
+from cron:
+
+    mairix -f /home/user/Mail/.mairix/config
+
+FOLDER-PATH is the directory in which SEARCH-REGEXP-LIST is used to search."
+  (set-buffer (get-buffer-create mh-index-temp-buffer))
+  (erase-buffer)
+  (unless mh-mairix-binary
+    (error "Set mh-mairix-binary appropriately"))
+  (apply #'call-process mh-mairix-binary nil '(t nil) nil
+         "-f" (format "%s%s/config" mh-user-path mh-mairix-directory)
+         search-regexp-list)
+  (goto-char (point-min))
+  (setq mh-mairix-folder
+        (let ((last-char (substring folder-path (1- (length folder-path)))))
+          (if (equal last-char "/")
+              folder-path
+            (format "%s/" folder-path)))))
+
+(defun mh-mairix-next-result ()
+  "Return next result from mairix output."
+  (prog1
+      (block nil
+        (when (or (eobp) (and (bolp) (eolp)))
+          (return nil))
+        (unless (eq (char-after) ?/)
+          (return error))
+        (let ((start (point))
+              end msg-start)
+          (setq end (line-end-position))
+          (unless (search-forward mh-mairix-folder end t)
+            (return 'error))
+          (goto-char (match-beginning 0))
+          (unless (equal (point) start)
+            (return 'error))
+          (goto-char end)
+          (unless (search-backward "/" start t)
+            (return 'error))
+          (setq msg-start (1+ (point)))
+          (goto-char start)
+          (unless (search-forward mh-user-path end t)
+            (return 'error))
+          (list (format "+%s" (buffer-substring-no-properties
+                               (point) (1- msg-start)))
+                (car (read-from-string
+                      (buffer-substring-no-properties msg-start end)))
+                ())))
+    (forward-line)))
+
+(defun mh-mairix-regexp-builder (regexp-list)
+  "Generate query for mairix.
+REGEXP-LIST is an alist of fields and values."
+  (let ((result ()))
+    (dolist (pair regexp-list)
+      (when (cdr pair)
+        (push
+         (concat
+          (cond ((eq (car pair) 'to) "t:")
+                ((eq (car pair) 'from) "f:")
+                ((eq (car pair) 'cc) "c:")
+                ((eq (car pair) 'subject) "s:")
+                ((eq (car pair) 'date) "d:")
+                (t ""))
+          (let ((sop (cdr (mh-mairix-convert-to-sop* (cdr pair))))
+                (final ""))
+            (dolist (conjunct sop)
+              (let ((expr-list (cdr conjunct))
+                    (expr-string ""))
+                (dolist (e expr-list)
+                  (setq expr-string (concat expr-string "+"
+                                            (if (atom e) "" "~")
+                                            (if (atom e) e (cadr e)))))
+                (setq final (concat final "," (substring expr-string 1)))))
+            (substring final 1)))
+         result)))
+    result))
+
+(defun mh-mairix-convert-to-sop* (expr)
+  "Convert EXPR to sum of product form."
+  (cond ((atom expr) `(or (and ,expr)))
+        ((eq (car expr) 'or)
+         (cons 'or
+               (loop for e in (mapcar #'mh-mairix-convert-to-sop* (cdr expr))
+                     append (cdr e))))
+        ((eq (car expr) 'and)
+         (let ((conjuncts (mapcar #'mh-mairix-convert-to-sop* (cdr expr)))
+               result next-factor)
+           (setq result (pop conjuncts))
+           (while conjuncts
+             (setq next-factor (pop conjuncts))
+             (setq result (let ((res ()))
+                            (dolist (t1 (cdr result))
+                              (dolist (t2 (cdr next-factor))
+                                (push `(and ,@(cdr t1) ,@(cdr t2)) res)))
+                            (cons 'or res))))
+           result))
+        ((atom (cadr expr)) `(or (and ,expr)))
+        ((eq (caadr expr) 'not) (mh-mairix-convert-to-sop* (cadadr expr)))
+        ((eq (caadr expr) 'and) (mh-mairix-convert-to-sop*
+                                 `(or ,@(mapcar #'(lambda (x) `(not ,x))
+                                                (cdadr expr)))))
+        ((eq (caadr expr) 'or) (mh-mairix-convert-to-sop*
+                                `(and ,@(mapcar #'(lambda (x) `(not ,x))
+                                                (cdadr expr)))))
+        (t (error "Unreachable: %s" expr))))
+
+
+
 ;; Swish interface
 
 (defvar mh-swish-binary (executable-find "swish-e"))
@@ -704,7 +1035,7 @@
     FileRules pathname contains /home/user/Mail/.swish
     FileRules pathname contains /home/user/Mail/mhe-index
     FileRules filename is index
-    FileRules filename is \..*
+    FileRules filename is \\..*
     FileRules filename is #.*
     FileRules filename is ,.*
     FileRules filename is .*~
@@ -829,6 +1160,29 @@
 
 (defalias 'mh-swish++-next-result 'mh-swish-next-result)
 
+(defun mh-swish++-regexp-builder (regexp-list)
+  "Generate query for swish++.
+REGEXP-LIST is an alist of fields and values."
+  (let ((regexp "") meta)
+    (dolist (elem regexp-list)
+      (when (cdr elem)
+        (setq regexp (concat regexp " and "
+                             (if (car elem) "(" "")
+                             (if (car elem) (symbol-name (car elem)) "")
+                             (if (car elem) " = " "")
+                             (mh-swish++-print-regexp (cdr elem))
+                             (if (car elem) ")" "")))))
+    (substring regexp 4)))
+
+(defun mh-swish++-print-regexp (expr)
+  "Return infix expression corresponding to EXPR."
+  (cond ((atom expr) (format "%s" expr))
+        ((eq (car expr) 'not)
+         (format "(not %s)" (mh-swish++-print-regexp (cadr expr))))
+        (t (format "(%s %s %s)" (mh-swish++-print-regexp (cadr expr))
+                   (symbol-name (car expr))
+                   (mh-swish++-print-regexp (caddr expr))))))
+
 
 
 ;; Namazu interface
@@ -931,8 +1285,9 @@
                (executable (symbol-value (cadr current))))
           (when executable
             (setq mh-indexer (car current))
-            (setq mh-index-execute-search-function (caddr current))
-            (setq mh-index-next-result-function (cadddr current))
+            (setq mh-index-execute-search-function (nth 2 current))
+            (setq mh-index-next-result-function (nth 3 current))
+            (setq mh-index-regexp-builder (nth 4 current))
             (return mh-indexer))))
       nil)))