;;; Code:
;;
-(eval-when-compile (require 'cl))
+(eval-when-compile
+ (require 'cl)
+ (require 'static))
(require 'elmo-vars)
(require 'elmo-date)
(require 'mcharset)
(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*")
(fset 'elmo-base64-decode-string
(mel-find-function 'mime-decode-string "base64"))
-;; Any Emacsen may have add-name-to-file(), because loadup.el requires it. :-p
-;; Check make-symbolic-link() instead. -- 981002 by Fuji
-(if (fboundp 'make-symbolic-link) ;; xxx
- (defalias 'elmo-add-name-to-file 'add-name-to-file)
- (defun elmo-add-name-to-file
- (filename newname &optional ok-if-already-exists)
- (copy-file filename newname ok-if-already-exists t)))
-
-(defalias 'elmo-read 'read)
+(eval-and-compile
+ (if elmo-use-hardlink
+ (defalias 'elmo-add-name-to-file 'add-name-to-file)
+ (defun elmo-add-name-to-file
+ (filename newname &optional ok-if-already-exists)
+ (copy-file filename newname ok-if-already-exists t))))
(defmacro elmo-set-work-buf (&rest body)
"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)
- (erase-buffer)
- (,@ body))))
+ `(with-current-buffer (get-buffer-create elmo-work-buf-name)
+ (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))))
+ `(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)
+
+(static-if (condition-case nil
+ (plist-get '(one) 'other)
+ (error t))
+ (defmacro elmo-safe-plist-get (plist prop)
+ `(ignore-errors
+ (plist-get ,plist ,prop)))
+ (defalias 'elmo-safe-plist-get 'plist-get))
+
+(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.
(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)))
"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))
-;;;(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)))
(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")
(defun elmo-condition-parse-search-value ()
(cond
((looking-at "\"")
- (elmo-read (current-buffer)))
- ((or (looking-at "yesterday") (looking-at "lastweek")
+ (read (current-buffer)))
+ ((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))
(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)
(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-union (l1 l2)
+ "Make a union of two lists"
+ (elmo-uniq-sorted-list (sort (append l1 l2) #'<)))
+
(defun elmo-list-insert (list element after)
(let* ((match (memq after list))
(rest (and match (cdr (memq after list)))))
(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...
(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
- (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)))
+ (let ((filename (expand-file-name elmo-passwd-alist-file-name
+ elmo-msgdb-directory)))
+ (if (not (file-readable-p filename))
+ ()
+ (with-temp-buffer
+ (let (insert-file-contents-pre-hook ; To avoid autoconv-xmas...
+ insert-file-contents-post-hook)
+ (insert-file-contents filename)
+ (goto-char (point-min))
+ (ignore-errors
+ (read (current-buffer))))))))
(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*")))
- (set-buffer tmp-buffer)
- (erase-buffer)
- (prin1 elmo-passwd-alist tmp-buffer)
- (princ "\n" tmp-buffer)
-;;; (if (and (file-exists-p filename)
+ print-length print-level)
+ (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))
(if (file-writable-p filename)
(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."
(elmo-base64-encode-string pass)))))
(if elmo-passwd-life-time
(run-with-timer elmo-passwd-life-time nil
- (` (lambda () (elmo-remove-passwd (, key))))))
+ `(lambda () (elmo-remove-passwd ,key))))
pass)))
(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)
(directory-files path t "^[^\\.]")
(error nil)))
(result 0.0))
- ;; (result (nth 7 file-attr))) ... directory size
+;;; (result (nth 7 file-attr))) ; ... directory size
(while files
(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."
(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)))
+ "Return a list from L2 in which each element is a member of L1."
+ (let (result)
+ (dolist (element l2)
+ (if (memq element l1)
+ (setq result (cons element result))))
+ (nreverse result)))
(defsubst elmo-list-delete-if-smaller (list number)
(let ((ret-val (copy-sequence list)))
(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
(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)
- "Returns a list (- +). + is bigger than max of LIST1, in LIST2."
- (if (null list2)
- (cons list1 nil)
- (let* ((l1 list1)
- (l2 list2)
- (max-of-l2 (or (nth (max 0 (1- (length l2))) l2) 0))
- diff1 num i percent
- )
- (setq i 0)
- (setq num (+ (length l1)))
- (while l1
- (if (memq (car l1) l2)
- (if (eq (car l1) (car l2))
- (setq l2 (cdr l2))
- (delq (car l1) l2))
- (if (> (car l1) max-of-l2)
- (setq diff1 (nconc diff1 (list (car l1))))))
- (if mes
- (progn
- (setq i (+ i 1))
- (setq percent (/ (* i 100) num))
- (if (eq (% percent 5) 0)
- (elmo-display-progress
- 'elmo-list-bigger-diff "%s%d%%" percent mes))))
- (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)
(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-with-enable-multibyte
+ (encode-mime-charset-string
+ (or (ignore-errors
+ (eword-decode-and-unfold-unstructured-field-body string))
+ string)
+ elmo-mime-charset))))
(defsubst elmo-collect-field (beg end downcase-field-name)
(save-excursion
(setq dest (cons (cons name body) dest))))
dest)))
-(defun elmo-safe-filename (folder)
- (elmo-replace-in-string
- (elmo-replace-in-string
- (elmo-replace-in-string folder "/" " ")
- ":" "__")
- "|" "_or_"))
+(defun elmo-safe-filename (filename)
+ (let* ((replace-alist '(("/" . " ")
+ (":" . "__")
+ ("|" . "_or_")
+ ("\"" . "_Q_")))
+ (regexp (concat "["
+ (regexp-quote (mapconcat 'car replace-alist ""))
+ "]"))
+ (rest filename)
+ converted)
+ (while (string-match regexp rest)
+ (setq converted (concat converted
+ (substring rest 0 (match-beginning 0))
+ (cdr (assoc (substring rest
+ (match-beginning 0)
+ (match-end 0))
+ replace-alist)))
+ rest (substring rest (match-end 0))))
+ (concat converted rest)))
(defvar elmo-filename-replace-chars nil)
(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)
+(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)
(list 'error-message doc
'error-conditions (cons error conds))))))
-(cond ((fboundp 'progress-feedback-with-label)
- (defalias 'elmo-display-progress 'progress-feedback-with-label))
- ((fboundp 'lprogress-display)
- (defalias 'elmo-display-progress 'lprogress-display))
- (t
- (defun elmo-display-progress (label format &optional value &rest args)
- "Print a progress message."
- (if (and (null format) (null args))
- (message nil)
- (apply (function message) (concat format " %d%%")
- (nconc args (list value)))))))
+(defvar elmo-progress-counter nil)
-(defvar elmo-progress-counter-alist nil)
+(defalias 'elmo-progress-counter-label 'car-safe)
(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)))
+ `(aref (cdr ,counter) 0))
(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))))))
+ `(aset (cdr ,counter) 0 ,value))
+
+(defmacro elmo-progress-counter-total (counter)
+ `(aref (cdr ,counter) 1))
+
+(defmacro elmo-progress-counter-set-total (counter value)
+ `(aset (cdr ,counter) 1 ,value))
+
+(defmacro elmo-progress-counter-action (counter)
+ `(aref (cdr ,counter) 2))
+
+(defmacro elmo-progress-counter-set-action (counter action)
+ `(aset (cdr ,counter) 2, action))
+
+(defvar elmo-progress-callback-function nil)
+
+(defun elmo-progress-call-callback (counter &optional value)
+ (when elmo-progress-callback-function
+ (funcall elmo-progress-callback-function
+ (elmo-progress-counter-label counter)
+ (elmo-progress-counter-action counter)
+ (or value
+ (elmo-progress-counter-value counter))
+ (elmo-progress-counter-total counter))))
+
+(defun elmo-progress-start (label total action)
+ (when (and (null elmo-progress-counter)
+ (or (null total)
+ (> total 0)))
+ (let ((counter (cons label (vector 0 total action))))
+ (elmo-progress-call-callback counter 'start)
+ (setq elmo-progress-counter
+ (cond ((null total)
+ counter)
+ ((elmo-progress-call-callback counter 'query)
+ (elmo-progress-call-callback counter)
+ counter)
+ (t
+ t)))
+ counter)))
+
+(defun elmo-progress-clear (counter)
+ (when counter
+ (when (and (elmo-progress-counter-label elmo-progress-counter)
+ (elmo-progress-counter-total elmo-progress-counter))
+ (elmo-progress-call-callback elmo-progress-counter 100))
+ (setq elmo-progress-counter nil)))
+
+(defun elmo-progress-done (counter)
+ (when (elmo-progress-counter-label counter)
+ (elmo-progress-call-callback counter 'done)))
+
+(defun elmo-progress-notify (label &rest params)
+ (when (eq label (elmo-progress-counter-label elmo-progress-counter))
+ (let ((counter elmo-progress-counter))
+ (if (or (elmo-progress-counter-total counter)
+ (and (elmo-progress-counter-set-total
+ counter
+ (elmo-safe-plist-get params :total))
+ (elmo-progress-call-callback counter 'query)))
+ (progn
+ (elmo-progress-counter-set-value
+ counter
+ (or (elmo-safe-plist-get params :set)
+ (+ (elmo-progress-counter-value counter)
+ (or (elmo-safe-plist-get params :inc)
+ (car params)
+ 1))))
+ (elmo-progress-call-callback counter))
+ (setq elmo-progress-counter t)))))
+
+(defmacro elmo-with-progress-display (spec message &rest body)
+ "Evaluate BODY with progress message and return its value.
+SPEC is a list as followed (LABEL TOTAL [VAR]).
+LABEL is an identifier what is specidied by `elmo-progress-notify'.
+If TOTAL is nil, the first `elmo-progress-notify' call must be
+with a `:total' parameter.
+If optional parameter VAR is specified, bind it with a progress counter object.
+MESSAGE is a doing part of progress message."
+ (let ((label (nth 0 spec))
+ (total (nth 1 spec))
+ (var (or (nth 2 spec) (make-symbol "--elmo-progress-temp--"))))
+ `(let ((,var (elmo-progress-start (quote ,label) ,total ,message)))
+ (prog1
+ (unwind-protect
+ (progn
+ ,@body)
+ (elmo-progress-clear ,var))
+ (elmo-progress-done ,var)))))
+
+(put 'elmo-with-progress-display 'lisp-indent-function '2)
+(def-edebug-spec elmo-with-progress-display
+ ((symbolp form &optional symbolp) form &rest form))
(defun elmo-time-expire (before-time diff-time)
(let* ((current (current-time))
(and (eq (car diff) 0)
(< diff-time (nth 1 diff)))))
-(if (fboundp 'std11-fetch-field)
- (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
- (defalias 'elmo-field-body 'std11-field-body))
+(eval-and-compile
+ (if (fboundp 'std11-fetch-field)
+ (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
+ (or (ignore-errors
+ (elmo-with-enable-multibyte
+ (mime-decode-field-body field-body field-name mode)))
+ field-body))))
(defun elmo-address-quote-specials (word)
"Make quoted string of WORD if needed."
(defmacro elmo-string (string)
"STRING without text property."
- (` (let ((obj (copy-sequence (, string))))
- (and obj (set-text-properties 0 (length obj) nil obj))
- obj)))
+ `(let ((obj (copy-sequence ,string)))
+ (and obj (set-text-properties 0 (length obj) nil obj))
+ obj))
(defun elmo-flatten (list-of-list)
"Flatten LIST-OF-LIST."
- (unless (null list-of-list)
- (append (if (and (car list-of-list)
- (listp (car list-of-list)))
- (car list-of-list)
- (list (car list-of-list)))
- (elmo-flatten (cdr list-of-list)))))
+ (and list-of-list
+ (apply #'append
+ (mapcar (lambda (element)
+ (if (listp element) element (list element)))
+ list-of-list))))
(defun elmo-y-or-n-p (prompt &optional auto default)
"Same as `y-or-n-p'.
(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))
- (string= string (car slist)))
- (throw 'found t))
- (setq slist (cdr slist)))))
+ (dolist (element slist)
+ (cond ((null element))
+ ((stringp element)
+ (when (string= string element)
+ (throw 'found t)))
+ ((symbolp element)
+ (when (string= string (symbol-value element))
+ (throw 'found t)))))))
+
+(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))
(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)
+(defconst elmo-quoted-specials-list '(?\\ ?\"))
+
+(defun elmo-quoted-token (string)
+ (concat "\""
+ (std11-wrap-as-quoted-pairs string elmo-quoted-specials-list)
+ "\""))
+
+(defun elmo-token-valid-p (token requirement)
+ (cond ((null requirement))
+ ((stringp requirement)
+ (string-match requirement token))
+ ((functionp requirement)
+ (funcall requirement token))))
+
+(defun elmo-parse-token (string &optional seps requirement)
"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)))
(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)))
+ (let ((atom (if (null content)
+ ""
+ (char-list-to-string (nreverse content)))))
+ (if (elmo-token-valid-p atom requirement)
+ (cons atom (substring string i))
+ (cons "" string))))))
+
+(defun elmo-parse-prefixed-element (prefix string &optional seps requirement)
+ (let (parsed)
+ (if (and (not (eq (length string) 0))
+ (eq (aref string 0) prefix)
+ (setq parsed (elmo-parse-token (substring string 1) seps))
+ (elmo-token-valid-p (car parsed) requirement))
+ parsed
+ (cons "" string))))
+
+(defun elmo-collect-separators (spec)
+ (when (listp spec)
+ (let ((result (elmo-collect-separators-internal spec)))
+ (and result
+ (char-list-to-string (elmo-uniq-list result #'delq))))))
+
+(defun elmo-collect-separators-internal (specs &optional separators)
+ (while specs
+ (let ((spec (car specs)))
+ (cond
+ ((listp spec)
+ (setq separators (elmo-collect-separators-internal spec separators)
+ specs (cdr specs)))
+ ((characterp spec)
+ (setq separators (cons spec separators)
+ specs nil))
+ (t
+ (setq specs nil)))))
+ separators)
+
+(defun elmo-collect-trail-separators (element specs)
+ (cond
+ ((symbolp specs)
+ (eq specs element))
+ ((vectorp specs)
+ (eq (aref specs 0) element))
+ ((listp specs)
+ (let (spec result)
+ (while (setq spec (car specs))
+ (if (setq result (elmo-collect-trail-separators element spec))
+ (setq result (concat (if (stringp result) result)
+ (elmo-collect-separators (cdr specs)))
+ specs nil)
+ (setq specs (cdr specs))))
+ result))))
+
+(defun elmo-parse-separated-tokens (string spec)
+ (let ((result (elmo-parse-separated-tokens-internal string spec)))
+ (if (eq (car result) t)
+ (cons nil (cdr result))
+ result)))
+
+(defun elmo-parse-separated-tokens-internal (string spec &optional separators)
+ (cond
+ ((symbolp spec)
+ (let ((parse (elmo-parse-token string separators)))
+ (cons (list (cons spec (car parse))) (cdr parse))))
+ ((vectorp spec)
+ (let ((parse (elmo-parse-token string separators)))
+ (if (elmo-token-valid-p (car parse) (aref spec 1))
+ (cons (list (cons (aref spec 0) (car parse))) (cdr parse))
+ (cons nil string))))
+ ((characterp spec)
+ (if (and (> (length string) 0)
+ (eq (aref string 0) spec))
+ (cons t (substring string 1))
+ (cons nil string)))
+ ((listp spec)
+ (catch 'unmatch
+ (let ((rest string)
+ result tokens)
+ (while spec
+ (setq result (elmo-parse-separated-tokens-internal
+ rest
+ (car spec)
+ (concat (elmo-collect-separators (cdr spec))
+ separators)))
+ (cond ((null (car result))
+ (throw 'unmatch (cons t string)))
+ ((eq t (car result)))
+ (t
+ (setq tokens (nconc (car result) tokens))))
+ (setq rest (cdr result)
+ spec (cdr spec)))
+ (cons (or tokens t) rest))))))
+
+(defun elmo-quote-syntactical-element (value element syntax)
+ (let ((separators (elmo-collect-trail-separators element syntax)))
+ (if (and separators
+ (string-match (concat "[" separators "]") value))
+ (elmo-quoted-token value)
+ value)))
;;; Number set defined by OKAZAKI Tetsurou <okazaki@be.to>
;;
(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."
(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-map-until-success (function sequence)
+ (let (result)
+ (while (and (null result)
+ sequence)
+ (setq result (funcall function (car sequence))
+ sequence (cdr sequence)))
+ result))
+
+(defun elmo-string-match-substring (regexp string &optional matchn)
+ (when (string-match regexp string)
+ (match-string (or matchn 1) string)))
+
(defun elmo-parse (string regexp &optional matchn)
(or matchn (setq matchn 1))
(let (list)
(match-end matchn)) list)))
(nreverse list)))
+(defun elmo-find-list-match-value (specs getter)
+ (lexical-let ((getter getter))
+ (elmo-map-until-success
+ (lambda (spec)
+ (cond
+ ((symbolp spec)
+ (funcall getter spec))
+ ((consp spec)
+ (lexical-let ((value (funcall getter (car spec))))
+ (when value
+ (elmo-map-until-success
+ (lambda (rule)
+ (cond
+ ((stringp rule)
+ (elmo-string-match-substring rule value))
+ ((consp rule)
+ (elmo-string-match-substring (car rule) value (cdr rule)))))
+ (cdr spec)))))))
+ specs)))
+
;;; File cache.
(defmacro elmo-make-file-cache (path status)
"PATH is the cache file name.
'section means partial section cache exists.
'entire means entire cache exists.
If the cache is partial file-cache, TYPE is 'partial."
- (` (cons (, path) (, status))))
+ `(cons ,path ,status))
(defmacro elmo-file-cache-path (file-cache)
"Returns the file path of the FILE-CACHE."
- (` (car (, file-cache))))
+ `(car ,file-cache))
(defmacro elmo-file-cache-status (file-cache)
"Returns the status of the FILE-CACHE."
- (` (cdr (, file-cache))))
+ `(cdr ,file-cache))
(defsubst elmo-cache-to-msgid (filename)
(concat "<" (elmo-recover-string-from-filename filename) ">"))
(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."
"Return file name for the file-cache corresponds to the section.
PATH is the file-cache path.
SECTION is the section string."
- (` (expand-file-name (or (, section) "") (, path))))
+ `(expand-file-name (or ,section "") ,path))
(defun elmo-file-cache-delete (path)
"Delete a cache on PATH."
(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)
(cons (car (car cfl))
(car flist)))))
(setq cfl (cdr cfl)))
-;;; (prin1 firsts)
+;;; (prin1 firsts)
(while firsts
(if (and (not oldest-entity)
(cdr (cdr (car firsts))))
oldest-entity))
(defun elmo-cache-get-sorted-cache-file-list ()
- (let ((dirs (directory-files
- elmo-cache-directory
- t "^[^\\.]"))
- (i 0) num
- elist
- ret-val)
- (setq num (length dirs))
- (message "Collecting cache info...")
- (while dirs
- (setq elist (mapcar (lambda (x)
- (elmo-cache-make-file-entity x (car dirs)))
- (directory-files (car dirs) nil "^[^\\.]")))
- (setq ret-val (append ret-val
- (list (cons
- (car dirs)
- (sort
- elist
- (lambda (x y)
- (< (cdr x)
- (cdr y))))))))
- (when (> num elmo-display-progress-threshold)
- (setq i (+ i 1))
- (elmo-display-progress
- 'elmo-cache-get-sorted-cache-file-list "Collecting cache info..."
- (/ (* i 100) num)))
- (setq dirs (cdr dirs)))
- (message "Collecting cache info...done")
+ (let ((dirs (directory-files elmo-cache-directory t "^[^\\.]"))
+ elist ret-val)
+ (elmo-with-progress-display (elmo-collecting-cache (length dirs))
+ "Collecting cache info"
+ (dolist (dir dirs)
+ (setq elist (mapcar (lambda (x)
+ (elmo-cache-make-file-entity x dir))
+ (directory-files dir nil "^[^\\.]")))
+ (setq ret-val (append ret-val
+ (list (cons
+ dir
+ (sort
+ elist
+ (lambda (x y)
+ (< (cdr x)
+ (cdr y))))))))))
ret-val))
(defun elmo-cache-expire-by-age (&optional days)
- (let ((age (or (and days (int-to-string days))
+ "Expire cache file by age.
+Optional argument DAYS specifies the days to expire caches."
+ (interactive)
+ (let ((age (or (and days (number-to-string days))
(and (interactive-p)
(read-from-minibuffer
(format "Enter days (%s): "
elmo-cache-expire-default-age)))
- (int-to-string elmo-cache-expire-default-age)))
+ (number-to-string elmo-cache-expire-default-age)))
(dirs (directory-files
elmo-cache-directory
t "^[^\\.]"))
curtime)
(if (string= age "")
(setq age elmo-cache-expire-default-age)
- (setq age (string-to-int age)))
+ (setq age (string-to-number age)))
(setq curtime (current-time))
(setq curtime (+ (* (nth 0 curtime)
(float 65536)) (nth 1 curtime)))
;;;
;; 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)
(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.
(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)))))
+ (elmo-delete-cr-buffer))))
+
+;;
+;; 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.")
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))
projects / elisp / wanderlust.git / blobdiff