;;; Code:
;;
-(eval-when-compile (require 'cl))
+(eval-when-compile
+ (require 'cl)
+ (require 'static))
(require 'elmo-vars)
(require 'elmo-date)
(require 'mcharset)
(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)))
+(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))
- (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
(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."
nil
(with-temp-buffer
(insert-file-contents-as-binary filename)
- (let ((coding-system (or (funcall set-auto-coding-function
- filename
- (- (point-max) (point-min)))
+ (let ((coding-system (or (elmo-set-auto-coding)
(mime-charset-to-coding-system
mime-charset))))
(when coding-system
(defun elmo-condition-optimize (condition)
(cond
((vectorp condition)
- (or (cdr (assoc (elmo-filter-key condition)
- '(("first" . 0)
- ("last" . 0)
- ("flag" . 1)
- ("body" . 3))))
- 2))
+ (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))))
(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)))))
(defvar elmo-passwd-alist nil)
(defun elmo-passwd-alist-load ()
- (with-temp-buffer
- (let ((filename (expand-file-name elmo-passwd-alist-file-name
- elmo-msgdb-directory))
- insert-file-contents-pre-hook ; To avoid autoconv-xmas...
- insert-file-contents-post-hook
- ret-val)
- (if (not (file-readable-p filename))
- ()
- (insert-file-contents filename)
- (condition-case nil
- (read (current-buffer))
- (error nil nil))))))
+ (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."
print-length print-level)
(prin1 elmo-passwd-alist (current-buffer))
(princ "\n" (current-buffer))
-;;; (if (and (file-exists-p filename)
+;;; (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)
(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)
(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)))
))))
(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 list1 (cdr list1)))
(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-get-hash-val (string hashtable)
(static-if (fboundp 'unintern)
`(symbol-value (intern-soft ,string ,hashtable))
(and string
(elmo-with-enable-multibyte
(encode-mime-charset-string
- (eword-decode-and-unfold-unstructured-field-body 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)
(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))
(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)))
(defun elmo-decoded-field-body (field-name &optional mode)
(let ((field-body (elmo-field-body field-name)))
(and field-body
- (elmo-with-enable-multibyte
- (mime-decode-field-body field-body field-name mode)))))
+ (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)))))
+ (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-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)))
+(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>
;;
prev
(nconc
(list
- ;; (beg . (1- number))
+;;; (beg . (1- number))
(let ((new (cons (car elem) (1- number))))
(if (eq (car new) (cdr new))
(car new)
new))
- ;; ((1+ number) . end)
+;;; ((1+ number) . end)
(let ((new (cons (1+ number) (cdr elem))))
(if (eq (car new) (cdr new))
(car new)
(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."
(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)))
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
projects / elisp / wanderlust.git / blobdiff