1 ;;; elmo-util.el --- Utilities for ELMO.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Keywords: mail, net news
8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
32 (eval-when-compile (require 'cl))
38 (require 'eword-decode)
43 (defmacro elmo-set-buffer-multibyte (flag)
44 "Set the multibyte flag of the current buffer to FLAG."
46 (list 'setq 'mc-flag flag))
49 ((and (boundp 'emacs-major-version) (>= emacs-major-version 20))
50 (list 'set-buffer-multibyte flag))
54 (defvar elmo-work-buf-name " *elmo work*")
55 (defvar elmo-temp-buf-name " *elmo temp*")
57 (or (boundp 'default-enable-multibyte-characters)
58 (defvar default-enable-multibyte-characters (featurep 'mule)
59 "The mock variable except for Emacs 20."))
61 (defun elmo-base64-encode-string (string &optional no-line-break))
62 (defun elmo-base64-decode-string (string))
64 ;; base64 encoding/decoding
66 (fset 'elmo-base64-encode-string
67 (mel-find-function 'mime-encode-string "base64"))
68 (fset 'elmo-base64-decode-string
69 (mel-find-function 'mime-decode-string "base64"))
71 ;; Any Emacsen may have add-name-to-file(), because loadup.el requires it. :-p
72 ;; Check make-symbolic-link() instead. -- 981002 by Fuji
73 (if (fboundp 'make-symbolic-link) ;; xxx
74 (defalias 'elmo-add-name-to-file 'add-name-to-file)
75 (defun elmo-add-name-to-file
76 (filename newname &optional ok-if-already-exists)
77 (copy-file filename newname ok-if-already-exists t)))
79 (defmacro elmo-set-work-buf (&rest body)
80 "Execute BODY on work buffer. Work buffer remains."
82 (set-buffer (get-buffer-create elmo-work-buf-name))
83 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
87 (defmacro elmo-bind-directory (dir &rest body)
88 "Set current directory DIR and execute BODY."
89 (` (let ((default-directory (file-name-as-directory (, dir))))
92 (defun elmo-object-load (filename &optional mime-charset no-err)
93 "Load OBJECT from the file specified by FILENAME.
94 File content is decoded with MIME-CHARSET."
95 (if (not (file-readable-p filename))
99 (insert-file-contents filename))
101 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
102 (decode-mime-charset-region (point-min) (point-max) mime-charset))
104 (read (current-buffer))
105 (error (unless no-err
106 (message "Warning: Loading object from %s failed."
108 (elmo-object-save filename nil))
111 (defsubst elmo-save-buffer (filename &optional mime-charset)
112 "Save current buffer to the file specified by FILENAME.
113 Directory of the file is created if it doesn't exist.
114 File content is encoded with MIME-CHARSET."
115 (let ((dir (directory-file-name (file-name-directory filename))))
116 (if (file-directory-p dir)
118 (unless (file-exists-p dir)
119 (elmo-make-directory dir)))
120 (if (file-writable-p filename)
123 ;;; (elmo-set-buffer-multibyte default-enable-multibyte-characters)
124 (encode-mime-charset-region (point-min) (point-max) mime-charset))
125 (as-binary-output-file
126 (write-region (point-min) (point-max) filename nil 'no-msg)))
127 (message "%s is not writable." filename))))
129 (defun elmo-object-save (filename object &optional mime-charset)
130 "Save OBJECT to the file specified by FILENAME.
131 Directory of the file is created if it doesn't exist.
132 File content is encoded with MIME-CHARSET."
134 (let (print-length print-level)
135 (prin1 object (current-buffer)))
136 ;;;(princ "\n" (current-buffer))
137 (elmo-save-buffer filename mime-charset)))
141 (defconst elmo-condition-atom-regexp "[^/ \")|&]*")
143 (defun elmo-read-search-condition (default)
144 "Read search condition string interactively."
145 (elmo-read-search-condition-internal "Search by" default))
147 (defun elmo-read-search-condition-internal (prompt default)
148 (let* ((completion-ignore-case t)
149 (field (completing-read
150 (format "%s (%s): " prompt default)
153 "Last" "First" "Flag"
154 "From" "Subject" "To" "Cc" "Body"
155 "Since" "Before" "ToCc"
156 "!From" "!Subject" "!To" "!Cc" "!Body"
157 "!Since" "!Before" "!ToCc")
158 elmo-msgdb-extra-fields))))
160 (setq field (if (string= field "")
164 ((or (string= field "AND") (string= field "OR"))
166 (elmo-read-search-condition-internal
167 (concat field "(1) Search by") default)
168 (if (string= field "AND") "&" "|")
169 (elmo-read-search-condition-internal
170 (concat field "(2) Search by") default)
172 ((string-match "Since\\|Before" field)
173 (let ((default (format-time-string "%Y-%m-%d")))
174 (setq value (completing-read
175 (format "Value for '%s' [%s]: " field default)
178 (list (format "%s" (car x)))))
179 elmo-date-descriptions)))
180 (concat (downcase field) ":"
181 (if (equal value "") default value))))
182 ((string= field "Flag")
183 (setq value (completing-read
184 (format "Value for '%s': " field)
186 '("unread" "important" "answered" "digest" "any"))))
187 (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
189 (setq value (prin1-to-string value)))
190 (concat (downcase field) ":" value))
192 (setq value (read-from-minibuffer (format "Value for '%s': " field)))
193 (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
195 (setq value (prin1-to-string value)))
196 (concat (downcase field) ":" value)))))
198 (defsubst elmo-condition-parse-error ()
199 (error "Syntax error in '%s'" (buffer-string)))
201 (defun elmo-parse-search-condition (condition)
203 Return value is a cons cell of (STRUCTURE . REST)"
206 (goto-char (point-min))
207 (cons (elmo-condition-parse) (buffer-substring (point) (point-max)))))
209 ;; condition ::= or-expr
210 (defun elmo-condition-parse ()
211 (or (elmo-condition-parse-or-expr)
212 (elmo-condition-parse-error)))
214 ;; or-expr ::= and-expr /
215 ;; and-expr "|" or-expr
216 (defun elmo-condition-parse-or-expr ()
217 (let ((left (elmo-condition-parse-and-expr)))
218 (if (looking-at "| *")
220 (goto-char (match-end 0))
221 (list 'or left (elmo-condition-parse-or-expr)))
224 ;; and-expr ::= primitive /
225 ;; primitive "&" and-expr
226 (defun elmo-condition-parse-and-expr ()
227 (let ((left (elmo-condition-parse-primitive)))
228 (if (looking-at "& *")
230 (goto-char (match-end 0))
231 (list 'and left (elmo-condition-parse-and-expr)))
234 ;; primitive ::= "(" expr ")" /
235 ;; ["!"] search-key SPACE* ":" SPACE* search-value
236 (defun elmo-condition-parse-primitive ()
239 (goto-char (match-end 0))
240 (prog1 (elmo-condition-parse)
241 (unless (looking-at ") *")
242 (elmo-condition-parse-error))
243 (goto-char (match-end 0))))
244 ;; search-key ::= [A-Za-z-]+
245 ;; ;; "since" / "before" / "last" / "first" /
246 ;; ;; "body" / "mark" / field-name
247 ((looking-at "\\(!\\)? *\\([A-Za-z-]+\\) *: *")
248 (goto-char (match-end 0))
249 (let ((search-key (vector
250 (if (match-beginning 1) 'unmatch 'match)
251 (elmo-match-buffer 2)
252 (elmo-condition-parse-search-value))))
254 (if (string= (aref search-key 1) "tocc")
255 (if (eq (aref search-key 0) 'match)
257 (vector 'match "to" (aref search-key 2))
258 (vector 'match "cc" (aref search-key 2)))
260 (vector 'unmatch "to" (aref search-key 2))
261 (vector 'unmatch "cc" (aref search-key 2))))
264 ;; search-value ::= quoted / time / number / atom
265 ;; quoted ::= <elisp string expression>
266 ;; time ::= "yesterday" / "lastweek" / "lastmonth" / "lastyear" /
267 ;; number SPACE* "daysago" /
268 ;; number "-" month "-" number ; ex. 10-May-2000
269 ;; number "-" number "-" number ; ex. 2000-05-10
271 ;; month ::= "Jan" / "Feb" / "Mar" / "Apr" / "May" / "Jun" /
272 ;; "Jul" / "Aug" / "Sep" / "Oct" / "Nov" / "Dec"
273 ;; atom ::= ATOM_CHARS*
274 ;; SPACE ::= <ascii space character, 0x20>
275 ;; ATOM_CHARS ::= <any character except specials>
276 ;; specials ::= SPACE / <"> / </> / <)> / <|> / <&>
277 ;; ;; These characters should be quoted.
278 (defun elmo-condition-parse-search-value ()
281 (read (current-buffer)))
282 ((or (looking-at "yesterday") (looking-at "lastweek")
283 (looking-at "lastmonth") (looking-at "lastyear")
284 (looking-at "[0-9]+ *daysago")
285 (looking-at "[0-9]+-[A-Za-z]+-[0-9]+")
286 (looking-at "[0-9]+-[0-9]+-[0-9]+")
287 (looking-at "[0-9]+")
288 (looking-at elmo-condition-atom-regexp))
289 (prog1 (elmo-match-buffer 0)
290 (goto-char (match-end 0))))
291 (t (error "Syntax error '%s'" (buffer-string)))))
294 (defsubst elmo-buffer-replace (regexp &optional newtext)
295 (goto-char (point-min))
296 (while (re-search-forward regexp nil t)
297 (replace-match (or newtext ""))))
299 (defsubst elmo-delete-char (char string &optional unibyte)
302 (let ((coding-system-for-read 'no-conversion)
303 (coding-system-for-write 'no-conversion))
304 (if unibyte (elmo-set-buffer-multibyte nil))
306 (goto-char (point-min))
307 (while (search-forward (char-to-string char) nil t)
311 (defsubst elmo-delete-cr-buffer ()
312 "Delete CR from buffer."
314 (goto-char (point-min))
315 (while (search-forward "\r\n" nil t)
316 (replace-match "\n")) ))
318 (defsubst elmo-delete-cr-get-content-type ()
320 (goto-char (point-min))
321 (while (search-forward "\r\n" nil t)
322 (replace-match "\n"))
323 (goto-char (point-min))
324 (or (std11-field-body "content-type")
327 (defun elmo-delete-cr (string)
331 (goto-char (point-min))
332 (while (search-forward "\r\n" nil t)
333 (replace-match "\n"))
336 (defun elmo-uniq-list (lst &optional delete-function)
337 "Distractively uniqfy elements of LST."
338 (setq delete-function (or delete-function #'delete))
344 (funcall delete-function
349 (defun elmo-list-insert (list element after)
350 (let* ((match (memq after list))
351 (rest (and match (cdr (memq after list)))))
354 (setcdr match (list element))
356 (nconc list (list element)))))
358 (defun elmo-string-partial-p (string)
359 (and (stringp string) (string-match "message/partial" string)))
361 (defun elmo-get-file-string (filename &optional remove-final-newline)
363 (let (insert-file-contents-pre-hook ; To avoid autoconv-xmas...
364 insert-file-contents-post-hook)
365 (when (file-exists-p filename)
367 (as-binary-input-file (insert-file-contents filename)))
368 (when (and remove-final-newline
370 (= (char-after (1- (point-max))) ?\n))
371 (goto-char (point-max))
372 (delete-backward-char 1))
375 (defun elmo-save-string (string filename)
378 (as-binary-output-file
380 (write-region (point-min) (point-max)
381 filename nil 'no-msg))
384 (defun elmo-max-of-list (nlist)
388 (if (< max-num (car l))
389 (setq max-num (car l)))
393 (defun elmo-concat-path (path filename)
394 (if (not (string= path ""))
395 (if (string= elmo-path-sep (substring path (- (length path) 1)))
396 (concat path filename)
397 (concat path elmo-path-sep filename))
400 (defvar elmo-passwd-alist nil)
402 (defun elmo-passwd-alist-load ()
404 (let ((filename (expand-file-name elmo-passwd-alist-file-name
405 elmo-msgdb-directory))
406 (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))
407 insert-file-contents-pre-hook ; To avoid autoconv-xmas...
408 insert-file-contents-post-hook
410 (if (not (file-readable-p filename))
412 (set-buffer tmp-buffer)
413 (insert-file-contents filename)
416 (read (current-buffer))
418 (kill-buffer tmp-buffer)
421 (defun elmo-passwd-alist-clear ()
422 "Clear password cache."
424 (setq elmo-passwd-alist nil))
426 (defun elmo-passwd-alist-save ()
427 "Save password into file."
430 (let ((filename (expand-file-name elmo-passwd-alist-file-name
431 elmo-msgdb-directory))
432 (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))
433 print-length print-level)
434 (set-buffer tmp-buffer)
436 (prin1 elmo-passwd-alist tmp-buffer)
437 (princ "\n" tmp-buffer)
438 ;;; (if (and (file-exists-p filename)
439 ;;; (not (equal 384 (file-modes filename))))
440 ;;; (error "%s is not safe.chmod 600 %s!" filename filename))
441 (if (file-writable-p filename)
443 (write-region (point-min) (point-max)
444 filename nil 'no-msg)
445 (set-file-modes filename 384))
446 (message "%s is not writable." filename))
447 (kill-buffer tmp-buffer))))
449 (defun elmo-get-passwd (key)
450 "Get password from password pool."
452 (if (not elmo-passwd-alist)
453 (setq elmo-passwd-alist (elmo-passwd-alist-load)))
454 (setq pair (assoc key elmo-passwd-alist))
456 (elmo-base64-decode-string (cdr pair))
457 (setq pass (elmo-read-passwd (format "Password for %s: "
459 (setq elmo-passwd-alist
460 (append elmo-passwd-alist
462 (elmo-base64-encode-string pass)))))
463 (if elmo-passwd-life-time
464 (run-with-timer elmo-passwd-life-time nil
465 (` (lambda () (elmo-remove-passwd (, key))))))
468 (defun elmo-remove-passwd (key)
469 "Remove password from password pool (for failure)."
471 (if (setq pass-cons (assoc key elmo-passwd-alist))
474 (fillarray (cdr pass-cons) 0))
475 (setq elmo-passwd-alist
476 (delete pass-cons elmo-passwd-alist))))))
478 (defmacro elmo-read-char-exclusive ()
479 (cond ((featurep 'xemacs)
480 '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?)
485 (key-press-event-p (setq event (next-command-event)))
486 (setq key (or (event-to-character event)
487 (cdr (assq (event-key event) table)))))))
489 ((fboundp 'read-char-exclusive)
490 '(read-char-exclusive))
494 (defun elmo-read-passwd (prompt &optional stars)
495 "Read a single line of text from user without echoing, and return it."
499 (cursor-in-echo-area t)
500 (log-message-max-size 0)
501 message-log-max done msg truncate)
503 (if (or (not stars) (string= "" ans))
505 (setq msg (concat prompt (make-string (length ans) ?.)))
507 (1+ (- (length msg) (window-width (minibuffer-window)))))
509 (setq msg (concat "$" (substring msg (1+ truncate))))))
511 (setq c (elmo-read-char-exclusive))
515 ((or (= c ?\r) (= c ?\n) (= c ?\e))
519 ((and (/= c ?\b) (/= c ?\177))
520 (setq ans (concat ans (char-to-string c))))
522 (setq ans (substring ans 0 -1)))))
531 (defun elmo-string-to-list (string)
534 (goto-char (point-min))
536 (goto-char (point-max))
538 (goto-char (point-min))
539 (read (current-buffer))))
541 (defun elmo-list-to-string (list)
550 (if (symbolp (car tlist))
551 (symbol-name (car tlist))
556 (setq tlist (cdr tlist)))
566 (defun elmo-plug-on-by-servers (alist &optional servers)
567 (let ((server-list (or servers elmo-plug-on-servers)))
570 (if (elmo-plugged-p (car server-list))
572 (setq server-list (cdr server-list))))))
574 (defun elmo-plug-on-by-exclude-servers (alist &optional servers)
575 (let ((server-list (or servers elmo-plug-on-exclude-servers))
576 server other-servers)
578 (when (and (not (member (setq server (caaar alist)) server-list))
579 (not (member server other-servers)))
580 (push server other-servers))
581 (setq alist (cdr alist)))
582 (elmo-plug-on-by-servers alist other-servers)))
584 (defun elmo-plugged-p (&optional server port stream-type alist label-exp)
585 (let ((alist (or alist elmo-plugged-alist))
587 (cond ((and (not port) (not server))
588 (cond ((eq elmo-plugged-condition 'one)
592 (if (nth 2 (car alist))
594 (setq alist (cdr alist))))
596 ((eq elmo-plugged-condition 'all)
600 (if (not (nth 2 (car alist)))
601 (throw 'plugged nil))
602 (setq alist (cdr alist)))
605 ((functionp elmo-plugged-condition)
606 (funcall elmo-plugged-condition alist))
609 ((not port) ;; server
612 (when (string= server (caaar alist))
613 (if (nth 2 (car alist))
615 (setq alist (cdr alist)))))
617 (setq plugged-info (assoc (list server port stream-type) alist))
618 (if (not plugged-info)
619 ;; add elmo-plugged-alist automatically
621 (elmo-set-plugged elmo-plugged server port stream-type
622 nil nil nil label-exp)
624 (if (and elmo-auto-change-plugged
625 (> elmo-auto-change-plugged 0)
626 (nth 3 plugged-info) ;; time
627 (elmo-time-expire (nth 3 plugged-info)
628 elmo-auto-change-plugged))
630 (nth 2 plugged-info)))))))
632 (defun elmo-set-plugged (plugged &optional server port stream-type time
634 (let ((alist (or alist elmo-plugged-alist))
636 (cond ((and (not port) (not server))
637 (setq elmo-plugged plugged)
638 ;; set plugged all element of elmo-plugged-alist.
640 (setcdr (cdar alist) (list plugged time))
641 (setq alist (cdr alist))))
643 ;; set plugged all port of server
645 (when (string= server (caaar alist))
646 (setcdr (cdar alist) (list plugged time)))
647 (setq alist (cdr alist))))
649 ;; set plugged one port of server
650 (setq plugged-info (assoc (list server port stream-type) alist))
651 (setq label (if label-exp
653 (nth 1 plugged-info)))
655 ;; if add is non-nil, don't reset plug state.
657 (setcdr plugged-info (list label plugged time)))
659 (setq elmo-plugged-alist
663 (list (list server port stream-type)
664 label plugged time))))))))
667 (defun elmo-delete-plugged (&optional server port alist)
668 (let* ((alist (or alist elmo-plugged-alist))
670 (cond ((and (not port) (not server))
673 ;; delete plugged all port of server
675 (when (string= server (caaar alist2))
676 (setq alist (delete (car alist2) alist)))
677 (setq alist2 (cdr alist2))))
679 ;; delete plugged one port of server
681 (delete (assoc (cons server port) alist) alist))))
684 (defun elmo-disk-usage (path)
685 "Get disk usage (bytes) in PATH."
687 (condition-case () (file-attributes path) (error nil))))
689 (if (nth 0 file-attr) ; directory
690 (let ((files (condition-case ()
691 (directory-files path t "^[^\\.]")
694 ;; (result (nth 7 file-attr))) ... directory size
696 (setq result (+ result (or (elmo-disk-usage (car files)) 0)))
697 (setq files (cdr files)))
699 (float (nth 7 file-attr)))
702 (defun elmo-get-last-accessed-time (path &optional dir)
703 "Return the last accessed time of PATH."
704 (let ((last-accessed (nth 4 (file-attributes (or (and dir
709 (setq last-accessed (+ (* (nth 0 last-accessed)
710 (float 65536)) (nth 1 last-accessed)))
713 (defun elmo-get-last-modification-time (path &optional dir)
714 "Return the last accessed time of PATH."
715 (let ((last-modified (nth 5 (file-attributes (or (and dir
719 (setq last-modified (+ (* (nth 0 last-modified)
720 (float 65536)) (nth 1 last-modified)))))
722 (defun elmo-make-directory (path &optional mode)
723 "Create directory recursively."
724 (let ((parent (directory-file-name (file-name-directory path))))
725 (if (null (file-directory-p parent))
726 (elmo-make-directory parent))
727 (make-directory path)
728 (set-file-modes path (or mode
729 (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700
731 (defun elmo-delete-directory (path &optional no-hierarchy)
732 "Delete directory recursively."
733 (if (stringp path) ; nil is not permitted.
734 (let ((dirent (directory-files path))
735 relpath abspath hierarchy)
737 (setq relpath (car dirent)
739 abspath (expand-file-name relpath path))
740 (when (not (string-match "^\\.\\.?$" relpath))
741 (if (eq (nth 0 (file-attributes abspath)) t)
744 (elmo-delete-directory abspath no-hierarchy))
745 (delete-file abspath))))
747 (delete-directory path)))))
749 (defun elmo-delete-match-files (path regexp &optional remove-if-empty)
750 "Delete directory files specified by PATH.
751 If optional REMOVE-IF-EMPTY is non-nil, delete directory itself if
752 the directory becomes empty after deletion."
753 (when (stringp path) ; nil is not permitted.
754 (dolist (file (directory-files path t regexp))
758 (delete-directory path) ; should be removed if empty.
761 (defun elmo-list-filter (l1 l2)
762 "Rerurn a list from L2 in which each element is a member of L1."
763 (elmo-delete-if (lambda (x) (not (memq x l1))) l2))
765 (defsubst elmo-list-delete-if-smaller (list number)
766 (let ((ret-val (copy-sequence list)))
768 (if (< (car list) number)
769 (setq ret-val (delq (car list) ret-val)))
770 (setq list (cdr list)))
773 (defun elmo-list-diff (list1 list2 &optional mes)
776 (let ((clist1 (copy-sequence list1))
777 (clist2 (copy-sequence list2)))
779 (setq clist1 (delq (car list2) clist1))
780 (setq list2 (cdr list2)))
782 (setq clist2 (delq (car list1) clist2))
783 (setq list1 (cdr list1)))
785 (message "%sdone" mes))
786 (list clist1 clist2)))
788 (defun elmo-list-bigger-diff (list1 list2 &optional mes)
789 "Returns a list (- +). + is bigger than max of LIST1, in LIST2."
794 (max-of-l2 (or (nth (max 0 (1- (length l2))) l2) 0))
798 (setq num (+ (length l1)))
800 (if (memq (car l1) l2)
801 (if (eq (car l1) (car l2))
804 (if (> (car l1) max-of-l2)
805 (setq diff1 (nconc diff1 (list (car l1))))))
809 (setq percent (/ (* i 100) num))
810 (if (eq (% percent 5) 0)
811 (elmo-display-progress
812 'elmo-list-bigger-diff "%s%d%%" percent mes))))
814 (cons diff1 (list l2)))))
816 (defmacro elmo-filter-condition-p (filter)
817 `(or (vectorp ,filter) (consp ,filter)))
819 (defmacro elmo-filter-type (filter)
820 (` (aref (, filter) 0)))
822 (defmacro elmo-filter-key (filter)
823 (` (aref (, filter) 1)))
825 (defmacro elmo-filter-value (filter)
826 (` (aref (, filter) 2)))
828 (defsubst elmo-buffer-field-primitive-condition-match (condition
832 (goto-char (point-min))
834 ((string= (elmo-filter-key condition) "last")
835 (setq result (<= (length (memq number number-list))
836 (string-to-int (elmo-filter-value condition)))))
837 ((string= (elmo-filter-key condition) "first")
838 (setq result (< (- (length number-list)
839 (length (memq number number-list)))
840 (string-to-int (elmo-filter-value condition)))))
841 ((string= (elmo-filter-key condition) "since")
842 (let ((field-date (elmo-date-make-sortable-string
844 (std11-field-body "date")
845 (current-time-zone) nil)))
846 (specified-date (elmo-date-make-sortable-string
847 (elmo-date-get-datevec
848 (elmo-filter-value condition)))))
850 (or (string= field-date specified-date)
851 (string< specified-date field-date)))))
852 ((string= (elmo-filter-key condition) "before")
855 (elmo-date-make-sortable-string
857 (std11-field-body "date")
858 (current-time-zone) nil))
859 (elmo-date-make-sortable-string
860 (elmo-date-get-datevec
861 (elmo-filter-value condition))))))
862 ((string= (elmo-filter-key condition) "body")
863 (and (re-search-forward "^$" nil t) ; goto body
864 (setq result (search-forward (elmo-filter-value condition)
867 (dolist (fval (elmo-multiple-field-body (elmo-filter-key condition)))
868 (if (eq (length fval) 0) (setq fval nil))
869 (if fval (setq fval (eword-decode-string fval)))
870 (setq result (or result
871 (and fval (string-match
872 (elmo-filter-value condition) fval)))))))
873 (if (eq (elmo-filter-type condition) 'unmatch)
874 (setq result (not result)))
877 (defun elmo-condition-in-msgdb-p-internal (condition fields)
880 (if (not (member (elmo-filter-key condition) fields))
882 ((or (eq (car condition) 'and)
883 (eq (car condition) 'or))
884 (elmo-condition-in-msgdb-p-internal (nth 1 condition) fields)
885 (elmo-condition-in-msgdb-p-internal (nth 2 condition) fields))))
887 (defun elmo-condition-in-msgdb-p (condition)
889 (elmo-condition-in-msgdb-p-internal condition
891 elmo-msgdb-extra-fields
892 '("last" "first" "from"
893 "subject" "to" "cc" "since"
896 (defun elmo-buffer-field-condition-match (condition number number-list)
899 (elmo-buffer-field-primitive-condition-match
900 condition number number-list))
901 ((eq (car condition) 'and)
902 (and (elmo-buffer-field-condition-match
903 (nth 1 condition) number number-list)
904 (elmo-buffer-field-condition-match
905 (nth 2 condition) number number-list)))
906 ((eq (car condition) 'or)
907 (or (elmo-buffer-field-condition-match
908 (nth 1 condition) number number-list)
909 (elmo-buffer-field-condition-match
910 (nth 2 condition) number number-list)))))
912 (defsubst elmo-file-field-primitive-condition-match (file
917 (goto-char (point-min))
919 ((string= (elmo-filter-key condition) "last")
920 (setq result (<= (length (memq number number-list))
921 (string-to-int (elmo-filter-value condition))))
922 (if (eq (elmo-filter-type condition) 'unmatch)
923 (setq result (not result))))
924 ((string= (elmo-filter-key condition) "first")
925 (setq result (< (- (length number-list)
926 (length (memq number number-list)))
927 (string-to-int (elmo-filter-value condition))))
928 (if (eq (elmo-filter-type condition) 'unmatch)
929 (setq result (not result))))
932 (as-binary-input-file (insert-file-contents file))
933 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
934 ;; Should consider charset?
935 (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
937 (elmo-buffer-field-primitive-condition-match
938 condition number number-list)))))
941 (defun elmo-file-field-condition-match (file condition number number-list)
944 (elmo-file-field-primitive-condition-match
945 file condition number number-list))
946 ((eq (car condition) 'and)
947 (and (elmo-file-field-condition-match
948 file (nth 1 condition) number number-list)
949 (elmo-file-field-condition-match
950 file (nth 2 condition) number number-list)))
951 ((eq (car condition) 'or)
952 (or (elmo-file-field-condition-match
953 file (nth 1 condition) number number-list)
954 (elmo-file-field-condition-match
955 file (nth 2 condition) number number-list)))))
957 (defmacro elmo-get-hash-val (string hashtable)
958 (static-if (fboundp 'unintern)
959 `(symbol-value (intern-soft ,string ,hashtable))
960 `(let ((sym (intern-soft ,string ,hashtable)))
962 (symbol-value sym)))))
964 (defmacro elmo-set-hash-val (string value hashtable)
965 `(set (intern ,string ,hashtable) ,value))
967 (defmacro elmo-clear-hash-val (string hashtable)
968 (static-if (fboundp 'unintern)
969 (list 'unintern string hashtable)
970 (list 'makunbound (list 'intern string hashtable))))
972 (defmacro elmo-unintern (string)
973 "`unintern' symbol named STRING, When can use `unintern'.
974 Emacs 19.28 or earlier does not have `unintern'."
975 (static-if (fboundp 'unintern)
976 (list 'unintern string)))
978 (defun elmo-make-hash (&optional hashsize)
979 "Make a new hash table which have HASHSIZE size."
983 ;; Prime numbers as lengths tend to result in good
984 ;; hashing; lengths one less than a power of two are
988 (while (< (- i 1) hashsize)
991 elmo-hash-maximum-size)
992 elmo-hash-minimum-size)
993 elmo-hash-minimum-size)
996 (defsubst elmo-mime-string (string)
997 "Normalize MIME encoded STRING."
1000 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1002 (encode-mime-charset-string
1003 (eword-decode-and-unfold-unstructured-field-body
1006 (elmo-set-buffer-multibyte nil)
1009 (defsubst elmo-collect-field (beg end downcase-field-name)
1012 (narrow-to-region beg end)
1013 (goto-char (point-min))
1014 (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1016 (while (re-search-forward regexp nil t)
1017 (setq name (buffer-substring-no-properties
1018 (match-beginning 1)(1- (match-end 1))))
1019 (if downcase-field-name
1020 (setq name (downcase name)))
1021 (setq body (buffer-substring-no-properties
1022 (match-end 0) (std11-field-end)))
1023 (or (assoc name dest)
1024 (setq dest (cons (cons name body) dest))))
1027 (defsubst elmo-collect-field-from-string (string downcase-field-name)
1030 (goto-char (point-min))
1031 (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1033 (while (re-search-forward regexp nil t)
1034 (setq name (buffer-substring-no-properties
1035 (match-beginning 1)(1- (match-end 1))))
1036 (if downcase-field-name
1037 (setq name (downcase name)))
1038 (setq body (buffer-substring-no-properties
1039 (match-end 0) (std11-field-end)))
1040 (or (assoc name dest)
1041 (setq dest (cons (cons name body) dest))))
1044 (defun elmo-safe-filename (folder)
1045 (elmo-replace-in-string
1046 (elmo-replace-in-string
1047 (elmo-replace-in-string folder "/" " ")
1051 (defvar elmo-filename-replace-chars nil)
1053 (defsubst elmo-replace-string-as-filename (msgid)
1054 "Replace string as filename."
1055 (setq msgid (elmo-replace-in-string msgid " " " "))
1056 (if (null elmo-filename-replace-chars)
1057 (setq elmo-filename-replace-chars
1058 (regexp-quote (mapconcat
1059 'car elmo-filename-replace-string-alist ""))))
1060 (while (string-match (concat "[" elmo-filename-replace-chars "]")
1063 (substring msgid 0 (match-beginning 0))
1066 (match-beginning 0) (match-end 0))
1067 elmo-filename-replace-string-alist))
1068 (substring msgid (match-end 0)))))
1071 (defsubst elmo-recover-string-from-filename (filename)
1072 "Recover string from FILENAME."
1074 (while (string-match " " filename)
1075 (setq tmp (substring filename
1077 (+ (match-end 0) 1)))
1078 (if (string= tmp " ")
1080 (setq tmp (car (rassoc tmp
1081 elmo-filename-replace-string-alist))))
1084 (substring filename 0 (match-beginning 0))
1086 (setq filename (substring filename (+ (match-end 0) 1))))
1087 (concat result filename)))
1089 (defsubst elmo-copy-file (src dst &optional ok-if-already-exists)
1091 (elmo-add-name-to-file src dst ok-if-already-exists)
1092 (error (copy-file src dst ok-if-already-exists t))))
1094 (defsubst elmo-buffer-exists-p (buffer)
1095 (if (bufferp buffer)
1096 (buffer-live-p buffer)
1097 (get-buffer buffer)))
1099 (defsubst elmo-kill-buffer (buffer)
1100 (when (elmo-buffer-exists-p buffer)
1101 (kill-buffer buffer)))
1103 (defun elmo-delete-if (pred lst)
1104 "Return new list contain items which don't satisfy PRED in LST."
1107 (unless (funcall pred (car lst))
1108 (setq result (nconc result (list (car lst)))))
1109 (setq lst (cdr lst)))
1112 (defun elmo-list-delete (list1 list2 &optional delete-function)
1113 "Delete by side effect any occurrences equal to elements of LIST1 from LIST2.
1114 Return the modified LIST2. Deletion is done with `delete'.
1115 Write `(setq foo (elmo-list-delete bar foo))' to be sure of changing
1117 If optional DELETE-FUNCTION is speficied, it is used as delete procedure."
1118 (setq delete-function (or delete-function 'delete))
1120 (setq list2 (funcall delete-function (car list1) list2))
1121 (setq list1 (cdr list1)))
1124 (defun elmo-list-member (list1 list2)
1125 "If any element of LIST1 is member of LIST2, return t."
1128 (if (member (car list1) list2)
1130 (setq list1 (cdr list1)))))
1132 (defun elmo-count-matches (regexp beg end)
1136 (while (re-search-forward regexp end t)
1137 (setq count (1+ count)))
1140 (if (fboundp 'display-error)
1141 (defalias 'elmo-display-error 'display-error)
1142 (defun elmo-display-error (error-object stream)
1143 "A tiny function to display ERROR-OBJECT to the STREAM."
1145 (errobj error-object)
1148 (setq err-mes (concat err-mes (format
1149 (if (stringp (car errobj))
1153 (setq errobj (cdr errobj))
1154 (if errobj (setq err-mes (concat err-mes (if first ": " ", "))))
1156 (princ err-mes stream))))
1158 (if (fboundp 'define-error)
1159 (defalias 'elmo-define-error 'define-error)
1160 (defun elmo-define-error (error doc &optional parents)
1162 (setq parents 'error))
1163 (let ((conds (get parents 'error-conditions)))
1165 (error "Not an error symbol: %s" error))
1167 (list 'error-message doc
1168 'error-conditions (cons error conds))))))
1170 (cond ((fboundp 'progress-feedback-with-label)
1171 (defalias 'elmo-display-progress 'progress-feedback-with-label))
1172 ((fboundp 'lprogress-display)
1173 (defalias 'elmo-display-progress 'lprogress-display))
1175 (defun elmo-display-progress (label format &optional value &rest args)
1176 "Print a progress message."
1177 (if (and (null format) (null args))
1179 (apply (function message) (concat format " %d%%")
1180 (nconc args (list value)))))))
1182 (defvar elmo-progress-counter-alist nil)
1184 (defmacro elmo-progress-counter-value (counter)
1185 (` (aref (cdr (, counter)) 0)))
1187 (defmacro elmo-progress-counter-all-value (counter)
1188 (` (aref (cdr (, counter)) 1)))
1190 (defmacro elmo-progress-counter-format (counter)
1191 (` (aref (cdr (, counter)) 2)))
1193 (defmacro elmo-progress-counter-set-value (counter value)
1194 (` (aset (cdr (, counter)) 0 (, value))))
1196 (defun elmo-progress-set (label all-value &optional format)
1197 (unless (assq label elmo-progress-counter-alist)
1198 (setq elmo-progress-counter-alist
1199 (cons (cons label (vector 0 all-value (or format "")))
1200 elmo-progress-counter-alist))))
1202 (defun elmo-progress-clear (label)
1203 (let ((counter (assq label elmo-progress-counter-alist)))
1205 (elmo-display-progress label
1206 (elmo-progress-counter-format counter)
1208 (setq elmo-progress-counter-alist
1209 (delq counter elmo-progress-counter-alist)))))
1211 (defun elmo-progress-notify (label &optional value op &rest args)
1212 (let ((counter (assq label elmo-progress-counter-alist)))
1214 (let* ((value (or value 1))
1215 (cur-value (elmo-progress-counter-value counter))
1216 (all-value (elmo-progress-counter-all-value counter))
1217 (new-value (if (eq op 'set) value (+ cur-value value)))
1218 (cur-rate (/ (* cur-value 100) all-value))
1219 (new-rate (/ (* new-value 100) all-value)))
1220 (elmo-progress-counter-set-value counter new-value)
1221 (unless (= cur-rate new-rate)
1222 (apply 'elmo-display-progress
1224 (elmo-progress-counter-format counter)
1227 (when (>= new-rate 100)
1228 (elmo-progress-clear label))))))
1230 (put 'elmo-with-progress-display 'lisp-indent-function '2)
1231 (def-edebug-spec elmo-with-progress-display
1232 (form (symbolp form &optional form) &rest form))
1234 (defmacro elmo-with-progress-display (condition spec &rest body)
1235 "Evaluate BODY with progress gauge if CONDITION is non-nil.
1236 SPEC is a list as followed (LABEL MAX-VALUE [FORMAT])."
1237 (let ((label (car spec))
1238 (max-value (cadr spec))
1243 (elmo-progress-set (quote ,label) ,max-value ,fmt))
1245 (elmo-progress-clear (quote ,label)))))
1247 (defun elmo-time-expire (before-time diff-time)
1248 (let* ((current (current-time))
1249 (rest (when (< (nth 1 current) (nth 1 before-time))
1253 (list (- (+ (car current) (if rest -1 0)) (car before-time))
1254 (- (+ (or rest 0) (nth 1 current)) (nth 1 before-time))))
1255 (and (eq (car diff) 0)
1256 (< diff-time (nth 1 diff)))))
1258 (if (fboundp 'std11-fetch-field)
1259 (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
1260 (defalias 'elmo-field-body 'std11-field-body))
1262 (defun elmo-unfold-field-body (name)
1263 (let ((value (elmo-field-body name)))
1265 (std11-unfold-string value))))
1267 (defun elmo-address-quote-specials (word)
1268 "Make quoted string of WORD if needed."
1269 (let ((lal (std11-lexical-analyze word)))
1270 (if (or (assq 'specials lal)
1271 (assq 'domain-literal lal))
1272 (prin1-to-string word)
1275 (defmacro elmo-string (string)
1276 "STRING without text property."
1277 (` (let ((obj (copy-sequence (, string))))
1278 (and obj (set-text-properties 0 (length obj) nil obj))
1281 (defun elmo-flatten (list-of-list)
1282 "Flatten LIST-OF-LIST."
1283 (unless (null list-of-list)
1284 (append (if (and (car list-of-list)
1285 (listp (car list-of-list)))
1287 (list (car list-of-list)))
1288 (elmo-flatten (cdr list-of-list)))))
1290 (defun elmo-y-or-n-p (prompt &optional auto default)
1291 "Same as `y-or-n-p'.
1292 But if optional argument AUTO is non-nil, DEFAULT is returned."
1297 (defun elmo-string-member (string slist)
1300 (if (and (stringp (car slist))
1301 (string= string (car slist)))
1303 (setq slist (cdr slist)))))
1305 (cond ((fboundp 'member-ignore-case)
1306 (defalias 'elmo-string-member-ignore-case 'member-ignore-case))
1307 ((fboundp 'compare-strings)
1308 (defun elmo-string-member-ignore-case (elt list)
1309 "Like `member', but ignores differences in case and text representation.
1310 ELT must be a string. Upper-case and lower-case letters are treated as equal.
1311 Unibyte strings are converted to multibyte for comparison."
1312 (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t))))
1313 (setq list (cdr list)))
1316 (defun elmo-string-member-ignore-case (elt list)
1317 "Like `member', but ignores differences in case and text representation.
1318 ELT must be a string. Upper-case and lower-case letters are treated as equal."
1319 (let ((str (downcase elt)))
1320 (while (and list (not (string= str (downcase (car list)))))
1321 (setq list (cdr list)))
1324 (defun elmo-string-match-member (str list &optional case-ignore)
1325 (let ((case-fold-search case-ignore))
1328 (if (string-match (car list) str)
1329 (throw 'member (car list)))
1330 (setq list (cdr list))))))
1332 (defun elmo-string-matched-member (str list &optional case-ignore)
1333 (let ((case-fold-search case-ignore))
1336 (if (string-match str (car list))
1337 (throw 'member (car list)))
1338 (setq list (cdr list))))))
1340 (defsubst elmo-string-delete-match (string pos)
1341 (concat (substring string
1342 0 (match-beginning pos))
1347 (defun elmo-string-match-assoc (key alist &optional case-ignore)
1348 (let ((case-fold-search case-ignore)
1352 (setq a (car alist))
1355 (string-match key (car a)))
1357 (setq alist (cdr alist))))))
1359 (defun elmo-string-matched-assoc (key alist &optional case-ignore)
1360 (let ((case-fold-search case-ignore)
1364 (setq a (car alist))
1367 (string-match (car a) key))
1369 (setq alist (cdr alist))))))
1371 (defun elmo-string-assoc (key alist)
1375 (setq a (car alist))
1378 (string= key (car a)))
1380 (setq alist (cdr alist))))))
1382 (defun elmo-string-assoc-all (key alist)
1385 (if (string= key (car (car alist)))
1389 (setq alist (cdr alist)))
1392 (defun elmo-string-rassoc (key alist)
1396 (setq a (car alist))
1399 (string= key (cdr a)))
1401 (setq alist (cdr alist))))))
1403 (defun elmo-string-rassoc-all (key alist)
1406 (if (string= key (cdr (car alist)))
1410 (setq alist (cdr alist)))
1413 (defun elmo-expand-newtext (newtext original)
1414 (let ((len (length newtext))
1416 c expanded beg N did-expand)
1419 (while (and (< pos len)
1420 (not (= (aref newtext pos) ?\\)))
1421 (setq pos (1+ pos)))
1423 (push (substring newtext beg pos) expanded))
1425 ;; We hit a \; expand it.
1428 c (aref newtext pos))
1429 (if (not (or (= c ?\&)
1432 ;; \ followed by some character we don't expand.
1433 (push (char-to-string c) expanded)
1438 (when (match-beginning N)
1439 (push (substring original (match-beginning N) (match-end N))
1441 (setq pos (1+ pos)))
1443 (apply (function concat) (nreverse expanded))
1446 ;;; Folder parser utils.
1447 (defun elmo-parse-token (string &optional seps)
1448 "Parse atom from STRING using SEPS as a string of separator char list."
1449 (let ((len (length string))
1450 (seps (and seps (string-to-char-list seps)))
1456 (while (and (< i len) (or in (null sep)))
1457 (setq c (aref string i))
1459 ((and in (eq c ?\\))
1461 content (cons (aref string i) content)
1466 (in (setq content (cons c content)
1470 (t (setq content (cons c content)
1472 (if in (error "Parse error in quoted"))
1473 (cons (if (null content) "" (char-list-to-string (nreverse content)))
1474 (substring string i)))))
1476 (defun elmo-parse-prefixed-element (prefix string &optional seps)
1477 (if (and (not (eq (length string) 0))
1478 (eq (aref string 0) prefix))
1479 (elmo-parse-token (substring string 1) seps)
1482 ;;; Number set defined by OKAZAKI Tetsurou <okazaki@be.to>
1484 ;; number ::= [0-9]+
1487 ;; number-range ::= "(" beg " . " end ")" ;; cons cell
1488 ;; number-set-elem ::= number / number-range
1489 ;; number-set ::= "(" *number-set-elem ")" ;; list
1491 (defun elmo-number-set-member (number number-set)
1492 "Return non-nil if NUMBER is an element of NUMBER-SET.
1493 The value is actually the tail of NUMBER-RANGE whose car contains NUMBER."
1494 (or (memq number number-set)
1496 (while (and number-set (not found))
1497 (if (and (consp (car number-set))
1498 (and (<= (car (car number-set)) number)
1499 (<= number (cdr (car number-set)))))
1501 (setq number-set (cdr number-set))))
1504 (defun elmo-number-set-append-list (number-set list)
1505 "Append LIST of numbers to the NUMBER-SET.
1506 NUMBER-SET is altered."
1507 (let ((appended number-set))
1509 (setq appended (elmo-number-set-append appended (car list)))
1510 (setq list (cdr list)))
1513 (defun elmo-number-set-append (number-set number)
1514 "Append NUMBER to the NUMBER-SET.
1515 NUMBER-SET is altered."
1516 (let ((number-set-1 number-set)
1518 (while (and number-set (not found))
1519 (setq elem (car number-set))
1522 (eq (+ 1 (cdr elem)) number))
1523 (setcdr elem number)
1525 ((and (integerp elem)
1526 (eq (+ 1 elem) number))
1527 (setcar number-set (cons elem number))
1529 ((or (and (integerp elem) (eq elem number))
1531 (<= (car elem) number)
1532 (<= number (cdr elem))))
1534 (setq number-set (cdr number-set)))
1536 (setq number-set-1 (nconc number-set-1 (list number))))
1539 (defun elmo-number-set-to-number-list (number-set)
1540 "Return a number list which corresponds to NUMBER-SET."
1541 (let (number-list elem i)
1543 (setq elem (car number-set))
1547 (while (<= i (cdr elem))
1548 (setq number-list (cons i number-list))
1551 (setq number-list (cons elem number-list))))
1552 (setq number-set (cdr number-set)))
1553 (nreverse number-list)))
1555 (defcustom elmo-list-subdirectories-ignore-regexp "^\\(\\.\\.?\\|[0-9]+\\)$"
1556 "*Regexp to filter subfolders."
1560 (defun elmo-list-subdirectories-1 (basedir curdir one-level)
1561 (let ((root (zerop (length curdir)))
1562 (w32-get-true-file-link-count t) ; for Meadow
1565 (dolist (file (directory-files (setq dir (expand-file-name curdir basedir))))
1566 (when (and (not (string-match
1567 elmo-list-subdirectories-ignore-regexp
1569 (car (setq attr (file-attributes
1570 (expand-file-name file dir)))))
1571 (when (eq one-level 'check) (throw 'done t))
1573 (concat curdir (and (not root) elmo-path-sep) file))
1575 (setq dirs (nconc dirs
1576 (if (if elmo-have-link-count (< 2 (nth 1 attr))
1578 (elmo-list-subdirectories-1
1581 (if one-level 'check))))
1583 (list (list relpath))
1586 (elmo-list-subdirectories-1
1590 (list relpath)))))))
1593 (defun elmo-list-subdirectories (directory file one-level)
1594 (let ((subdirs (elmo-list-subdirectories-1 directory file one-level)))
1595 (if (zerop (length file))
1597 (cons file subdirs))))
1599 (defun elmo-mapcar-list-of-list (func list-of-list)
1602 (cond ((listp x) (elmo-mapcar-list-of-list func x))
1603 (t (funcall func x))))
1606 (defun elmo-parse (string regexp &optional matchn)
1607 (or matchn (setq matchn 1))
1609 (store-match-data nil)
1610 (while (string-match regexp string (match-end 0))
1611 (setq list (cons (substring string (match-beginning matchn)
1612 (match-end matchn)) list)))
1616 (defmacro elmo-make-file-cache (path status)
1617 "PATH is the cache file name.
1618 STATUS is one of 'section, 'entire or nil.
1619 nil means no cache exists.
1620 'section means partial section cache exists.
1621 'entire means entire cache exists.
1622 If the cache is partial file-cache, TYPE is 'partial."
1623 (` (cons (, path) (, status))))
1625 (defmacro elmo-file-cache-path (file-cache)
1626 "Returns the file path of the FILE-CACHE."
1627 (` (car (, file-cache))))
1629 (defmacro elmo-file-cache-status (file-cache)
1630 "Returns the status of the FILE-CACHE."
1631 (` (cdr (, file-cache))))
1633 (defsubst elmo-cache-to-msgid (filename)
1634 (concat "<" (elmo-recover-string-from-filename filename) ">"))
1636 (defsubst elmo-cache-get-path-subr (msgid)
1637 (let ((chars '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?A ?B ?C ?D ?E ?F))
1638 (clist (string-to-char-list msgid))
1641 (setq sum (+ sum (car clist)))
1642 (setq clist (cdr clist)))
1644 (nth (% (/ sum 16) 2) chars)
1645 (nth (% sum 16) chars))))
1648 (defun elmo-file-cache-get-path (msgid &optional section)
1649 "Get cache path for MSGID.
1650 If optional argument SECTION is specified, partial cache path is returned."
1651 (if (setq msgid (elmo-msgid-to-cache msgid))
1654 (format "%s/%s/%s/%s"
1655 elmo-cache-directory
1656 (elmo-cache-get-path-subr msgid)
1660 elmo-cache-directory
1661 (elmo-cache-get-path-subr msgid)
1664 (defmacro elmo-file-cache-expand-path (path section)
1665 "Return file name for the file-cache corresponds to the section.
1666 PATH is the file-cache path.
1667 SECTION is the section string."
1668 (` (expand-file-name (or (, section) "") (, path))))
1670 (defun elmo-file-cache-delete (path)
1671 "Delete a cache on PATH."
1672 (when (file-exists-p path)
1673 (if (file-directory-p path)
1675 (dolist (file (directory-files path t "^[^\\.]"))
1677 (delete-directory path))
1681 (defun elmo-file-cache-exists-p (msgid)
1682 "Returns 'section or 'entire if a cache which corresponds to MSGID exists."
1683 (elmo-file-cache-status (elmo-file-cache-get msgid)))
1685 (defun elmo-file-cache-save (cache-path section)
1686 "Save current buffer as cache on PATH.
1687 Return t if cache is saved successfully."
1689 (let ((path (if section (expand-file-name section cache-path)
1692 (if (and (null section)
1693 (file-directory-p path))
1695 (setq files (directory-files path t "^[^\\.]"))
1697 (delete-file (car files))
1698 (setq files (cdr files)))
1699 (delete-directory path))
1701 (not (file-directory-p cache-path)))
1702 (delete-file cache-path)))
1704 (setq dir (directory-file-name (file-name-directory path)))
1705 (if (not (file-exists-p dir))
1706 (elmo-make-directory dir))
1707 (write-region-as-binary (point-min) (point-max)
1713 (defun elmo-file-cache-load (cache-path section)
1714 "Load cache on PATH into the current buffer.
1715 Return t if cache is loaded successfully."
1718 (when (and cache-path
1719 (if (elmo-cache-path-section-p cache-path)
1722 (setq cache-file (elmo-file-cache-expand-path
1725 (file-exists-p cache-file))
1726 (insert-file-contents-as-binary cache-file)
1731 (defun elmo-cache-path-section-p (path)
1732 "Return non-nil when PATH is `section' cache path."
1733 (file-directory-p path))
1735 (defun elmo-file-cache-get (msgid &optional section)
1736 "Returns the current file-cache object associated with MSGID.
1737 MSGID is the message-id of the message.
1738 If optional argument SECTION is specified, get partial file-cache object
1739 associated with SECTION."
1741 (let ((path (elmo-cache-get-path msgid)))
1742 (if (and path (file-exists-p path))
1743 (if (elmo-cache-path-section-p path)
1745 (if (file-exists-p (setq path (expand-file-name
1747 (cons path 'section))
1748 ;; section is not specified but sectional.
1749 (cons path 'section))
1752 (cons path 'entire)))
1759 (defun elmo-cache-expire ()
1761 (let* ((completion-ignore-case t)
1762 (method (completing-read (format "Expire by (%s): "
1763 elmo-cache-expire-default-method)
1767 (when (string= method "")
1768 (setq method elmo-cache-expire-default-method))
1769 (funcall (intern (concat "elmo-cache-expire-by-" method)))))
1771 (defun elmo-read-float-value-from-minibuffer (prompt &optional initial)
1772 (let ((str (read-from-minibuffer prompt initial)))
1774 ((string-match "[0-9]*\\.[0-9]+" str)
1775 (string-to-number str))
1776 ((string-match "[0-9]+" str)
1777 (string-to-number (concat str ".0")))
1778 (t (error "%s is not number" str)))))
1780 (defun elmo-cache-expire-by-size (&optional kbytes)
1781 "Expire cache file by size.
1782 If KBYTES is kilo bytes (This value must be float)."
1784 (let ((size (or kbytes
1785 (and (interactive-p)
1786 (elmo-read-float-value-from-minibuffer
1787 "Enter cache disk size (Kbytes): "
1789 (if (integerp elmo-cache-expire-default-size)
1790 (float elmo-cache-expire-default-size)
1791 elmo-cache-expire-default-size))))
1792 (if (integerp elmo-cache-expire-default-size)
1793 (float elmo-cache-expire-default-size))))
1797 (message "Checking disk usage...")
1798 (setq total (/ (elmo-disk-usage
1799 elmo-cache-directory) Kbytes))
1800 (setq beginning total)
1801 (message "Checking disk usage...done")
1802 (let ((cfl (elmo-cache-get-sorted-cache-file-list))
1806 (while (and (<= size total)
1807 (setq oldest (elmo-cache-get-oldest-cache-file-entity cfl)))
1808 (setq cur-file (expand-file-name (car (cdr oldest)) (car oldest)))
1809 (setq cur-size (/ (elmo-disk-usage cur-file) Kbytes))
1810 (when (elmo-file-cache-delete cur-file)
1811 (setq count (+ count 1))
1812 (message "%d cache(s) are expired." count))
1813 (setq deleted (+ deleted cur-size))
1814 (setq total (- total cur-size)))
1815 (message "%d cache(s) are expired from disk (%d Kbytes/%d Kbytes)."
1816 count deleted beginning))))
1818 (defun elmo-cache-make-file-entity (filename path)
1819 (cons filename (elmo-get-last-accessed-time filename path)))
1821 (defun elmo-cache-get-oldest-cache-file-entity (cache-file-list)
1822 (let ((cfl cache-file-list)
1823 flist firsts oldest-entity wonlist)
1825 (setq flist (cdr (car cfl)))
1826 (setq firsts (append firsts (list
1827 (cons (car (car cfl))
1829 (setq cfl (cdr cfl)))
1832 (if (and (not oldest-entity)
1833 (cdr (cdr (car firsts))))
1834 (setq oldest-entity (car firsts)))
1835 (if (and (cdr (cdr (car firsts)))
1836 (cdr (cdr oldest-entity))
1837 (> (cdr (cdr oldest-entity)) (cdr (cdr (car firsts)))))
1838 (setq oldest-entity (car firsts)))
1839 (setq firsts (cdr firsts)))
1840 (setq wonlist (assoc (car oldest-entity) cache-file-list))
1842 (setcdr wonlist (delete (car (cdr wonlist)) (cdr wonlist))))
1845 (defun elmo-cache-get-sorted-cache-file-list ()
1846 (let ((dirs (directory-files
1847 elmo-cache-directory
1852 (setq num (length dirs))
1853 (message "Collecting cache info...")
1855 (setq elist (mapcar (lambda (x)
1856 (elmo-cache-make-file-entity x (car dirs)))
1857 (directory-files (car dirs) nil "^[^\\.]")))
1858 (setq ret-val (append ret-val
1866 (when (> num elmo-display-progress-threshold)
1868 (elmo-display-progress
1869 'elmo-cache-get-sorted-cache-file-list "Collecting cache info..."
1871 (setq dirs (cdr dirs)))
1872 (message "Collecting cache info...done")
1875 (defun elmo-cache-expire-by-age (&optional days)
1876 (let ((age (or (and days (int-to-string days))
1877 (and (interactive-p)
1878 (read-from-minibuffer
1879 (format "Enter days (%s): "
1880 elmo-cache-expire-default-age)))
1881 (int-to-string elmo-cache-expire-default-age)))
1882 (dirs (directory-files
1883 elmo-cache-directory
1887 (if (string= age "")
1888 (setq age elmo-cache-expire-default-age)
1889 (setq age (string-to-int age)))
1890 (setq curtime (current-time))
1891 (setq curtime (+ (* (nth 0 curtime)
1892 (float 65536)) (nth 1 curtime)))
1894 (let ((files (directory-files (car dirs) t "^[^\\.]"))
1895 (limit-age (* age 86400)))
1897 (when (> (- curtime (elmo-get-last-accessed-time (car files)))
1899 (when (elmo-file-cache-delete (car files))
1900 (setq count (+ 1 count))
1901 (message "%d cache file(s) are expired." count)))
1902 (setq files (cdr files))))
1903 (setq dirs (cdr dirs)))))
1907 (defun elmo-msgid-to-cache (msgid)
1910 (string-match "<\\(.+\\)>$" msgid))
1911 (elmo-replace-string-as-filename (elmo-match-string 1 msgid)))))
1913 (defun elmo-cache-get-path (msgid &optional folder number)
1914 "Get path for cache file associated with MSGID, FOLDER, and NUMBER."
1915 (if (setq msgid (elmo-msgid-to-cache msgid))
1919 (format "%s/%s/%s@%s"
1920 (elmo-cache-get-path-subr msgid)
1923 (elmo-safe-filename folder))
1925 (elmo-cache-get-path-subr msgid)
1927 elmo-cache-directory))))
1932 (static-if (fboundp 'display-warning)
1933 (defmacro elmo-warning (&rest args)
1934 "Display a warning with `elmo' group."
1935 `(display-warning 'elmo (format ,@args)))
1936 (defconst elmo-warning-buffer-name "*elmo warning*")
1937 (defun elmo-warning (&rest args)
1938 "Display a warning. ARGS are passed to `format'."
1939 (with-current-buffer (get-buffer-create elmo-warning-buffer-name)
1940 (goto-char (point-max))
1941 (funcall 'insert (apply 'format (append args '("\n"))))
1942 (ignore-errors (recenter 1))
1943 (display-buffer elmo-warning-buffer-name))))
1945 (defvar elmo-obsolete-variable-alist nil)
1947 (defcustom elmo-obsolete-variable-show-warnings t
1948 "Show warning window if obsolete variable is treated."
1952 (defun elmo-define-obsolete-variable (obsolete var)
1953 "Define obsolete variable.
1954 OBSOLETE is a symbol for obsolete variable.
1955 VAR is a symbol for new variable.
1956 Definition is stored in `elmo-obsolete-variable-alist'."
1957 (let ((pair (assq var elmo-obsolete-variable-alist)))
1959 (setcdr pair obsolete)
1960 (setq elmo-obsolete-variable-alist
1961 (cons (cons var obsolete)
1962 elmo-obsolete-variable-alist)))))
1964 (defun elmo-resque-obsolete-variable (obsolete var)
1965 "Resque obsolete variable OBSOLETE as VAR.
1966 If `elmo-obsolete-variable-show-warnings' is non-nil, show warning message."
1967 (when (boundp obsolete)
1968 (static-if (and (fboundp 'defvaralias)
1969 (subrp (symbol-function 'defvaralias)))
1970 (defvaralias var obsolete)
1971 (set var (symbol-value obsolete)))
1972 (if elmo-obsolete-variable-show-warnings
1973 (elmo-warning "%s is obsolete. Use %s instead."
1974 (symbol-name obsolete)
1975 (symbol-name var)))))
1977 (defun elmo-resque-obsolete-variables (&optional alist)
1978 "Resque obsolete variables in ALIST.
1979 ALIST is a list of cons cell of
1980 \(OBSOLETE-VARIABLE-SYMBOL . NEW-VARIABLE-SYMBOL\).
1981 If ALIST is nil, `elmo-obsolete-variable-alist' is used."
1982 (dolist (pair elmo-obsolete-variable-alist)
1983 (elmo-resque-obsolete-variable (cdr pair)
1986 (defsubst elmo-msgdb-get-last-message-id (string)
1992 (goto-char (point-max))
1993 (when (search-backward "<" nil t)
1995 (if (search-forward ">" nil t)
1996 (elmo-replace-in-string
1997 (buffer-substring beg (point)) "\n[ \t]*" ""))))))))
1999 (defun elmo-msgdb-get-message-id-from-buffer ()
2000 (let ((msgid (elmo-field-body "message-id")))
2002 (if (string-match "<\\(.+\\)>$" msgid)
2004 (concat "<" msgid ">")) ; Invaild message-id.
2005 ;; no message-id, so put dummy msgid.
2006 (concat "<" (timezone-make-date-sortable
2007 (elmo-unfold-field-body "date"))
2008 (nth 1 (eword-extract-address-components
2009 (or (elmo-field-body "from") "nobody"))) ">"))))
2011 (defsubst elmo-msgdb-insert-file-header (file)
2012 "Insert the header of the article."
2014 insert-file-contents-pre-hook ; To avoid autoconv-xmas...
2015 insert-file-contents-post-hook
2017 (when (file-exists-p file)
2018 ;; Read until header separator is found.
2019 (while (and (eq elmo-msgdb-file-header-chop-length
2021 (insert-file-contents-as-binary
2023 (incf beg elmo-msgdb-file-header-chop-length))))
2024 (prog1 (not (search-forward "\n\n" nil t))
2025 (goto-char (point-max))))))))
2028 ;; overview handling
2030 (defun elmo-multiple-field-body (name &optional boundary)
2033 (std11-narrow-to-header boundary)
2034 (goto-char (point-min))
2035 (let ((case-fold-search t)
2037 (while (re-search-forward (concat "^" name ":[ \t]*") nil t)
2040 (list (buffer-substring-no-properties
2041 (match-end 0) (std11-field-end))))))
2045 (defvar elmo-dop-queue-filename "queue"
2046 "*Disconnected operation queue is saved in this file.")
2048 (defun elmo-dop-queue-load ()
2049 (setq elmo-dop-queue
2051 (expand-file-name elmo-dop-queue-filename
2052 elmo-msgdb-directory))))
2054 (defun elmo-dop-queue-save ()
2056 (expand-file-name elmo-dop-queue-filename
2057 elmo-msgdb-directory)
2060 (if (and (fboundp 'regexp-opt)
2061 (not (featurep 'xemacs)))
2062 (defalias 'elmo-regexp-opt 'regexp-opt)
2063 (defun elmo-regexp-opt (strings &optional paren)
2064 "Return a regexp to match a string in STRINGS.
2065 Each string should be unique in STRINGS and should not contain any regexps,
2066 quoted or not. If optional PAREN is non-nil, ensure that the returned regexp
2067 is enclosed by at least one regexp grouping construct."
2068 (let ((open-paren (if paren "\\(" "")) (close-paren (if paren "\\)" "")))
2069 (concat open-paren (mapconcat 'regexp-quote strings "\\|")
2073 (product-provide (provide 'elmo-util) (require 'elmo-version))
2075 ;;; elmo-util.el ends here