X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-util.el;h=5a7a1bcb17f2bfac7bd0671e1d922f5e6e49f5a8;hb=db01fedca6f61f632720316b337f8d16eb76b10c;hp=dbd4a5e7b2f56a66b0f29fc8b47d5b5211fe54e3;hpb=ac6e0d92fed22e59b3d745eb85aa5e02293949c7;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-util.el b/elmo/elmo-util.el index dbd4a5e..5a7a1bc 100644 --- a/elmo/elmo-util.el +++ b/elmo/elmo-util.el @@ -1,4 +1,4 @@ -;;; elmo-util.el -- Utilities for Elmo. +;;; elmo-util.el --- Utilities for ELMO. ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi @@ -24,10 +24,10 @@ ;; ;;; Commentary: -;; +;; ;;; Code: -;; +;; (eval-when-compile (require 'cl)) (require 'elmo-vars) @@ -38,17 +38,18 @@ (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." (cond ((boundp 'MULE) - (list 'setq 'mc-flag flag)) - ((featurep 'xemacs) - flag) - ((and (boundp 'emacs-major-version) (>= emacs-major-version 20)) - (list 'set-buffer-multibyte flag)) - (t - flag))) + (list 'setq 'mc-flag flag)) + ((featurep 'xemacs) + flag) + ((and (boundp 'emacs-major-version) (>= emacs-major-version 20)) + (list 'set-buffer-multibyte flag)) + (t + flag))) (defvar elmo-work-buf-name " *elmo work*") (defvar elmo-temp-buf-name " *elmo temp*") @@ -75,14 +76,6 @@ (filename newname &optional ok-if-already-exists) (copy-file filename newname ok-if-already-exists t))) -;; Nemacs's `read' is different. -(static-if (fboundp 'nemacs-version) - (defun elmo-read (obj) - (prog1 (read obj) - (if (bufferp obj) - (or (bobp) (forward-char -1))))) - (defalias 'elmo-read 'read)) - (defmacro elmo-set-work-buf (&rest body) "Execute BODY on work buffer. Work buffer remains." (` (save-excursion @@ -131,14 +124,15 @@ File content is encoded with MIME-CHARSET." (encode-mime-charset-region (point-min) (point-max) mime-charset)) (as-binary-output-file (write-region (point-min) (point-max) filename nil 'no-msg))) - (message (format "%s is not writable." filename))))) + (message "%s is not writable." filename)))) (defun elmo-object-save (filename object &optional mime-charset) "Save OBJECT to the file specified by FILENAME. 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))) @@ -156,12 +150,12 @@ 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" "!Since" "!Before" "!ToCc") - elmo-msgdb-extra-fields)) nil t)) + elmo-msgdb-extra-fields)))) value) (setq field (if (string= field "") (setq field default) @@ -176,12 +170,24 @@ File content is encoded with MIME-CHARSET." (concat field "(2) Search by") default) ")")) ((string-match "Since\\|Before" field) - (concat (downcase field) ":" - (completing-read (format "Value for '%s': " field) - (mapcar (function - (lambda (x) - (list (format "%s" (car x))))) - elmo-date-descriptions)))) + (let ((default (format-time-string "%Y-%m-%d"))) + (setq value (completing-read + (format "Value for '%s' [%s]: " field default) + (mapcar (function + (lambda (x) + (list (format "%s" (car x))))) + 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 "$") @@ -206,7 +212,7 @@ Return value is a cons cell of (STRUCTURE . REST)" (elmo-condition-parse-error))) ;; or-expr ::= and-expr / -;; and-expr "|" or-expr +;; and-expr "|" or-expr (defun elmo-condition-parse-or-expr () (let ((left (elmo-condition-parse-and-expr))) (if (looking-at "| *") @@ -237,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 @@ -260,6 +266,7 @@ Return value is a cons cell of (STRUCTURE . REST)" ;; time ::= "yesterday" / "lastweek" / "lastmonth" / "lastyear" / ;; number SPACE* "daysago" / ;; number "-" month "-" number ; ex. 10-May-2000 +;; number "-" number "-" number ; ex. 2000-05-10 ;; number ::= [0-9]+ ;; month ::= "Jan" / "Feb" / "Mar" / "Apr" / "May" / "Jun" / ;; "Jul" / "Aug" / "Sep" / "Oct" / "Nov" / "Dec" @@ -271,11 +278,12 @@ 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") (looking-at "[0-9]+-[A-Za-z]+-[0-9]+") + (looking-at "[0-9]+-[0-9]+-[0-9]+") (looking-at "[0-9]+") (looking-at elmo-condition-atom-regexp)) (prog1 (elmo-match-buffer 0) @@ -325,33 +333,28 @@ 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) - "Insert an ELEMENT to the LIST, just after AFTER." - (let ((li list) - (curn 0) - p pn) - (while li - (if (eq (car li) after) - (setq p li pn curn li nil) - (incf curn)) - (setq li (cdr li))) - (if pn - (setcdr (nthcdr pn list) (cons element (cdr p))) + (let* ((match (memq after list)) + (rest (and match (cdr (memq after list))))) + (if match + (progn + (setcdr match (list element)) + (nconc list rest)) (nconc list (list element))))) -(defun elmo-string-partial-p (string) - (and (stringp string) (string-match "message/partial" string))) - (defun elmo-get-file-string (filename &optional remove-final-newline) (elmo-set-work-buf (let (insert-file-contents-pre-hook ; To avoid autoconv-xmas... @@ -396,34 +399,38 @@ Return value is a cons cell of (STRUCTURE . REST)" (defun elmo-passwd-alist-load () (save-excursion (let ((filename (expand-file-name elmo-passwd-alist-file-name - elmo-msgdb-dir)) - (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*")) - insert-file-contents-pre-hook ; To avoid autoconv-xmas... - insert-file-contents-post-hook - ret-val) + elmo-msgdb-directory)) + (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*")) + insert-file-contents-pre-hook ; To avoid autoconv-xmas... + insert-file-contents-post-hook + ret-val) (if (not (file-readable-p filename)) - () - (set-buffer tmp-buffer) - (insert-file-contents filename) - (setq ret-val - (condition-case nil - (read (current-buffer)) - (error nil nil)))) + () + (set-buffer tmp-buffer) + (insert-file-contents filename) + (setq ret-val + (condition-case nil + (read (current-buffer)) + (error nil nil)))) (kill-buffer tmp-buffer) ret-val))) (defun elmo-passwd-alist-clear () "Clear password cache." (interactive) + (dolist (pair elmo-passwd-alist) + (when (stringp (cdr-safe pair)) + (fillarray (cdr pair) 0))) (setq elmo-passwd-alist nil)) - + (defun elmo-passwd-alist-save () "Save password into file." (interactive) (save-excursion (let ((filename (expand-file-name elmo-passwd-alist-file-name - elmo-msgdb-dir)) - (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))) + elmo-msgdb-directory)) + (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) @@ -432,11 +439,11 @@ Return value is a cons cell of (STRUCTURE . REST)" ;;; (not (equal 384 (file-modes filename)))) ;;; (error "%s is not safe.chmod 600 %s!" filename filename)) (if (file-writable-p filename) - (progn - (write-region (point-min) (point-max) - filename nil 'no-msg) - (set-file-modes filename 384)) - (message (format "%s is not writable." filename))) + (progn + (write-region (point-min) (point-max) + filename nil 'no-msg) + (set-file-modes filename 384)) + (message "%s is not writable." filename)) (kill-buffer tmp-buffer)))) (defun elmo-get-passwd (key) @@ -461,28 +468,27 @@ Return value is a cons cell of (STRUCTURE . REST)" (defun elmo-remove-passwd (key) "Remove password from password pool (for failure)." (let (pass-cons) - (if (setq pass-cons (assoc key elmo-passwd-alist)) - (progn - (unwind-protect - (fillarray (cdr pass-cons) 0)) - (setq elmo-passwd-alist - (delete pass-cons elmo-passwd-alist)))))) + (while (setq pass-cons (assoc key elmo-passwd-alist)) + (unwind-protect + (fillarray (cdr pass-cons) 0) + (setq elmo-passwd-alist + (delete pass-cons elmo-passwd-alist)))))) (defmacro elmo-read-char-exclusive () (cond ((featurep 'xemacs) - '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?) - (left . ?\C-h)))) - event key) - (while (not - (and - (key-press-event-p (setq event (next-command-event))) - (setq key (or (event-to-character event) - (cdr (assq (event-key event) table))))))) - key)) - ((fboundp 'read-char-exclusive) - '(read-char-exclusive)) - (t - '(read-char)))) + '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?) + (left . ?\C-h)))) + event key) + (while (not + (and + (key-press-event-p (setq event (next-command-event))) + (setq key (or (event-to-character event) + (cdr (assq (event-key event) table))))))) + key)) + ((fboundp 'read-char-exclusive) + '(read-char-exclusive)) + (t + '(read-char)))) (defun elmo-read-passwd (prompt &optional stars) "Read a single line of text from user without echoing, and return it." @@ -549,12 +555,12 @@ Return value is a cons cell of (STRUCTURE . REST)" (setq tlist (cdr tlist))) (setq str (concat str ")"))) - (setq str + (setq str (if (symbolp tlist) (symbol-name tlist) tlist))) str)) - + (defun elmo-plug-on-by-servers (alist &optional servers) (let ((server-list (or servers elmo-plug-on-servers))) @@ -689,7 +695,8 @@ Return value is a cons cell of (STRUCTURE . REST)" (setq result (+ result (or (elmo-disk-usage (car files)) 0))) (setq files (cdr files))) result) - (float (nth 7 file-attr)))))) + (float (nth 7 file-attr))) + 0))) (defun elmo-get-last-accessed-time (path &optional dir) "Return the last accessed time of PATH." @@ -711,14 +718,14 @@ Return value is a cons cell of (STRUCTURE . REST)" (setq last-modified (+ (* (nth 0 last-modified) (float 65536)) (nth 1 last-modified))))) -(defun elmo-make-directory (path) +(defun elmo-make-directory (path &optional mode) "Create directory recursively." (let ((parent (directory-file-name (file-name-directory path)))) (if (null (file-directory-p parent)) (elmo-make-directory parent)) (make-directory path) - (if (string= path (expand-file-name elmo-msgdb-dir)) - (set-file-modes path (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700 + (set-file-modes path (or mode + (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700 (defun elmo-delete-directory (path &optional no-hierarchy) "Delete directory recursively." @@ -738,15 +745,21 @@ Return value is a cons cell of (STRUCTURE . REST)" (unless hierarchy (delete-directory path))))) +(defun elmo-delete-match-files (path regexp &optional remove-if-empty) + "Delete directory files specified by PATH. +If optional REMOVE-IF-EMPTY is non-nil, delete directory itself if +the directory becomes empty after deletion." + (when (stringp path) ; nil is not permitted. + (dolist (file (directory-files path t regexp)) + (delete-file file)) + (if remove-if-empty + (ignore-errors + (delete-directory path) ; should be removed if empty. + )))) + (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))) @@ -758,7 +771,7 @@ Return value is a cons cell of (STRUCTURE . REST)" (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 @@ -768,7 +781,7 @@ Return value is a cons cell of (STRUCTURE . REST)" (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) @@ -799,6 +812,9 @@ Return value is a cons cell of (STRUCTURE . REST)" (setq l1 (cdr l1))) (cons diff1 (list l2))))) +(defmacro elmo-filter-condition-p (filter) + `(or (vectorp ,filter) (consp ,filter))) + (defmacro elmo-filter-type (filter) (` (aref (, filter) 0))) @@ -822,56 +838,59 @@ Return value is a cons cell of (STRUCTURE . REST)" (length (memq number number-list))) (string-to-int (elmo-filter-value condition))))) ((string= (elmo-filter-key condition) "since") - (let ((date (elmo-date-get-datevec (elmo-filter-value condition)))) + (let ((field-date (elmo-date-make-sortable-string + (timezone-fix-time + (std11-field-body "date") + (current-time-zone) nil))) + (specified-date (elmo-date-make-sortable-string + (elmo-date-get-datevec + (elmo-filter-value condition))))) (setq result - (string< - (timezone-make-sortable-date (aref date 0) - (aref date 1) - (aref date 2) - (timezone-make-time-string - (aref date 3) - (aref date 4) - (aref date 5))) - (timezone-make-date-sortable (std11-field-body "date")))))) + (or (string= field-date specified-date) + (string< specified-date field-date))))) ((string= (elmo-filter-key condition) "before") - (let ((date (elmo-date-get-datevec (elmo-filter-value condition)))) - (setq result - (string< - (timezone-make-date-sortable (std11-field-body "date")) - (timezone-make-sortable-date (aref date 0) - (aref date 1) - (aref date 2) - (timezone-make-time-string - (aref date 3) - (aref date 4) - (aref date 5))))))) + (setq result + (string< + (elmo-date-make-sortable-string + (timezone-fix-time + (std11-field-body "date") + (current-time-zone) nil)) + (elmo-date-make-sortable-string + (elmo-date-get-datevec + (elmo-filter-value condition)))))) ((string= (elmo-filter-key condition) "body") (and (re-search-forward "^$" nil t) ; goto body (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)) -(defun elmo-condition-find-key-internal (condition key) +(defun elmo-condition-in-msgdb-p-internal (condition fields) (cond ((vectorp condition) - (if (string= (elmo-filter-key condition) key) + (if (not (member (elmo-filter-key condition) fields)) (throw 'found t))) ((or (eq (car condition) 'and) (eq (car condition) 'or)) - (elmo-condition-find-key-internal (nth 1 condition) key) - (elmo-condition-find-key-internal (nth 2 condition) key)))) - -(defun elmo-condition-find-key (condition key) - (catch 'found - (elmo-condition-find-key-internal condition key))) + (elmo-condition-in-msgdb-p-internal (nth 1 condition) fields) + (elmo-condition-in-msgdb-p-internal (nth 2 condition) fields)))) + +(defun elmo-condition-in-msgdb-p (condition) + (not (catch 'found + (elmo-condition-in-msgdb-p-internal condition + (append + elmo-msgdb-extra-fields + '("last" "first" "from" + "subject" "to" "cc" "since" + "before")))))) (defun elmo-buffer-field-condition-match (condition number number-list) (cond @@ -898,11 +917,15 @@ Return value is a cons cell of (STRUCTURE . REST)" (cond ((string= (elmo-filter-key condition) "last") (setq result (<= (length (memq number number-list)) - (string-to-int (elmo-filter-value condition))))) + (string-to-int (elmo-filter-value condition)))) + (if (eq (elmo-filter-type condition) 'unmatch) + (setq result (not result)))) ((string= (elmo-filter-key condition) "first") (setq result (< (- (length number-list) (length (memq number number-list))) - (string-to-int (elmo-filter-value condition))))) + (string-to-int (elmo-filter-value condition)))) + (if (eq (elmo-filter-type condition) 'unmatch) + (setq result (not result)))) (t (elmo-set-work-buf (as-binary-input-file (insert-file-contents file)) @@ -912,8 +935,6 @@ Return value is a cons cell of (STRUCTURE . REST)" (setq result (elmo-buffer-field-primitive-condition-match condition number number-list))))) - (if (eq (elmo-filter-type condition) 'unmatch) - (setq result (not result))) result)) (defun elmo-file-field-condition-match (file condition number number-list) @@ -933,12 +954,14 @@ Return value is a cons cell of (STRUCTURE . REST)" file (nth 2 condition) number number-list))))) (defmacro elmo-get-hash-val (string hashtable) - (let ((sym (list 'intern-soft string hashtable))) - (list 'if (list 'boundp sym) - (list '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) @@ -954,10 +977,10 @@ Emacs 19.28 or earlier does not have `unintern'." (defun elmo-make-hash (&optional hashsize) "Make a new hash table which have HASHSIZE size." (make-vector - (if hashsize + (if hashsize (max ;; Prime numbers as lengths tend to result in good - ;; hashing; lengths one less than a power of two are + ;; hashing; lengths one less than a power of two are ;; also good. (min (let ((i 1)) @@ -971,15 +994,16 @@ Emacs 19.28 or earlier does not have `unintern'." (defsubst elmo-mime-string (string) "Normalize MIME encoded STRING." - (and string - (let (str) - (elmo-set-work-buf - (elmo-set-buffer-multibyte default-enable-multibyte-characters) - (setq str (eword-decode-string - (decode-mime-charset-string string elmo-mime-charset))) - (setq str (encode-mime-charset-string str elmo-mime-charset)) - (elmo-set-buffer-multibyte nil) - str)))) + (and string + (elmo-set-work-buf + (elmo-set-buffer-multibyte default-enable-multibyte-characters) + (setq string + (encode-mime-charset-string + (eword-decode-and-unfold-unstructured-field-body + string) + elmo-mime-charset)) + (elmo-set-buffer-multibyte nil) + string))) (defsubst elmo-collect-field (beg end downcase-field-name) (save-excursion @@ -1061,10 +1085,10 @@ Emacs 19.28 or earlier does not have `unintern'." (setq filename (substring filename (+ (match-end 0) 1)))) (concat result filename))) -(defsubst elmo-copy-file (src dst) +(defsubst elmo-copy-file (src dst &optional ok-if-already-exists) (condition-case err - (elmo-add-name-to-file src dst t) - (error (copy-file src dst t)))) + (elmo-add-name-to-file src dst ok-if-already-exists) + (error (copy-file src dst ok-if-already-exists t)))) (defsubst elmo-buffer-exists-p (buffer) (if (bufferp buffer) @@ -1084,13 +1108,15 @@ Emacs 19.28 or earlier does not have `unintern'." (setq lst (cdr lst))) result)) -(defun elmo-list-delete (list1 list2) +(defun elmo-list-delete (list1 list2 &optional delete-function) "Delete by side effect any occurrences equal to elements of LIST1 from LIST2. Return the modified LIST2. Deletion is done with `delete'. Write `(setq foo (elmo-list-delete bar foo))' to be sure of changing -the value of `foo'." +the value of `foo'. +If optional DELETE-FUNCTION is speficied, it is used as delete procedure." + (setq delete-function (or delete-function 'delete)) (while list1 - (setq list2 (delete (car list1) list2)) + (setq list2 (funcall delete-function (car list1) list2)) (setq list1 (cdr list1))) list2) @@ -1121,9 +1147,8 @@ the value of `foo'." (setq err-mes (concat err-mes (format (if (stringp (car errobj)) "%s" - (if (boundp 'nemacs-version) - "%s" - "%S")) (car errobj)))) + "%S") + (car errobj)))) (setq errobj (cdr errobj)) (if errobj (setq err-mes (concat err-mes (if first ": " ", ")))) (setq first nil)) @@ -1153,6 +1178,71 @@ the value of `foo'." (apply (function message) (concat format " %d%%") (nconc args (list value))))))) +(defvar elmo-progress-counter-alist nil) + +(defmacro elmo-progress-counter-value (counter) + (` (aref (cdr (, counter)) 0))) + +(defmacro elmo-progress-counter-all-value (counter) + (` (aref (cdr (, counter)) 1))) + +(defmacro elmo-progress-counter-format (counter) + (` (aref (cdr (, counter)) 2))) + +(defmacro elmo-progress-counter-set-value (counter value) + (` (aset (cdr (, counter)) 0 (, value)))) + +(defun elmo-progress-set (label all-value &optional format) + (unless (assq label elmo-progress-counter-alist) + (setq elmo-progress-counter-alist + (cons (cons label (vector 0 all-value (or format ""))) + elmo-progress-counter-alist)))) + +(defun elmo-progress-clear (label) + (let ((counter (assq label elmo-progress-counter-alist))) + (when counter + (elmo-display-progress label + (elmo-progress-counter-format counter) + 100) + (setq elmo-progress-counter-alist + (delq counter elmo-progress-counter-alist))))) + +(defun elmo-progress-notify (label &optional value op &rest args) + (let ((counter (assq label elmo-progress-counter-alist))) + (when counter + (let* ((value (or value 1)) + (cur-value (elmo-progress-counter-value counter)) + (all-value (elmo-progress-counter-all-value counter)) + (new-value (if (eq op 'set) value (+ cur-value value))) + (cur-rate (/ (* cur-value 100) all-value)) + (new-rate (/ (* new-value 100) all-value))) + (elmo-progress-counter-set-value counter new-value) + (unless (= cur-rate new-rate) + (apply 'elmo-display-progress + label + (elmo-progress-counter-format counter) + new-rate + args)) + (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)) @@ -1168,10 +1258,23 @@ the value of `foo'." (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))) + (if (or (assq 'specials lal) + (assq 'domain-literal lal)) + (prin1-to-string word) + word))) + (defmacro elmo-string (string) "STRING without text property." (` (let ((obj (copy-sequence (, string)))) - (set-text-properties 0 (length obj) nil obj) + (and obj (set-text-properties 0 (length obj) nil obj)) obj))) (defun elmo-flatten (list-of-list) @@ -1191,7 +1294,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)) @@ -1199,6 +1301,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 @@ -1257,6 +1378,16 @@ But if optional argument AUTO is non-nil, DEFAULT is returned." (throw 'loop a)) (setq alist (cdr alist)))))) +(defun elmo-string-assoc-all (key alist) + (let (matches) + (while alist + (if (string= key (car (car alist))) + (setq matches + (cons (car alist) + matches))) + (setq alist (cdr alist))) + matches)) + (defun elmo-string-rassoc (key alist) (let (a) (catch 'loop @@ -1278,8 +1409,77 @@ But if optional argument AUTO is non-nil, DEFAULT is returned." (setq alist (cdr alist))) matches)) +(defun elmo-expand-newtext (newtext original) + (let ((len (length newtext)) + (pos 0) + c expanded beg N did-expand) + (while (< pos len) + (setq beg pos) + (while (and (< pos len) + (not (= (aref newtext pos) ?\\))) + (setq pos (1+ pos))) + (unless (= beg pos) + (push (substring newtext beg pos) expanded)) + (when (< pos len) + ;; We hit a \; expand it. + (setq did-expand t + pos (1+ pos) + c (aref newtext pos)) + (if (not (or (= c ?\&) + (and (>= c ?1) + (<= c ?9)))) + ;; \ followed by some character we don't expand. + (push (char-to-string c) expanded) + ;; \& or \N + (if (= c ?\&) + (setq N 0) + (setq N (- c ?0))) + (when (match-beginning N) + (push (substring original (match-beginning N) (match-end N)) + expanded)))) + (setq pos (1+ pos))) + (if did-expand + (apply (function concat) (nreverse expanded)) + newtext))) + +;;; Folder parser utils. +(defun elmo-parse-token (string &optional seps) + "Parse atom from STRING using SEPS as a string of separator char list." + (let ((len (length string)) + (seps (and seps (string-to-char-list seps))) + (i 0) + (sep nil) + content c in) + (if (eq len 0) + (cons "" "") + (while (and (< i len) (or in (null sep))) + (setq c (aref string i)) + (cond + ((and in (eq c ?\\)) + (setq i (1+ i) + content (cons (aref string i) content) + i (1+ i))) + ((eq c ?\") + (setq in (not in) + i (1+ i))) + (in (setq content (cons c content) + i (1+ i))) + ((memq c seps) + (setq sep c)) + (t (setq content (cons c content) + i (1+ i))))) + (if in (error "Parse error in quoted")) + (cons (if (null content) "" (char-list-to-string (nreverse content))) + (substring string i))))) + +(defun elmo-parse-prefixed-element (prefix string &optional seps) + (if (and (not (eq (length string) 0)) + (eq (aref string 0) prefix)) + (elmo-parse-token (substring string 1) seps) + (cons "" string))) + ;;; Number set defined by OKAZAKI Tetsurou -;; +;; ;; number ::= [0-9]+ ;; beg ::= number ;; end ::= number @@ -1408,7 +1608,7 @@ NUMBER-SET is altered." (store-match-data nil) (while (string-match regexp string (match-end 0)) (setq list (cons (substring string (match-beginning matchn) - (match-end matchn)) list))) + (match-end matchn)) list))) (nreverse list))) ;;; File cache. @@ -1443,21 +1643,20 @@ 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." (if (setq msgid (elmo-msgid-to-cache msgid)) (expand-file-name (if section - (format "%s/%s/%s/%s/%s" - elmo-msgdb-dir - elmo-cache-dirname + (format "%s/%s/%s/%s" + elmo-cache-directory (elmo-cache-get-path-subr msgid) msgid section) - (format "%s/%s/%s/%s" - elmo-msgdb-dir - elmo-cache-dirname + (format "%s/%s/%s" + elmo-cache-directory (elmo-cache-get-path-subr msgid) msgid))))) @@ -1469,16 +1668,14 @@ SECTION is the section string." (defun elmo-file-cache-delete (path) "Delete a cache on PATH." - (let (files) - (when (file-exists-p path) - (if (file-directory-p path) - (progn - (setq files (directory-files path t "^[^\\.]")) - (while files - (delete-file (car files)) - (setq files (cdr files))) - (delete-directory path)) - (delete-file path))))) + (when (file-exists-p path) + (if (file-directory-p path) + (progn + (dolist (file (directory-files path t "^[^\\.]")) + (delete-file file)) + (delete-directory path)) + (delete-file path)) + t)) (defun elmo-file-cache-exists-p (msgid) "Returns 'section or 'entire if a cache which corresponds to MSGID exists." @@ -1512,6 +1709,24 @@ Return t if cache is saved successfully." ;; ignore error (error))) +(defun elmo-file-cache-load (cache-path section) + "Load cache on PATH into the current buffer. +Return t if cache is loaded successfully." + (condition-case nil + (let (cache-file) + (when (and cache-path + (if (elmo-cache-path-section-p cache-path) + section + (null section)) + (setq cache-file (elmo-file-cache-expand-path + cache-path + section)) + (file-exists-p cache-file)) + (insert-file-contents-as-binary cache-file) + t)) + ;; igore error + (error))) + (defun elmo-cache-path-section-p (path) "Return non-nil when PATH is `section' cache path." (file-directory-p path)) @@ -1546,9 +1761,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) @@ -1579,8 +1795,7 @@ If KBYTES is kilo bytes (This value must be float)." total beginning) (message "Checking disk usage...") (setq total (/ (elmo-disk-usage - (expand-file-name - elmo-cache-dirname elmo-msgdb-dir)) Kbytes)) + elmo-cache-directory) Kbytes)) (setq beginning total) (message "Checking disk usage...done") (let ((cfl (elmo-cache-get-sorted-cache-file-list)) @@ -1628,7 +1843,7 @@ If KBYTES is kilo bytes (This value must be float)." (defun elmo-cache-get-sorted-cache-file-list () (let ((dirs (directory-files - (expand-file-name elmo-cache-dirname elmo-msgdb-dir) + elmo-cache-directory t "^[^\\.]")) (i 0) num elist @@ -1664,7 +1879,7 @@ If KBYTES is kilo bytes (This value must be float)." elmo-cache-expire-default-age))) (int-to-string elmo-cache-expire-default-age))) (dirs (directory-files - (expand-file-name elmo-cache-dirname elmo-msgdb-dir) + elmo-cache-directory t "^[^\\.]")) (count 0) curtime) @@ -1689,9 +1904,10 @@ If KBYTES is kilo bytes (This value must be float)." ;;; ;; msgid to path. (defun elmo-msgid-to-cache (msgid) - (when (and msgid - (string-match "<\\(.+\\)>$" msgid)) - (elmo-replace-string-as-filename (elmo-match-string 1 msgid)))) + (save-match-data + (when (and msgid + (string-match "<\\(.+\\)>$" msgid)) + (elmo-replace-string-as-filename (elmo-match-string 1 msgid))))) (defun elmo-cache-get-path (msgid &optional folder number) "Get path for cache file associated with MSGID, FOLDER, and NUMBER." @@ -1707,24 +1923,30 @@ If KBYTES is kilo bytes (This value must be float)." (format "%s/%s" (elmo-cache-get-path-subr msgid) msgid)) - (expand-file-name elmo-cache-dirname - elmo-msgdb-dir))))) + elmo-cache-directory)))) ;;; ;; Warnings. -(defconst elmo-warning-buffer-name "*elmo warning*") - -(defun elmo-warning (&rest args) - "Display a warning, making warning message by passing all args to `insert'." - (with-current-buffer (get-buffer-create elmo-warning-buffer-name) - (goto-char (point-max)) - (apply 'insert (append args '("\n"))) - (recenter 1)) - (display-buffer elmo-warning-buffer-name)) +(static-if (fboundp 'display-warning) + (defmacro elmo-warning (&rest args) + "Display a warning with `elmo' group." + `(display-warning 'elmo (format ,@args))) + (defconst elmo-warning-buffer-name "*elmo warning*") + (defun elmo-warning (&rest args) + "Display a warning. ARGS are passed to `format'." + (with-current-buffer (get-buffer-create elmo-warning-buffer-name) + (goto-char (point-max)) + (funcall 'insert (apply 'format (append args '("\n")))) + (ignore-errors (recenter 1)) + (display-buffer elmo-warning-buffer-name)))) (defvar elmo-obsolete-variable-alist nil) -(defvar elmo-obsolete-variable-show-warnings nil) + +(defcustom elmo-obsolete-variable-show-warnings t + "Show warning window if obsolete variable is treated." + :type 'boolean + :group 'elmo) (defun elmo-define-obsolete-variable (obsolete var) "Define obsolete variable. @@ -1747,9 +1969,9 @@ If `elmo-obsolete-variable-show-warnings' is non-nil, show warning message." (defvaralias var obsolete) (set var (symbol-value obsolete))) (if elmo-obsolete-variable-show-warnings - (elmo-warning (format "%s is obsolete. Use %s instead." - (symbol-name obsolete) - (symbol-name var)))))) + (elmo-warning "%s is obsolete. Use %s instead." + (symbol-name obsolete) + (symbol-name var))))) (defun elmo-resque-obsolete-variables (&optional alist) "Resque obsolete variables in ALIST. @@ -1760,6 +1982,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.") @@ -1768,14 +2048,26 @@ If ALIST is nil, `elmo-obsolete-variable-alist' is used." (setq elmo-dop-queue (elmo-object-load (expand-file-name elmo-dop-queue-filename - elmo-msgdb-dir)))) + elmo-msgdb-directory)))) (defun elmo-dop-queue-save () (elmo-object-save (expand-file-name elmo-dop-queue-filename - elmo-msgdb-dir) + 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))