(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
+(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)
(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))
- (set-buffer-multibyte default-enable-multibyte-characters)
- (erase-buffer)
- (,@ body))))
+ `(save-excursion
+ (set-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
- (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.
"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" "Flag"
- "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))))
- ((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 "$")
- 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))
(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")
(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))
(replace-match "\n"))
(buffer-string))))
+(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))
(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."
(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))
(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 nil (elmo-remove-passwd ,key))))
pass)))
(defun elmo-remove-passwd (key)
))))
(defun elmo-list-filter (l1 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))
+ "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 "%s" 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 "%sdone" mes))
(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
- (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 (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-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))
- (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)
(static-if (fboundp 'unintern)
`(symbol-value (intern-soft ,string ,hashtable))
(defsubst elmo-mime-string (string)
"Normalize MIME encoded STRING."
(and string
- (elmo-set-work-buf
- (set-buffer-multibyte default-enable-multibyte-characters)
- (setq string
- (encode-mime-charset-string
- (eword-decode-and-unfold-unstructured-field-body
- string)
- elmo-mime-charset))
- (set-buffer-multibyte nil)
- 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)
(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
- (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)))))
+ ((symbolp form &optional symbolp) form &rest form))
(defun elmo-time-expire (before-time diff-time)
(let* ((current (current-time))
(defun elmo-decoded-field-body (field-name &optional mode)
(let ((field-body (elmo-field-body field-name)))
(and field-body
- (elmo-set-work-buf
- (mime-decode-field-body field-body field-name mode)))))
+ (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'.
(defun elmo-string-member (string 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))
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)
(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) ">"))
"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."
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)
+ "Expire cache file by age.
+Optional argument DAYS specifies the days to expire caches."
+ (interactive)
(let ((age (or (and days (int-to-string days))
(and (interactive-p)
(read-from-minibuffer
(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)
file nil beg
(incf beg elmo-msgdb-file-header-chop-length))))
(prog1 (not (search-forward "\n\n" nil t))
- (goto-char (point-max))))))))
+ (goto-char (point-max)))))
+ (elmo-delete-cr-buffer))))
;;
;; overview handling
(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.")