X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-util.el;h=e3768c1fb427e2f06cd74590c020ba81935abc0c;hb=31665e949babd625632818bb0470f9486367fc88;hp=9fab0b444fd45dabf7343c40faac854a24fbba72;hpb=435763fadbe337d9f6d8e66ef46209492e49e8b8;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-util.el b/elmo/elmo-util.el index 9fab0b4..e3768c1 100644 --- a/elmo/elmo-util.el +++ b/elmo/elmo-util.el @@ -38,17 +38,10 @@ (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))) +(eval-and-compile + (autoload 'md5 "md5")) (defvar elmo-work-buf-name " *elmo work*") (defvar elmo-temp-buf-name " *elmo temp*") @@ -79,33 +72,128 @@ "Execute BODY on work buffer. Work buffer remains." (` (save-excursion (set-buffer (get-buffer-create elmo-work-buf-name)) - (elmo-set-buffer-multibyte default-enable-multibyte-characters) + (set-buffer-multibyte default-enable-multibyte-characters) (erase-buffer) (,@ body)))) +(put 'elmo-set-work-buf 'lisp-indent-function 0) +(def-edebug-spec elmo-set-work-buf t) + (defmacro elmo-bind-directory (dir &rest body) "Set current directory DIR and execute BODY." (` (let ((default-directory (file-name-as-directory (, dir)))) (,@ body)))) +(put 'elmo-bind-directory 'lisp-indent-function 1) +(def-edebug-spec elmo-bind-directory + (form &rest form)) + +(defconst elmo-multibyte-buffer-name " *elmo-multibyte-buffer*") + +(defmacro elmo-with-enable-multibyte (&rest body) + "Evaluate BODY with `default-enable-multibyte-character'." + `(with-current-buffer (get-buffer-create elmo-multibyte-buffer-name) + ,@body)) + +(put 'elmo-with-enable-multibyte 'lisp-indent-function 0) +(def-edebug-spec elmo-with-enable-multibyte t) + +(eval-when-compile + (unless (fboundp 'coding-system-base) + (defalias 'coding-system-base 'ignore)) + (unless (fboundp 'coding-system-name) + (defalias 'coding-system-name 'ignore)) + (unless (fboundp 'find-file-coding-system-for-read-from-filename) + (defalias 'find-file-coding-system-for-read-from-filename 'ignore)) + (unless (fboundp 'find-operation-coding-system) + (defalias 'find-operation-coding-system 'ignore))) + +(defun elmo-set-auto-coding (&optional filename) + "Find coding system used to decode the contents of the current buffer. +This function looks for the coding system magic cookie or examines the +coding system specified by `file-coding-system-alist' being associated +with FILENAME which defaults to `buffer-file-name'." + (cond + ((boundp 'set-auto-coding-function) ;; Emacs + (if filename + (or (funcall (symbol-value 'set-auto-coding-function) + filename (- (point-max) (point-min))) + (car (find-operation-coding-system 'insert-file-contents + filename))) + (let (auto-coding-alist) + (condition-case nil + (funcall (symbol-value 'set-auto-coding-function) + nil (- (point-max) (point-min))) + (error nil))))) + ((featurep 'file-coding) ;; XEmacs + (let ((case-fold-search t) + (end (point-at-eol)) + codesys start) + (or + (and (re-search-forward "-\\*-+[\t ]*" end t) + (progn + (setq start (match-end 0)) + (re-search-forward "[\t ]*-+\\*-" end t)) + (progn + (setq end (match-beginning 0)) + (goto-char start) + (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)") + (re-search-forward + "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)" + end t))) + (find-coding-system (setq codesys + (intern (match-string 1)))) + codesys) + (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:" + nil t) + (progn + (setq start (match-end 0)) + (re-search-forward "^[\t ]*;+[\t ]*End:" nil t)) + (progn + (setq end (match-beginning 0)) + (goto-char start) + (re-search-forward + "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)" + end t)) + (find-coding-system (setq codesys + (intern (match-string 1)))) + codesys) + (and (progn + (goto-char (point-min)) + (setq case-fold-search nil) + (re-search-forward "^;;;coding system: " + ;;(+ (point-min) 3000) t)) + nil t)) + (looking-at "[^\t\n\r ]+") + (find-coding-system + (setq codesys (intern (match-string 0)))) + codesys) + (and filename + (setq codesys + (find-file-coding-system-for-read-from-filename + filename)) + (coding-system-name (coding-system-base codesys)))))))) + (defun elmo-object-load (filename &optional mime-charset no-err) "Load OBJECT from the file specified by FILENAME. File content is decoded with MIME-CHARSET." - (if (not (file-readable-p filename)) - nil - (elmo-set-work-buf - (as-binary-input-file - (insert-file-contents filename)) - (when mime-charset - (elmo-set-buffer-multibyte default-enable-multibyte-characters) - (decode-mime-charset-region (point-min) (point-max) mime-charset)) - (condition-case nil - (read (current-buffer)) - (error (unless no-err - (message "Warning: Loading object from %s failed." - filename) - (elmo-object-save filename nil)) - nil))))) + (if (not (file-readable-p filename)) + nil + (with-temp-buffer + (insert-file-contents-as-binary filename) + (let ((coding-system (or (elmo-set-auto-coding) + (mime-charset-to-coding-system + mime-charset)))) + (when coding-system + (decode-coding-region (point-min) (point-max) coding-system))) + (goto-char (point-min)) + (condition-case nil + (read (current-buffer)) + (error (unless no-err + (message "Warning: Loading object from %s failed." + filename) + (elmo-object-save filename nil mime-charset)) + nil))))) (defsubst elmo-save-buffer (filename &optional mime-charset) "Save current buffer to the file specified by FILENAME. @@ -119,7 +207,7 @@ File content is encoded with MIME-CHARSET." (if (file-writable-p filename) (progn (when mime-charset -;;; (elmo-set-buffer-multibyte default-enable-multibyte-characters) +;;; (set-buffer-multibyte default-enable-multibyte-characters) (encode-mime-charset-region (point-min) (point-max) mime-charset)) (as-binary-output-file (write-region (point-min) (point-max) filename nil 'no-msg))) @@ -129,62 +217,23 @@ File content is encoded with 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 - (let (print-length print-level) - (prin1 object (current-buffer))) -;;;(princ "\n" (current-buffer)) - (elmo-save-buffer filename mime-charset))) + (with-temp-buffer + (let (print-length print-level) + (prin1 object (current-buffer))) + (when mime-charset + (let ((coding (mime-charset-to-coding-system + (or (detect-mime-charset-region (point-min) (point-max)) + mime-charset)))) + (goto-char (point-min)) + (insert ";;; -*- mode: emacs-lisp; coding: " + (symbol-name coding) " -*-\n") + (encode-coding-region (point-min) (point-max) coding))) + (elmo-save-buffer filename))) ;;; Search Condition (defconst elmo-condition-atom-regexp "[^/ \")|&]*") -(defun elmo-read-search-condition (default) - "Read search condition string interactively." - (elmo-read-search-condition-internal "Search by" default)) - -(defun elmo-read-search-condition-internal (prompt default) - (let* ((completion-ignore-case t) - (field (completing-read - (format "%s (%s): " prompt default) - (mapcar 'list - (append '("AND" "OR" - "Last" "First" - "From" "Subject" "To" "Cc" "Body" - "Since" "Before" "ToCc" - "!From" "!Subject" "!To" "!Cc" "!Body" - "!Since" "!Before" "!ToCc") - elmo-msgdb-extra-fields)))) - value) - (setq field (if (string= field "") - (setq field default) - field)) - (cond - ((or (string= field "AND") (string= field "OR")) - (concat "(" - (elmo-read-search-condition-internal - (concat field "(1) Search by") default) - (if (string= field "AND") "&" "|") - (elmo-read-search-condition-internal - (concat field "(2) Search by") default) - ")")) - ((string-match "Since\\|Before" field) - (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)))) - (t - (setq value (read-from-minibuffer (format "Value for '%s': " field))) - (unless (string-match (concat "^" elmo-condition-atom-regexp "$") - value) - (setq value (prin1-to-string value))) - (concat (downcase field) ":" value))))) - (defsubst elmo-condition-parse-error () (error "Syntax error in '%s'" (buffer-string))) @@ -233,12 +282,12 @@ 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" / "flag" / field-name ((looking-at "\\(!\\)? *\\([A-Za-z-]+\\) *: *") (goto-char (match-end 0)) (let ((search-key (vector (if (match-beginning 1) 'unmatch 'match) - (elmo-match-buffer 2) + (downcase (elmo-match-buffer 2)) (elmo-condition-parse-search-value)))) ;; syntax sugar. (if (string= (aref search-key 1) "tocc") @@ -269,17 +318,88 @@ Return value is a cons cell of (STRUCTURE . REST)" (cond ((looking-at "\"") (read (current-buffer))) - ((or (looking-at "yesterday") (looking-at "lastweek") + ((or (looking-at elmo-condition-atom-regexp) + (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)) + (looking-at "[0-9]+")) (prog1 (elmo-match-buffer 0) (goto-char (match-end 0)))) (t (error "Syntax error '%s'" (buffer-string))))) +(defmacro elmo-filter-condition-p (filter) + `(or (vectorp ,filter) (consp ,filter))) + +(defmacro elmo-filter-type (filter) + `(aref ,filter 0)) + +(defmacro elmo-filter-key (filter) + `(aref ,filter 1)) + +(defmacro elmo-filter-value (filter) + `(aref ,filter 2)) + +(defun elmo-condition-match (condition match-primitive args) + (cond + ((vectorp condition) + (if (eq (elmo-filter-type condition) 'unmatch) + (not (apply match-primitive condition args)) + (apply match-primitive condition args))) + ((eq (car condition) 'and) + (let ((lhs (elmo-condition-match (nth 1 condition) match-primitive args))) + (cond + ((elmo-filter-condition-p lhs) + (let ((rhs (elmo-condition-match (nth 2 condition) + match-primitive args))) + (cond ((elmo-filter-condition-p rhs) + (list 'and lhs rhs)) + (rhs + lhs)))) + (lhs + (elmo-condition-match (nth 2 condition) match-primitive args))))) + ((eq (car condition) 'or) + (let ((lhs (elmo-condition-match (nth 1 condition) match-primitive args))) + (cond + ((elmo-filter-condition-p lhs) + (let ((rhs (elmo-condition-match (nth 2 condition) + match-primitive args))) + (cond ((elmo-filter-condition-p rhs) + (list 'or lhs rhs)) + (rhs + t) + (t + lhs)))) + (lhs + t) + (t + (elmo-condition-match (nth 2 condition) match-primitive args))))))) + +(defun elmo-condition-optimize (condition) + (cond + ((vectorp condition) + (let ((key (elmo-filter-key condition))) + (cond ((cdr (assoc key '(("first" . 0) + ("last" . 0) + ("flag" . 1) + ("body" . 5))))) + ((member key '("since" "before" "from" "subject" "to" "cc")) + 2) + ((member key elmo-msgdb-extra-fields) + 3) + (t + 4)))) + (t + (let ((weight-l (elmo-condition-optimize (nth 1 condition))) + (weight-r (elmo-condition-optimize (nth 2 condition)))) + (if (> weight-l weight-r) + (let ((lhs (nth 1 condition))) + (setcar (nthcdr 1 condition) (nth 2 condition)) + (setcar (nthcdr 2 condition) lhs) + weight-l) + weight-r))))) + ;;; (defsubst elmo-buffer-replace (regexp &optional newtext) (goto-char (point-min)) @@ -291,7 +411,7 @@ Return value is a cons cell of (STRUCTURE . REST)" (elmo-set-work-buf (let ((coding-system-for-read 'no-conversion) (coding-system-for-write 'no-conversion)) - (if unibyte (elmo-set-buffer-multibyte nil)) + (if unibyte (set-buffer-multibyte nil)) (insert string) (goto-char (point-min)) (while (search-forward (char-to-string char) nil t) @@ -323,16 +443,39 @@ Return value is a cons cell of (STRUCTURE . REST)" (replace-match "\n")) (buffer-string)))) -(defun elmo-uniq-list (lst) +(defun elmo-last (list) + (and list (nth (1- (length list)) list))) + +(defun elmo-set-list (vars vals) + (while vars + (when (car vars) + (set (car vars) (car vals))) + (setq vars (cdr vars) + vals (cdr vals)))) + +(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-uniq-sorted-list (list &optional equal-function) + "Distractively uniqfy elements of sorted LIST." + (setq equal-function (or equal-function #'equal)) + (let ((list list)) + (while list + (while (funcall equal-function (car list) (cadr list)) + (setcdr list (cddr list))) + (setq list (cdr list)))) + list) + (defun elmo-list-insert (list element after) (let* ((match (memq after list)) (rest (and match (cdr (memq after list))))) @@ -342,9 +485,6 @@ Return value is a cons cell of (STRUCTURE . REST)" (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... @@ -379,49 +519,47 @@ Return value is a cons cell of (STRUCTURE . REST)" (defun elmo-concat-path (path filename) (if (not (string= path "")) - (if (string= elmo-path-sep (substring path (- (length path) 1))) - (concat path filename) - (concat path elmo-path-sep filename)) + (elmo-replace-in-string + (if (string= elmo-path-sep (substring path (- (length path) 1))) + (concat path filename) + (concat path elmo-path-sep filename)) + (concat (regexp-quote elmo-path-sep)(regexp-quote elmo-path-sep)) + elmo-path-sep) filename)) (defvar elmo-passwd-alist nil) (defun elmo-passwd-alist-load () - (save-excursion + (with-temp-buffer (let ((filename (expand-file-name elmo-passwd-alist-file-name 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)))) - (kill-buffer tmp-buffer) - ret-val))) + (condition-case nil + (read (current-buffer)) + (error nil nil)))))) (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 + (with-temp-buffer (let ((filename (expand-file-name elmo-passwd-alist-file-name 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) - (princ "\n" tmp-buffer) + (prin1 elmo-passwd-alist (current-buffer)) + (princ "\n" (current-buffer)) ;;; (if (and (file-exists-p filename) ;;; (not (equal 384 (file-modes filename)))) ;;; (error "%s is not safe.chmod 600 %s!" filename filename)) @@ -430,8 +568,7 @@ Return value is a cons cell of (STRUCTURE . REST)" (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)))) + (message "%s is not writable." filename))))) (defun elmo-get-passwd (key) "Get password from password pool." @@ -455,12 +592,11 @@ 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) @@ -741,19 +877,13 @@ the directory becomes empty after deletion." (dolist (file (directory-files path t regexp)) (delete-file file)) (if remove-if-empty - (ignore-errors + (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))) @@ -763,9 +893,34 @@ the directory becomes empty after deletion." (setq list (cdr list))) ret-val)) -(defun elmo-list-diff (list1 list2 &optional mes) - (if mes - (message mes)) +(defun elmo-list-diff (list1 list2) + (let ((clist1 (sort (copy-sequence list1) #'<)) + (clist2 (sort (copy-sequence list2) #'<)) + list1-only list2-only) + (while (or clist1 clist2) + (cond + ((null clist1) + (while clist2 + (setq list2-only (cons (car clist2) list2-only)) + (setq clist2 (cdr clist2)))) + ((null clist2) + (while clist1 + (setq list1-only (cons (car clist1) list1-only)) + (setq clist1 (cdr clist1)))) + ((< (car clist1) (car clist2)) + (while (and clist1 (< (car clist1) (car clist2))) + (setq list1-only (cons (car clist1) list1-only)) + (setq clist1 (cdr clist1)))) + ((< (car clist2) (car clist1)) + (while (and clist2 (< (car clist2) (car clist1))) + (setq list2-only (cons (car clist2) list2-only)) + (setq clist2 (cdr clist2)))) + ((= (car clist1) (car clist2)) + (setq clist1 (cdr clist1) + clist2 (cdr clist2))))) + (list list1-only list2-only))) + +(defun elmo-list-diff-nonsortable (list1 list2) (let ((clist1 (copy-sequence list1)) (clist2 (copy-sequence list2))) (while list2 @@ -774,8 +929,6 @@ the directory becomes empty after deletion." (while list1 (setq clist2 (delq (car list1) clist2)) (setq list1 (cdr list1))) - (if mes - (message (concat mes "done"))) (list clist1 clist2))) (defun elmo-list-bigger-diff (list1 list2 &optional mes) @@ -806,154 +959,15 @@ the directory becomes empty after deletion." (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))) - -(defmacro elmo-filter-key (filter) - (` (aref (, filter) 1))) - -(defmacro elmo-filter-value (filter) - (` (aref (, filter) 2))) - -(defsubst elmo-buffer-field-primitive-condition-match (condition - number - number-list) - (let (result) - (goto-char (point-min)) - (cond - ((string= (elmo-filter-key condition) "last") - (setq result (<= (length (memq number number-list)) - (string-to-int (elmo-filter-value condition))))) - ((string= (elmo-filter-key condition) "first") - (setq result (< (- (length number-list) - (length (memq number number-list))) - (string-to-int (elmo-filter-value condition))))) - ((string= (elmo-filter-key condition) "since") - (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 - (or (string= field-date specified-date) - (string< specified-date field-date))))) - ((string= (elmo-filter-key condition) "before") - (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)))) - (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)))))) - (if (eq (elmo-filter-type condition) 'unmatch) - (setq result (not result))) - result)) - -(defun elmo-condition-in-msgdb-p-internal (condition fields) - (cond - ((vectorp condition) - (if (not (member (elmo-filter-key condition) fields)) - (throw 'found t))) - ((or (eq (car condition) 'and) - (eq (car condition) 'or)) - (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 - ((vectorp condition) - (elmo-buffer-field-primitive-condition-match - condition number number-list)) - ((eq (car condition) 'and) - (and (elmo-buffer-field-condition-match - (nth 1 condition) number number-list) - (elmo-buffer-field-condition-match - (nth 2 condition) number number-list))) - ((eq (car condition) 'or) - (or (elmo-buffer-field-condition-match - (nth 1 condition) number number-list) - (elmo-buffer-field-condition-match - (nth 2 condition) number number-list))))) - -(defsubst elmo-file-field-primitive-condition-match (file - condition - number - number-list) - (let (result) - (goto-char (point-min)) - (cond - ((string= (elmo-filter-key condition) "last") - (setq result (<= (length (memq number number-list)) - (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)))) - (if (eq (elmo-filter-type condition) 'unmatch) - (setq result (not result)))) - (t - (elmo-set-work-buf - (as-binary-input-file (insert-file-contents file)) - (elmo-set-buffer-multibyte default-enable-multibyte-characters) - ;; Should consider charset? - (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset) - (setq result - (elmo-buffer-field-primitive-condition-match - condition number number-list))))) - result)) - -(defun elmo-file-field-condition-match (file condition number number-list) - (cond - ((vectorp condition) - (elmo-file-field-primitive-condition-match - file condition number number-list)) - ((eq (car condition) 'and) - (and (elmo-file-field-condition-match - file (nth 1 condition) number number-list) - (elmo-file-field-condition-match - file (nth 2 condition) number number-list))) - ((eq (car condition) 'or) - (or (elmo-file-field-condition-match - file (nth 1 condition) number number-list) - (elmo-file-field-condition-match - 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) @@ -987,15 +1001,10 @@ Emacs 19.28 or earlier does not have `unintern'." (defsubst elmo-mime-string (string) "Normalize MIME encoded STRING." (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))) + (elmo-with-enable-multibyte + (encode-mime-charset-string + (eword-decode-and-unfold-unstructured-field-body string) + elmo-mime-charset)))) (defsubst elmo-collect-field (beg end downcase-field-name) (save-excursion @@ -1096,9 +1105,9 @@ Emacs 19.28 or earlier does not have `unintern'." (let (result) (while lst (unless (funcall pred (car lst)) - (setq result (nconc result (list (car lst))))) + (setq result (cons (car lst) result))) (setq lst (cdr lst))) - result)) + (nreverse result))) (defun elmo-list-delete (list1 list2 &optional delete-function) "Delete by side effect any occurrences equal to elements of LIST1 from LIST2. @@ -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,17 @@ 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-decoded-field-body (field-name &optional mode) + (let ((field-body (elmo-field-body field-name))) + (and field-body + (elmo-with-enable-multibyte + (mime-decode-field-body field-body field-name mode))))) + (defun elmo-address-quote-specials (word) "Make quoted string of WORD if needed." (let ((lal (std11-lexical-analyze word))) @@ -1264,7 +1301,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,7 +1308,7 @@ But if optional argument AUTO is non-nil, DEFAULT is returned." (throw 'found t)) (setq slist (cdr slist))))) -(cond ((fboundp 'member-ignore-case) +(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) @@ -1414,6 +1450,13 @@ ELT must be a string. Upper-case and lower-case letters are treated as equal." newtext))) ;;; Folder parser utils. +(defconst elmo-quoted-specials-list '(?\\ ?\")) + +(defun elmo-quoted-token (string) + (concat "\"" + (std11-wrap-as-quoted-pairs string elmo-quoted-specials-list) + "\"")) + (defun elmo-parse-token (string &optional seps) "Parse atom from STRING using SEPS as a string of separator char list." (let ((len (length string)) @@ -1506,21 +1549,80 @@ NUMBER-SET is altered." (setq number-set-1 (nconc number-set-1 (list number)))) number-set-1)) +(defun elmo-number-set-delete-list (number-set list) + "Delete LIST of numbers from the NUMBER-SET. +NUMBER-SET is altered." + (let ((deleted number-set)) + (dolist (number list) + (setq deleted (elmo-number-set-delete deleted number))) + deleted)) + +(defun elmo-number-set-delete (number-set number) + "Delete NUMBER from the NUMBER-SET. +NUMBER-SET is altered." + (let* ((curr number-set) + (top (cons 'dummy number-set)) + (prev top) + elem found) + (while (and curr (not found)) + (setq elem (car curr)) + (if (consp elem) + (cond + ((eq (car elem) number) + (if (eq (cdr elem) (1+ number)) + (setcar curr (cdr elem)) + (setcar elem (1+ number))) + (setq found t)) + ((eq (cdr elem) number) + (if (eq (car elem) (1- number)) + (setcar curr (car elem)) + (setcdr elem (1- number))) + (setq found t)) + ((and (> number (car elem)) + (< number (cdr elem))) + (setcdr + prev + (nconc + (list + ;; (beg . (1- number)) + (let ((new (cons (car elem) (1- number)))) + (if (eq (car new) (cdr new)) + (car new) + new)) + ;; ((1+ number) . end) + (let ((new (cons (1+ number) (cdr elem)))) + (if (eq (car new) (cdr new)) + (car new) + new))) + (cdr curr))))) + (when (eq elem number) + (setcdr prev (cdr curr)) + (setq found t))) + (setq prev curr + curr (cdr curr))) + (cdr top))) + +(defun elmo-make-number-list (beg end) + (let (number-list i) + (setq i end) + (while (>= i beg) + (setq number-list (cons i number-list)) + (setq i (1- i))) + number-list)) + (defun elmo-number-set-to-number-list (number-set) "Return a number list which corresponds to NUMBER-SET." - (let (number-list elem i) + (let ((number-list (list 'dummy)) + elem) (while number-set (setq elem (car number-set)) (cond ((consp elem) - (setq i (car elem)) - (while (<= i (cdr elem)) - (setq number-list (cons i number-list)) - (incf i))) + (nconc number-list (elmo-make-number-list (car elem) (cdr elem)))) ((integerp elem) - (setq number-list (cons elem number-list)))) + (nconc number-list (list elem)))) (setq number-set (cdr number-set))) - (nreverse number-list))) + (cdr number-list))) (defcustom elmo-list-subdirectories-ignore-regexp "^\\(\\.\\.?\\|[0-9]+\\)$" "*Regexp to filter subfolders." @@ -1573,6 +1675,19 @@ NUMBER-SET is altered." (t (funcall func x)))) list-of-list)) +(defun elmo-map-recursive (function object) + (if (consp object) + (let* ((prev (list 'dummy)) + (result prev)) + (while (consp object) + (setq prev (setcdr prev (list (elmo-map-recursive function + (car object)))) + object (cdr object))) + (when object + (setcdr prev (funcall function object))) + (cdr result)) + (funcall function object))) + (defun elmo-parse (string regexp &optional matchn) (or matchn (setq matchn 1)) (let (list) @@ -1582,49 +1697,6 @@ NUMBER-SET is altered." (match-end matchn)) list))) (nreverse list))) -;;; -;; parsistent mark handling -;; (for global!) -;; (FIXME: this should be treated in the msgdb.) - -(defvar elmo-msgdb-global-mark-alist nil) - -(defun elmo-msgdb-global-mark-delete (msgid) - (let* ((path (expand-file-name - elmo-msgdb-global-mark-filename - elmo-msgdb-directory)) - (malist (or elmo-msgdb-global-mark-alist - (setq elmo-msgdb-global-mark-alist - (elmo-object-load path)))) - match) - (when (setq match (assoc msgid malist)) - (setq elmo-msgdb-global-mark-alist - (delete match elmo-msgdb-global-mark-alist)) - (elmo-object-save path elmo-msgdb-global-mark-alist)))) - -(defun elmo-msgdb-global-mark-set (msgid mark) - (let* ((path (expand-file-name - elmo-msgdb-global-mark-filename - elmo-msgdb-directory)) - (malist (or elmo-msgdb-global-mark-alist - (setq elmo-msgdb-global-mark-alist - (elmo-object-load path)))) - match) - (if (setq match (assoc msgid malist)) - (setcdr match mark) - (setq elmo-msgdb-global-mark-alist - (nconc elmo-msgdb-global-mark-alist - (list (cons msgid mark))))) - (elmo-object-save path elmo-msgdb-global-mark-alist))) - -(defun elmo-msgdb-global-mark-get (msgid) - (cdr (assoc msgid (or elmo-msgdb-global-mark-alist - (setq elmo-msgdb-global-mark-alist - (elmo-object-load - (expand-file-name - elmo-msgdb-global-mark-filename - elmo-msgdb-directory))))))) - ;;; File cache. (defmacro elmo-make-file-cache (path status) "PATH is the cache file name. @@ -1657,6 +1729,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." @@ -1681,16 +1754,14 @@ SECTION is the section string." (defun elmo-file-cache-delete (path) "Delete a cache on PATH." - (unless (elmo-msgdb-global-mark-get - (elmo-cache-to-msgid (file-name-nondirectory 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))) + (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." @@ -1776,9 +1847,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) @@ -1996,6 +2068,115 @@ 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 "<" + (if (elmo-unfold-field-body "date") + (timezone-make-date-sortable (elmo-unfold-field-body "date")) + (md5 (string-as-unibyte (buffer-string)))) + (nth 1 (eword-extract-address-components + (or (elmo-field-body "from") "nobody"))) ">")))) + +(defun elmo-msgdb-get-references-from-buffer () + (if elmo-msgdb-prefer-in-reply-to-for-parent + (or (elmo-msgdb-get-last-message-id (elmo-field-body "in-reply-to")) + (elmo-msgdb-get-last-message-id (elmo-field-body "references"))) + (or (elmo-msgdb-get-last-message-id (elmo-field-body "references")) + (elmo-msgdb-get-last-message-id (elmo-field-body "in-reply-to"))))) + +(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)))) + +(defun elmo-parse-addresses (string) + (if (null string) + () + (elmo-set-work-buf + (let (list start s char) + (insert string) + (goto-char (point-min)) + (skip-chars-forward "\t\f\n\r ") + (setq start (point)) + (while (not (eobp)) + (skip-chars-forward "^\"\\,(") + (setq char (following-char)) + (cond ((= char ?\\) + (forward-char 1) + (if (not (eobp)) + (forward-char 1))) + ((= char ?,) + (setq s (buffer-substring start (point))) + (if (or (null (string-match "^[\t\f\n\r ]+$" s)) + (not (string= s ""))) + (setq list (cons s list))) + (skip-chars-forward ",\t\f\n\r ") + (setq start (point))) + ((= char ?\") + (re-search-forward "[^\\]\"" nil 0)) + ((= char ?\() + (let ((parens 1)) + (forward-char 1) + (while (and (not (eobp)) (not (zerop parens))) + (re-search-forward "[()]" nil 0) + (cond ((or (eobp) + (= (char-after (- (point) 2)) ?\\))) + ((= (preceding-char) ?\() + (setq parens (1+ parens))) + (t + (setq parens (1- parens))))))))) + (setq s (buffer-substring start (point))) + (if (and (null (string-match "^[\t\f\n\r ]+$" s)) + (not (string= s ""))) + (setq list (cons s list))) + (nreverse list))))) + ;;; Queue. (defvar elmo-dop-queue-filename "queue" "*Disconnected operation queue is saved in this file.") @@ -2012,6 +2193,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))