X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=elmo%2Felmo-util.el;h=5147fa853c9212f008dbfbbb4b2c2f5b9e513188;hb=221c9217efb7a56f122c2389864b7b3958afec1a;hp=feecd124e4867fe267a48e0b31404e9eaeeb42d4;hpb=8e6795e82e1498243ed69ef03c69bf7a70944cd8;p=elisp%2Fwanderlust.git diff --git a/elmo/elmo-util.el b/elmo/elmo-util.el index feecd12..5147fa8 100644 --- a/elmo/elmo-util.el +++ b/elmo/elmo-util.el @@ -29,7 +29,9 @@ ;;; Code: ;; -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (require 'static)) (require 'elmo-vars) (require 'elmo-date) (require 'mcharset) @@ -60,29 +62,28 @@ (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)) + `(save-excursion + (with-current-buffer (get-buffer-create elmo-work-buf-name) (set-buffer-multibyte default-enable-multibyte-characters) (erase-buffer) - (,@ body)))) + ,@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 @@ -98,6 +99,14 @@ (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)) @@ -162,7 +171,7 @@ with FILENAME which defaults to `buffer-file-name'." (goto-char (point-min)) (setq case-fold-search nil) (re-search-forward "^;;;coding system: " - ;;(+ (point-min) 3000) t)) +;;; (+ (point-min) 3000) t)) nil t)) (looking-at "[^\t\n\r ]+") (find-coding-system @@ -476,6 +485,10 @@ Return value is a cons cell of (STRUCTURE . REST)" (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))))) @@ -530,18 +543,17 @@ Return value is a cons cell of (STRUCTURE . REST)" (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." @@ -560,7 +572,7 @@ Return value is a cons cell of (STRUCTURE . REST)" 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) @@ -586,7 +598,7 @@ Return value is a cons cell of (STRUCTURE . REST)" (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) @@ -814,7 +826,7 @@ Return value is a cons cell of (STRUCTURE . REST)" (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))) @@ -935,34 +947,6 @@ the directory becomes empty after deletion." (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)) @@ -1186,82 +1170,107 @@ If optional DELETE-FUNCTION is speficied, it is used as delete procedure." (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)) @@ -1274,9 +1283,10 @@ SPEC is a list as followed (LABEL MAX-VALUE [FORMAT])." (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))) @@ -1301,17 +1311,17 @@ SPEC is a list as followed (LABEL MAX-VALUE [FORMAT])." (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." - (if list-of-list - (apply #'nconc - (mapcar (lambda (element) - (if (consp element) element (list element))) - 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'. @@ -1704,12 +1714,12 @@ NUMBER-SET is altered." 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) @@ -1857,15 +1867,15 @@ STATUS is one of 'section, 'entire or nil. '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) ">")) @@ -1902,7 +1912,7 @@ 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." @@ -2064,7 +2074,7 @@ If KBYTES is kilo bytes (This value must be float)." (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)))) @@ -2080,42 +2090,34 @@ If KBYTES is kilo bytes (This value must be float)." 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 "^[^\\.]")) @@ -2123,7 +2125,7 @@ If KBYTES is kilo bytes (This value must be float)." 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))) @@ -2268,7 +2270,8 @@ If ALIST is nil, `elmo-obsolete-variable-alist' is used." 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