* elsp-sa.el (elmo-spam-register-spam-buffer): Don't specify '--forget'.
[elisp/wanderlust.git] / elmo / elmo-util.el
index 49326f0..7021069 100644 (file)
@@ -38,6 +38,7 @@
 (require 'eword-decode)
 (require 'utf7)
 (require 'poem)
+(require 'emu)
 
 (defmacro elmo-set-buffer-multibyte (flag)
   "Set the multibyte flag of the current buffer to FLAG."
@@ -75,8 +76,6 @@
     (filename newname &optional ok-if-already-exists)
     (copy-file filename newname ok-if-already-exists t)))
 
-(defalias 'elmo-read 'read)
-
 (defmacro elmo-set-work-buf (&rest body)
   "Execute BODY on work buffer.  Work buffer remains."
   (` (save-excursion
@@ -132,7 +131,8 @@ File content is encoded with MIME-CHARSET."
 Directory of the file is created if it doesn't exist.
 File content is encoded with MIME-CHARSET."
   (elmo-set-work-buf
-   (prin1 object (current-buffer))
+   (let (print-length print-level)
+     (prin1 object (current-buffer)))
 ;;;(princ "\n" (current-buffer))
    (elmo-save-buffer filename mime-charset)))
 
@@ -150,7 +150,7 @@ File content is encoded with MIME-CHARSET."
                 (format "%s (%s): " prompt default)
                 (mapcar 'list
                         (append '("AND" "OR"
-                                  "Last" "First"
+                                  "Last" "First" "Flag"
                                   "From" "Subject" "To" "Cc" "Body"
                                   "Since" "Before" "ToCc"
                                   "!From" "!Subject" "!To" "!Cc" "!Body"
@@ -179,6 +179,15 @@ File content is encoded with MIME-CHARSET."
                             elmo-date-descriptions)))
        (concat (downcase field) ":"
                (if (equal value "") default value))))
+     ((string= field "Flag")
+      (setq value (completing-read
+                  (format "Value for '%s': " field)
+                  (mapcar 'list
+                          '("unread" "important" "answered" "digest" "any"))))
+      (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
+                           value)
+       (setq value (prin1-to-string value)))
+      (concat (downcase field) ":" value))
      (t
       (setq value (read-from-minibuffer (format "Value for '%s': " field)))
       (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
@@ -234,7 +243,7 @@ Return value is a cons cell of (STRUCTURE . REST)"
       (goto-char (match-end 0))))
 ;; search-key   ::= [A-Za-z-]+
 ;;                 ;; "since" / "before" / "last" / "first" /
-;;                 ;; "body" / field-name
+;;                 ;; "body" / "mark" / field-name
    ((looking-at "\\(!\\)? *\\([A-Za-z-]+\\) *: *")
     (goto-char (match-end 0))
     (let ((search-key (vector
@@ -269,7 +278,7 @@ Return value is a cons cell of (STRUCTURE . REST)"
 (defun elmo-condition-parse-search-value ()
   (cond
    ((looking-at "\"")
-    (elmo-read (current-buffer)))
+    (read (current-buffer)))
    ((or (looking-at "yesterday") (looking-at "lastweek")
        (looking-at "lastmonth") (looking-at "lastyear")
        (looking-at "[0-9]+ *daysago")
@@ -324,14 +333,17 @@ Return value is a cons cell of (STRUCTURE . REST)"
        (replace-match "\n"))
      (buffer-string))))
 
-(defun elmo-uniq-list (lst)
+(defun elmo-uniq-list (lst &optional delete-function)
   "Distractively uniqfy elements of LST."
+  (setq delete-function (or delete-function #'delete))
   (let ((tmp lst))
-    (while tmp (setq tmp
-                    (setcdr tmp
-                            (and (cdr tmp)
-                                 (delete (car tmp)
-                                         (cdr tmp)))))))
+    (while tmp
+      (setq tmp
+           (setcdr tmp
+                   (and (cdr tmp)
+                        (funcall delete-function
+                                 (car tmp)
+                                 (cdr tmp)))))))
   lst)
 
 (defun elmo-list-insert (list element after)
@@ -417,7 +429,8 @@ Return value is a cons cell of (STRUCTURE . REST)"
   (save-excursion
     (let ((filename (expand-file-name elmo-passwd-alist-file-name
                                      elmo-msgdb-directory))
-         (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*")))
+         (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))
+         print-length print-level)
       (set-buffer tmp-buffer)
       (erase-buffer)
       (prin1 elmo-passwd-alist tmp-buffer)
@@ -746,14 +759,8 @@ the directory becomes empty after deletion."
          ))))
 
 (defun elmo-list-filter (l1 l2)
-  "L1 is filter."
-  (if (eq l1 t)
-      ;; t means filter all.
-      nil
-    (if l1
-       (elmo-delete-if (lambda (x) (not (memq x l1))) l2)
-      ;; filter is nil
-      l2)))
+  "Rerurn a list from L2 in which each element is a member of L1."
+  (elmo-delete-if (lambda (x) (not (memq x l1))) l2))
 
 (defsubst elmo-list-delete-if-smaller (list number)
   (let ((ret-val (copy-sequence list)))
@@ -765,7 +772,7 @@ the directory becomes empty after deletion."
 
 (defun elmo-list-diff (list1 list2 &optional mes)
   (if mes
-      (message mes))
+      (message "%s" mes))
   (let ((clist1 (copy-sequence list1))
        (clist2 (copy-sequence list2)))
     (while list2
@@ -775,7 +782,7 @@ the directory becomes empty after deletion."
       (setq clist2 (delq (car list1) clist2))
       (setq list1 (cdr list1)))
     (if mes
-       (message (concat mes "done.")))
+       (message "%sdone" mes))
     (list clist1 clist2)))
 
 (defun elmo-list-bigger-diff (list1 list2 &optional mes)
@@ -857,11 +864,12 @@ the directory becomes empty after deletion."
           (setq result (search-forward (elmo-filter-value condition)
                                        nil t))))
      (t
-      (let ((fval (std11-field-body (elmo-filter-key condition))))
+      (dolist (fval (elmo-multiple-field-body (elmo-filter-key condition)))
        (if (eq (length fval) 0) (setq fval nil))
        (if fval (setq fval (eword-decode-string fval)))
-       (setq result (and fval (string-match
-                               (elmo-filter-value condition) fval))))))
+       (setq result (or result
+                        (and fval (string-match
+                                   (elmo-filter-value condition) fval)))))))
     (if (eq (elmo-filter-type condition) 'unmatch)
        (setq result (not result)))
     result))
@@ -947,13 +955,14 @@ the directory becomes empty after deletion."
         file (nth 2 condition) number number-list)))))
 
 (defmacro elmo-get-hash-val (string hashtable)
-  `(and (stringp ,string)
-       (let ((sym (intern-soft ,string ,hashtable)))
-         (if (boundp sym)
-             (symbol-value sym)))))
+  (static-if (fboundp 'unintern)
+      `(symbol-value (intern-soft ,string ,hashtable))
+    `(let ((sym (intern-soft ,string ,hashtable)))
+       (and (boundp sym)
+           (symbol-value sym)))))
 
 (defmacro elmo-set-hash-val (string value hashtable)
-  (list 'set (list 'intern string hashtable) value))
+  `(set (intern ,string ,hashtable) ,value))
 
 (defmacro elmo-clear-hash-val (string hashtable)
   (static-if (fboundp 'unintern)
@@ -1218,6 +1227,23 @@ If optional DELETE-FUNCTION is speficied, it is used as delete procedure."
        (when (>= new-rate 100)
          (elmo-progress-clear label))))))
 
+(put 'elmo-with-progress-display 'lisp-indent-function '2)
+(def-edebug-spec elmo-with-progress-display
+  (form (symbolp form &optional form) &rest form))
+
+(defmacro elmo-with-progress-display (condition spec &rest body)
+  "Evaluate BODY with progress gauge if CONDITION is non-nil.
+SPEC is a list as followed (LABEL MAX-VALUE [FORMAT])."
+  (let ((label (car spec))
+       (max-value (cadr spec))
+       (fmt (caddr spec)))
+    `(unwind-protect
+        (progn
+          (when ,condition
+            (elmo-progress-set (quote ,label) ,max-value ,fmt))
+          ,@body)
+       (elmo-progress-clear (quote ,label)))))
+
 (defun elmo-time-expire (before-time diff-time)
   (let* ((current (current-time))
         (rest (when (< (nth 1 current) (nth 1 before-time))
@@ -1233,6 +1259,11 @@ If optional DELETE-FUNCTION is speficied, it is used as delete procedure."
     (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
   (defalias 'elmo-field-body 'std11-field-body))
 
+(defun elmo-unfold-field-body (name)
+  (let ((value (elmo-field-body name)))
+    (and value
+        (std11-unfold-string value))))
+
 (defun elmo-address-quote-specials (word)
   "Make quoted string of WORD if needed."
   (let ((lal (std11-lexical-analyze word)))
@@ -1264,7 +1295,6 @@ But if optional argument AUTO is non-nil, DEFAULT is returned."
     (y-or-n-p prompt)))
 
 (defun elmo-string-member (string slist)
-  "Return t if STRING is a member of the SLIST."
   (catch 'found
     (while slist
       (if (and (stringp (car slist))
@@ -1272,6 +1302,25 @@ But if optional argument AUTO is non-nil, DEFAULT is returned."
          (throw 'found t))
       (setq slist (cdr slist)))))
 
+(static-cond ((fboundp 'member-ignore-case)
+       (defalias 'elmo-string-member-ignore-case 'member-ignore-case))
+      ((fboundp 'compare-strings)
+       (defun elmo-string-member-ignore-case (elt list)
+        "Like `member', but ignores differences in case and text representation.
+ELT must be a string.  Upper-case and lower-case letters are treated as equal.
+Unibyte strings are converted to multibyte for comparison."
+        (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t))))
+          (setq list (cdr list)))
+        list))
+      (t
+       (defun elmo-string-member-ignore-case (elt list)
+        "Like `member', but ignores differences in case and text representation.
+ELT must be a string.  Upper-case and lower-case letters are treated as equal."
+        (let ((str (downcase elt)))
+          (while (and list (not (string= str (downcase (car list)))))
+            (setq list (cdr list)))
+          list))))
+
 (defun elmo-string-match-member (str list &optional case-ignore)
   (let ((case-fold-search case-ignore))
     (catch 'member
@@ -1595,6 +1644,7 @@ If the cache is partial file-cache, TYPE is 'partial."
            (nth (% (/ sum 16) 2) chars)
            (nth (% sum 16) chars))))
 
+;;;
 (defun elmo-file-cache-get-path (msgid &optional section)
   "Get cache path for MSGID.
 If optional argument SECTION is specified, partial cache path is returned."
@@ -1712,9 +1762,10 @@ associated with SECTION."
         (method (completing-read (format "Expire by (%s): "
                                          elmo-cache-expire-default-method)
                                  '(("size" . "size")
-                                   ("age" . "age")))))
-    (if (string= method "")
-       (setq method elmo-cache-expire-default-method))
+                                   ("age" . "age"))
+                                 nil t)))
+    (when (string= method "")
+      (setq method elmo-cache-expire-default-method))
     (funcall (intern (concat "elmo-cache-expire-by-" method)))))
 
 (defun elmo-read-float-value-from-minibuffer (prompt &optional initial)
@@ -1932,6 +1983,64 @@ If ALIST is nil, `elmo-obsolete-variable-alist' is used."
     (elmo-resque-obsolete-variable (cdr pair)
                                   (car pair))))
 
+(defsubst elmo-msgdb-get-last-message-id (string)
+  (if string
+      (save-match-data
+       (let (beg)
+         (elmo-set-work-buf
+          (insert string)
+          (goto-char (point-max))
+          (when (search-backward "<" nil t)
+            (setq beg (point))
+            (if (search-forward ">" nil t)
+                (elmo-replace-in-string
+                 (buffer-substring beg (point)) "\n[ \t]*" ""))))))))
+
+(defun elmo-msgdb-get-message-id-from-buffer ()
+  (let ((msgid (elmo-field-body "message-id")))
+    (if msgid
+       (if (string-match "<\\(.+\\)>$" msgid)
+           msgid
+         (concat "<" msgid ">")) ; Invaild message-id.
+      ;; no message-id, so put dummy msgid.
+      (concat "<" (timezone-make-date-sortable
+                  (elmo-unfold-field-body "date"))
+             (nth 1 (eword-extract-address-components
+                     (or (elmo-field-body "from") "nobody"))) ">"))))
+
+(defsubst elmo-msgdb-insert-file-header (file)
+  "Insert the header of the article."
+  (let ((beg 0)
+       insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
+       insert-file-contents-post-hook
+       format-alist)
+    (when (file-exists-p file)
+      ;; Read until header separator is found.
+      (while (and (eq elmo-msgdb-file-header-chop-length
+                     (nth 1
+                          (insert-file-contents-as-binary
+                           file nil beg
+                           (incf beg elmo-msgdb-file-header-chop-length))))
+                 (prog1 (not (search-forward "\n\n" nil t))
+                   (goto-char (point-max))))))))
+
+;;
+;; overview handling
+;;
+(defun elmo-multiple-field-body (name &optional boundary)
+  (save-excursion
+    (save-restriction
+      (std11-narrow-to-header boundary)
+      (goto-char (point-min))
+      (let ((case-fold-search t)
+           (field-body nil))
+       (while (re-search-forward (concat "^" name ":[ \t]*") nil t)
+         (setq field-body
+               (nconc field-body
+                      (list (buffer-substring-no-properties
+                             (match-end 0) (std11-field-end))))))
+       field-body))))
+
 ;;; Queue.
 (defvar elmo-dop-queue-filename "queue"
   "*Disconnected operation queue is saved in this file.")
@@ -1948,6 +2057,18 @@ If ALIST is nil, `elmo-obsolete-variable-alist' is used."
                     elmo-msgdb-directory)
    elmo-dop-queue))
 
+(if (and (fboundp 'regexp-opt)
+        (not (featurep 'xemacs)))
+    (defalias 'elmo-regexp-opt 'regexp-opt)
+  (defun elmo-regexp-opt (strings &optional paren)
+    "Return a regexp to match a string in STRINGS.
+Each string should be unique in STRINGS and should not contain any regexps,
+quoted or not.  If optional PAREN is non-nil, ensure that the returned regexp
+is enclosed by at least one regexp grouping construct."
+    (let ((open-paren (if paren "\\(" "")) (close-paren (if paren "\\)" "")))
+      (concat open-paren (mapconcat 'regexp-quote strings "\\|")
+             close-paren))))
+
 (require 'product)
 (product-provide (provide 'elmo-util) (require 'elmo-version))