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))
36 (require 'eword-decode)
39 (defmacro elmo-set-buffer-multibyte (flag)
40 "Set the multibyte flag of the current buffer to FLAG."
42 (list 'setq 'mc-flag flag))
45 ((and (boundp 'emacs-major-version) (>= emacs-major-version 20))
46 (list 'set-buffer-multibyte flag))
50 (defvar elmo-work-buf-name " *elmo work*")
51 (defvar elmo-temp-buf-name " *elmo temp*")
53 (or (boundp 'default-enable-multibyte-characters)
54 (defvar default-enable-multibyte-characters (featurep 'mule)
55 "The mock variable except for Emacs 20."))
57 (defun elmo-base64-encode-string (string &optional no-line-break))
58 (defun elmo-base64-decode-string (string))
60 ;; base64 encoding/decoding
62 (fset 'elmo-base64-encode-string
63 (mel-find-function 'mime-encode-string "base64"))
64 (fset 'elmo-base64-decode-string
65 (mel-find-function 'mime-decode-string "base64"))
67 ;; Any Emacsen may have add-name-to-file(), because loadup.el requires it. :-p
68 ;; Check make-symbolic-link() instead. -- 981002 by Fuji
69 (if (fboundp 'make-symbolic-link) ;; xxx
70 (defalias 'elmo-add-name-to-file 'add-name-to-file)
71 (defun elmo-add-name-to-file
72 (filename newname &optional ok-if-already-exists)
73 (copy-file filename newname ok-if-already-exists t)))
75 ;; Nemacs's `read' is different.
76 (static-if (fboundp 'nemacs-version)
77 (defun elmo-read (obj)
80 (or (bobp) (forward-char -1)))))
81 (defalias 'elmo-read 'read))
83 (defmacro elmo-set-work-buf (&rest body)
84 "Execute BODY on work buffer. Work buffer remains."
86 (set-buffer (get-buffer-create elmo-work-buf-name))
87 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
91 (defmacro elmo-bind-directory (dir &rest body)
92 "Set current directory DIR and execute BODY."
93 (` (let ((default-directory (file-name-as-directory (, dir))))
96 (defun elmo-object-load (filename &optional mime-charset no-err)
97 "Load OBJECT from the file specified by FILENAME.
98 File content is decoded with MIME-CHARSET."
99 (if (not (file-readable-p filename))
102 (as-binary-input-file
103 (insert-file-contents filename))
105 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
106 (decode-mime-charset-region (point-min) (point-max) mime-charset))
108 (read (current-buffer))
109 (error (unless no-err
110 (message "Warning: Loading object from %s failed."
112 (elmo-object-save filename nil))
115 (defsubst elmo-save-buffer (filename &optional mime-charset)
116 "Save current buffer to the file specified by FILENAME.
117 Directory of the file is created if it doesn't exist.
118 File content is encoded with MIME-CHARSET."
119 (let ((dir (directory-file-name (file-name-directory filename))))
120 (if (file-directory-p dir)
122 (unless (file-exists-p dir)
123 (elmo-make-directory dir)))
124 (if (file-writable-p filename)
127 ;;; (elmo-set-buffer-multibyte default-enable-multibyte-characters)
128 (encode-mime-charset-region (point-min) (point-max) mime-charset))
129 (as-binary-output-file
130 (write-region (point-min) (point-max) filename nil 'no-msg)))
131 (message (format "%s is not writable." filename)))))
133 (defun elmo-object-save (filename object &optional mime-charset)
134 "Save OBJECT to the file specified by FILENAME.
135 Directory of the file is created if it doesn't exist.
136 File content is encoded with MIME-CHARSET."
138 (prin1 object (current-buffer))
139 ;;;(princ "\n" (current-buffer))
140 (elmo-save-buffer filename mime-charset)))
142 (defun elmo-get-network-stream-type (stream-type stream-type-alist)
144 (while stream-type-alist
145 (if (eq (nth 1 (car stream-type-alist)) stream-type)
146 (throw 'found (car stream-type-alist)))
147 (setq stream-type-alist (cdr stream-type-alist)))))
151 (defconst elmo-condition-atom-regexp "[^/ \")|&]*")
153 (defun elmo-read-search-condition (default)
154 "Read search condition string interactively."
155 (elmo-read-search-condition-internal "Search by" default))
157 (defun elmo-read-search-condition-internal (prompt default)
158 (let* ((completion-ignore-case t)
159 (field (completing-read
160 (format "%s (%s): " prompt default)
164 "From" "Subject" "To" "Cc" "Body"
165 "Since" "Before" "ToCc"
166 "!From" "!Subject" "!To" "!Cc" "!Body"
167 "!Since" "!Before" "!ToCc")
168 elmo-msgdb-extra-fields)) nil t))
170 (setq field (if (string= field "")
174 ((or (string= field "AND") (string= field "OR"))
176 (elmo-read-search-condition-internal
177 (concat field "(1) Search by") default)
178 (if (string= field "AND") "&" "|")
179 (elmo-read-search-condition-internal
180 (concat field "(2) Search by") default)
182 ((string-match "Since\\|Before" field)
183 (concat (downcase field) ":"
184 (completing-read (format "Value for '%s': " field)
187 (list (format "%s" (car x)))))
188 elmo-date-descriptions))))
190 (setq value (read-from-minibuffer (format "Value for '%s': " field)))
191 (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
193 (setq value (prin1-to-string value)))
194 (concat (downcase field) ":" value)))))
196 (defsubst elmo-condition-parse-error ()
197 (error "Syntax error in '%s'" (buffer-string)))
199 (defun elmo-parse-search-condition (condition)
201 Return value is a cons cell of (STRUCTURE . REST)"
204 (goto-char (point-min))
205 (cons (elmo-condition-parse) (buffer-substring (point) (point-max)))))
207 ;; condition ::= or-expr
208 (defun elmo-condition-parse ()
209 (or (elmo-condition-parse-or-expr)
210 (elmo-condition-parse-error)))
212 ;; or-expr ::= and-expr /
213 ;; and-expr "|" or-expr
214 (defun elmo-condition-parse-or-expr ()
215 (let ((left (elmo-condition-parse-and-expr)))
216 (if (looking-at "| *")
218 (goto-char (match-end 0))
219 (list 'or left (elmo-condition-parse-or-expr)))
222 ;; and-expr ::= primitive /
223 ;; primitive "&" and-expr
224 (defun elmo-condition-parse-and-expr ()
225 (let ((left (elmo-condition-parse-primitive)))
226 (if (looking-at "& *")
228 (goto-char (match-end 0))
229 (list 'and left (elmo-condition-parse-and-expr)))
232 ;; primitive ::= "(" expr ")" /
233 ;; ["!"] search-key SPACE* ":" SPACE* search-value
234 (defun elmo-condition-parse-primitive ()
237 (goto-char (match-end 0))
238 (prog1 (elmo-condition-parse)
239 (unless (looking-at ") *")
240 (elmo-condition-parse-error))
241 (goto-char (match-end 0))))
242 ;; search-key ::= [A-Za-z-]+
243 ;; ;; "since" / "before" / "last" / "first" /
244 ;; ;; "body" / field-name
245 ((looking-at "\\(!\\)? *\\([A-Za-z-]+\\) *: *")
246 (goto-char (match-end 0))
247 (let ((search-key (vector
248 (if (match-beginning 1) 'unmatch 'match)
249 (elmo-match-buffer 2)
250 (elmo-condition-parse-search-value))))
252 (if (string= (aref search-key 1) "tocc")
253 (if (eq (aref search-key 0) 'match)
255 (vector 'match "to" (aref search-key 2))
256 (vector 'match "cc" (aref search-key 2)))
258 (vector 'unmatch "to" (aref search-key 2))
259 (vector 'unmatch "cc" (aref search-key 2))))
262 ;; search-value ::= quoted / time / number / atom
263 ;; quoted ::= <elisp string expression>
264 ;; time ::= "yesterday" / "lastweek" / "lastmonth" / "lastyear" /
265 ;; number SPACE* "daysago" /
266 ;; number "-" month "-" number ; ex. 10-May-2000
268 ;; month ::= "Jan" / "Feb" / "Mar" / "Apr" / "May" / "Jun" /
269 ;; "Jul" / "Aug" / "Sep" / "Oct" / "Nov" / "Dec"
270 ;; atom ::= ATOM_CHARS*
271 ;; SPACE ::= <ascii space character, 0x20>
272 ;; ATOM_CHARS ::= <any character except specials>
273 ;; specials ::= SPACE / <"> / </> / <)> / <|> / <&>
274 ;; ;; These characters should be quoted.
275 (defun elmo-condition-parse-search-value ()
278 (elmo-read (current-buffer)))
279 ((or (looking-at "yesterday") (looking-at "lastweek")
280 (looking-at "lastmonth") (looking-at "lastyear")
281 (looking-at "[0-9]+ *daysago")
282 (looking-at "[0-9]+-[A-Za-z]+-[0-9]+")
283 (looking-at "[0-9]+")
284 (looking-at elmo-condition-atom-regexp))
285 (prog1 (elmo-match-buffer 0)
286 (goto-char (match-end 0))))
287 (t (error "Syntax error '%s'" (buffer-string)))))
290 (defsubst elmo-buffer-replace (regexp &optional newtext)
291 (goto-char (point-min))
292 (while (re-search-forward regexp nil t)
293 (replace-match (or newtext ""))))
295 (defsubst elmo-delete-char (char string &optional unibyte)
298 (let ((coding-system-for-read 'no-conversion)
299 (coding-system-for-write 'no-conversion))
300 (if unibyte (elmo-set-buffer-multibyte nil))
302 (goto-char (point-min))
303 (while (search-forward (char-to-string char) nil t)
307 (defsubst elmo-delete-cr-buffer ()
308 "Delete CR from buffer."
310 (goto-char (point-min))
311 (while (search-forward "\r\n" nil t)
312 (replace-match "\n")) ))
314 (defsubst elmo-delete-cr-get-content-type ()
316 (goto-char (point-min))
317 (while (search-forward "\r\n" nil t)
318 (replace-match "\n"))
319 (goto-char (point-min))
320 (or (std11-field-body "content-type")
323 (defun elmo-delete-cr (string)
327 (goto-char (point-min))
328 (while (search-forward "\r\n" nil t)
329 (replace-match "\n"))
332 (defun elmo-uniq-list (lst)
333 "Distractively uniqfy elements of LST."
342 (defun elmo-string-partial-p (string)
343 (and (stringp string) (string-match "message/partial" string)))
345 (defun elmo-get-file-string (filename &optional remove-final-newline)
347 (let (insert-file-contents-pre-hook ; To avoid autoconv-xmas...
348 insert-file-contents-post-hook)
349 (when (file-exists-p filename)
351 (as-binary-input-file (insert-file-contents filename)))
352 (when (and remove-final-newline
354 (= (char-after (1- (point-max))) ?\n))
355 (goto-char (point-max))
356 (delete-backward-char 1))
359 (defun elmo-save-string (string filename)
362 (as-binary-output-file
364 (write-region (point-min) (point-max)
365 filename nil 'no-msg))
368 (defun elmo-max-of-list (nlist)
372 (if (< max-num (car l))
373 (setq max-num (car l)))
377 (defun elmo-concat-path (path filename)
378 (if (not (string= path ""))
379 (if (string= elmo-path-sep (substring path (- (length path) 1)))
380 (concat path filename)
381 (concat path elmo-path-sep filename))
384 (defvar elmo-passwd-alist nil)
386 (defun elmo-passwd-alist-load ()
388 (let ((filename (expand-file-name elmo-passwd-alist-file-name
390 (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))
391 insert-file-contents-pre-hook ; To avoid autoconv-xmas...
392 insert-file-contents-post-hook
394 (if (not (file-readable-p filename))
396 (set-buffer tmp-buffer)
397 (insert-file-contents filename)
400 (read (current-buffer))
402 (kill-buffer tmp-buffer)
405 (defun elmo-passwd-alist-clear ()
406 "Clear password cache."
408 (setq elmo-passwd-alist nil))
410 (defun elmo-passwd-alist-save ()
411 "Save password into file."
414 (let ((filename (expand-file-name elmo-passwd-alist-file-name
416 (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*")))
417 (set-buffer tmp-buffer)
419 (prin1 elmo-passwd-alist tmp-buffer)
420 (princ "\n" tmp-buffer)
421 ;;; (if (and (file-exists-p filename)
422 ;;; (not (equal 384 (file-modes filename))))
423 ;;; (error "%s is not safe.chmod 600 %s!" filename filename))
424 (if (file-writable-p filename)
426 (write-region (point-min) (point-max)
427 filename nil 'no-msg)
428 (set-file-modes filename 384))
429 (message (format "%s is not writable." filename)))
430 (kill-buffer tmp-buffer))))
432 (defun elmo-get-passwd (key)
433 "Get password from password pool."
435 (if (not elmo-passwd-alist)
436 (setq elmo-passwd-alist (elmo-passwd-alist-load)))
437 (setq pair (assoc key elmo-passwd-alist))
439 (elmo-base64-decode-string (cdr pair))
440 (setq pass (elmo-read-passwd (format "Password for %s: "
442 (setq elmo-passwd-alist
443 (append elmo-passwd-alist
445 (elmo-base64-encode-string pass)))))
446 (if elmo-passwd-life-time
447 (run-with-timer elmo-passwd-life-time nil
448 (` (lambda () (elmo-remove-passwd (, key))))))
451 (defun elmo-remove-passwd (key)
452 "Remove password from password pool (for failure)."
454 (if (setq pass-cons (assoc key elmo-passwd-alist))
457 (fillarray (cdr pass-cons) 0))
458 (setq elmo-passwd-alist
459 (delete pass-cons elmo-passwd-alist))))))
461 (defmacro elmo-read-char-exclusive ()
462 (cond ((featurep 'xemacs)
463 '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?)
468 (key-press-event-p (setq event (next-command-event)))
469 (setq key (or (event-to-character event)
470 (cdr (assq (event-key event) table)))))))
472 ((fboundp 'read-char-exclusive)
473 '(read-char-exclusive))
477 (defun elmo-read-passwd (prompt &optional stars)
478 "Read a single line of text from user without echoing, and return it."
482 (cursor-in-echo-area t)
483 (log-message-max-size 0)
484 message-log-max done msg truncate)
486 (if (or (not stars) (string= "" ans))
488 (setq msg (concat prompt (make-string (length ans) ?.)))
490 (1+ (- (length msg) (window-width (minibuffer-window)))))
492 (setq msg (concat "$" (substring msg (1+ truncate))))))
494 (setq c (elmo-read-char-exclusive))
498 ((or (= c ?\r) (= c ?\n) (= c ?\e))
502 ((and (/= c ?\b) (/= c ?\177))
503 (setq ans (concat ans (char-to-string c))))
505 (setq ans (substring ans 0 -1)))))
514 (defun elmo-string-to-list (string)
517 (goto-char (point-min))
519 (goto-char (point-max))
521 (goto-char (point-min))
522 (read (current-buffer))))
524 (defun elmo-list-to-string (list)
533 (if (symbolp (car tlist))
534 (symbol-name (car tlist))
539 (setq tlist (cdr tlist)))
549 (defun elmo-plug-on-by-servers (alist &optional servers)
550 (let ((server-list (or servers elmo-plug-on-servers)))
553 (if (elmo-plugged-p (car server-list))
555 (setq server-list (cdr server-list))))))
557 (defun elmo-plug-on-by-exclude-servers (alist &optional servers)
558 (let ((server-list (or servers elmo-plug-on-exclude-servers))
559 server other-servers)
561 (when (and (not (member (setq server (caaar alist)) server-list))
562 (not (member server other-servers)))
563 (push server other-servers))
564 (setq alist (cdr alist)))
565 (elmo-plug-on-by-servers alist other-servers)))
567 (defun elmo-plugged-p (&optional server port stream-type alist label-exp)
568 (let ((alist (or alist elmo-plugged-alist))
570 (cond ((and (not port) (not server))
571 (cond ((eq elmo-plugged-condition 'one)
575 (if (nth 2 (car alist))
577 (setq alist (cdr alist))))
579 ((eq elmo-plugged-condition 'all)
583 (if (not (nth 2 (car alist)))
584 (throw 'plugged nil))
585 (setq alist (cdr alist)))
588 ((functionp elmo-plugged-condition)
589 (funcall elmo-plugged-condition alist))
592 ((not port) ;; server
595 (when (string= server (caaar alist))
596 (if (nth 2 (car alist))
598 (setq alist (cdr alist)))))
600 (setq plugged-info (assoc (list server port stream-type) alist))
601 (if (not plugged-info)
602 ;; add elmo-plugged-alist automatically
604 (elmo-set-plugged elmo-plugged server port stream-type
605 nil nil nil label-exp)
607 (if (and elmo-auto-change-plugged
608 (> elmo-auto-change-plugged 0)
609 (nth 3 plugged-info) ;; time
610 (elmo-time-expire (nth 3 plugged-info)
611 elmo-auto-change-plugged))
613 (nth 2 plugged-info)))))))
615 (defun elmo-set-plugged (plugged &optional server port stream-type time
617 (let ((alist (or alist elmo-plugged-alist))
619 (cond ((and (not port) (not server))
620 (setq elmo-plugged plugged)
621 ;; set plugged all element of elmo-plugged-alist.
623 (setcdr (cdar alist) (list plugged time))
624 (setq alist (cdr alist))))
626 ;; set plugged all port of server
628 (when (string= server (caaar alist))
629 (setcdr (cdar alist) (list plugged time)))
630 (setq alist (cdr alist))))
632 ;; set plugged one port of server
633 (setq plugged-info (assoc (list server port stream-type) alist))
634 (setq label (if label-exp
636 (nth 1 plugged-info)))
638 ;; if add is non-nil, don't reset plug state.
640 (setcdr plugged-info (list label plugged time)))
642 (setq elmo-plugged-alist
646 (list (list server port stream-type)
647 label plugged time))))))))
650 (defun elmo-delete-plugged (&optional server port alist)
651 (let* ((alist (or alist elmo-plugged-alist))
653 (cond ((and (not port) (not server))
656 ;; delete plugged all port of server
658 (when (string= server (caaar alist2))
659 (setq alist (delete (car alist2) alist)))
660 (setq alist2 (cdr alist2))))
662 ;; delete plugged one port of server
664 (delete (assoc (cons server port) alist) alist))))
667 (defun elmo-disk-usage (path)
668 "Get disk usage (bytes) in PATH."
670 (condition-case () (file-attributes path) (error nil))))
672 (if (nth 0 file-attr) ; directory
673 (let ((files (condition-case ()
674 (directory-files path t "^[^\\.]")
677 ;; (result (nth 7 file-attr))) ... directory size
679 (setq result (+ result (or (elmo-disk-usage (car files)) 0)))
680 (setq files (cdr files)))
682 (float (nth 7 file-attr))))))
684 (defun elmo-get-last-accessed-time (path &optional dir)
685 "Return the last accessed time of PATH."
686 (let ((last-accessed (nth 4 (file-attributes (or (and dir
691 (setq last-accessed (+ (* (nth 0 last-accessed)
692 (float 65536)) (nth 1 last-accessed)))
695 (defun elmo-get-last-modification-time (path &optional dir)
696 "Return the last accessed time of PATH."
697 (let ((last-modified (nth 5 (file-attributes (or (and dir
701 (setq last-modified (+ (* (nth 0 last-modified)
702 (float 65536)) (nth 1 last-modified)))))
704 (defun elmo-make-directory (path)
705 "Create directory recursively."
706 (let ((parent (directory-file-name (file-name-directory path))))
707 (if (null (file-directory-p parent))
708 (elmo-make-directory parent))
709 (make-directory path)
710 (if (string= path (expand-file-name elmo-msgdb-dir))
711 (set-file-modes path (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700
713 (defun elmo-delete-directory (path &optional no-hierarchy)
714 "Delete directory recursively."
715 (if (stringp path) ; nil is not permitted.
716 (let ((dirent (directory-files path))
717 relpath abspath hierarchy)
719 (setq relpath (car dirent)
721 abspath (expand-file-name relpath path))
722 (when (not (string-match "^\\.\\.?$" relpath))
723 (if (eq (nth 0 (file-attributes abspath)) t)
726 (elmo-delete-directory abspath no-hierarchy))
727 (delete-file abspath))))
729 (delete-directory path)))))
731 (defun elmo-list-filter (l1 l2)
734 ;; t means filter all.
737 (elmo-delete-if (lambda (x) (not (memq x l1))) l2)
741 (defsubst elmo-list-delete-if-smaller (list number)
742 (let ((ret-val (copy-sequence list)))
744 (if (< (car list) number)
745 (setq ret-val (delq (car list) ret-val)))
746 (setq list (cdr list)))
749 (defun elmo-list-diff (list1 list2 &optional mes)
752 (let ((clist1 (copy-sequence list1))
753 (clist2 (copy-sequence list2)))
755 (setq clist1 (delq (car list2) clist1))
756 (setq list2 (cdr list2)))
758 (setq clist2 (delq (car list1) clist2))
759 (setq list1 (cdr list1)))
761 (message (concat mes "done.")))
762 (list clist1 clist2)))
764 (defun elmo-list-bigger-diff (list1 list2 &optional mes)
765 "Returns a list (- +). + is bigger than max of LIST1, in LIST2."
770 (max-of-l2 (or (nth (max 0 (1- (length l2))) l2) 0))
774 (setq num (+ (length l1)))
776 (if (memq (car l1) l2)
777 (if (eq (car l1) (car l2))
780 (if (> (car l1) max-of-l2)
781 (setq diff1 (nconc diff1 (list (car l1))))))
785 (setq percent (/ (* i 100) num))
786 (if (eq (% percent 5) 0)
787 (elmo-display-progress
788 'elmo-list-bigger-diff "%s%d%%" percent mes))))
790 (cons diff1 (list l2)))))
792 (defmacro elmo-filter-type (filter)
793 (` (aref (, filter) 0)))
795 (defmacro elmo-filter-key (filter)
796 (` (aref (, filter) 1)))
798 (defmacro elmo-filter-value (filter)
799 (` (aref (, filter) 2)))
801 (defsubst elmo-buffer-field-primitive-condition-match (condition
805 (goto-char (point-min))
807 ((string= (elmo-filter-key condition) "last")
808 (setq result (<= (length (memq number number-list))
809 (string-to-int (elmo-filter-value condition)))))
810 ((string= (elmo-filter-key condition) "first")
811 (setq result (< (- (length number-list)
812 (length (memq number number-list)))
813 (string-to-int (elmo-filter-value condition)))))
814 ((string= (elmo-filter-key condition) "since")
815 (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
818 (timezone-make-sortable-date (aref date 0)
821 (timezone-make-time-string
825 (timezone-make-date-sortable (std11-field-body "date"))))))
826 ((string= (elmo-filter-key condition) "before")
827 (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
830 (timezone-make-date-sortable (std11-field-body "date"))
831 (timezone-make-sortable-date (aref date 0)
834 (timezone-make-time-string
838 ((string= (elmo-filter-key condition) "body")
839 (and (re-search-forward "^$" nil t) ; goto body
840 (setq result (search-forward (elmo-filter-value condition)
843 (let ((fval (std11-field-body (elmo-filter-key condition))))
844 (if (eq (length fval) 0) (setq fval nil))
845 (if fval (setq fval (eword-decode-string fval)))
846 (setq result (and fval (string-match
847 (elmo-filter-value condition) fval))))))
848 (if (eq (elmo-filter-type condition) 'unmatch)
849 (setq result (not result)))
852 (defun elmo-condition-find-key-internal (condition key)
855 (if (string= (elmo-filter-key condition) key)
857 ((or (eq (car condition) 'and)
858 (eq (car condition) 'or))
859 (elmo-condition-find-key-internal (nth 1 condition) key)
860 (elmo-condition-find-key-internal (nth 2 condition) key))))
862 (defun elmo-condition-find-key (condition key)
864 (elmo-condition-find-key-internal condition key)))
866 (defun elmo-buffer-field-condition-match (condition number number-list)
869 (elmo-buffer-field-primitive-condition-match
870 condition number number-list))
871 ((eq (car condition) 'and)
872 (and (elmo-buffer-field-condition-match
873 (nth 1 condition) number number-list)
874 (elmo-buffer-field-condition-match
875 (nth 2 condition) number number-list)))
876 ((eq (car condition) 'or)
877 (or (elmo-buffer-field-condition-match
878 (nth 1 condition) number number-list)
879 (elmo-buffer-field-condition-match
880 (nth 2 condition) number number-list)))))
882 (defsubst elmo-file-field-condition-match (file condition number number-list)
884 (as-binary-input-file (insert-file-contents file))
885 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
886 ;; Should consider charset?
887 (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
888 (elmo-buffer-field-condition-match condition number number-list)))
890 (defmacro elmo-get-hash-val (string hashtable)
891 (let ((sym (list 'intern-soft string hashtable)))
892 (list 'if (list 'boundp sym)
893 (list 'symbol-value sym))))
895 (defmacro elmo-set-hash-val (string value hashtable)
896 (list 'set (list 'intern string hashtable) value))
898 (defmacro elmo-clear-hash-val (string hashtable)
899 (static-if (fboundp 'unintern)
900 (list 'unintern string hashtable)
901 (list 'makunbound (list 'intern string hashtable))))
903 (defmacro elmo-unintern (string)
904 "`unintern' symbol named STRING, When can use `unintern'.
905 Emacs 19.28 or earlier does not have `unintern'."
906 (static-if (fboundp 'unintern)
907 (list 'unintern string)))
909 (defun elmo-make-hash (&optional hashsize)
910 "Make a new hash table which have HASHSIZE size."
914 ;; Prime numbers as lengths tend to result in good
915 ;; hashing; lengths one less than a power of two are
919 (while (< (- i 1) hashsize)
922 elmo-hash-maximum-size)
923 elmo-hash-minimum-size)
924 elmo-hash-minimum-size)
927 (defsubst elmo-mime-string (string)
928 "Normalize MIME encoded STRING."
932 (elmo-set-buffer-multibyte default-enable-multibyte-characters)
933 (setq str (eword-decode-string
934 (decode-mime-charset-string string elmo-mime-charset)))
935 (setq str (encode-mime-charset-string str elmo-mime-charset))
936 (elmo-set-buffer-multibyte nil)
939 (defsubst elmo-collect-field (beg end downcase-field-name)
942 (narrow-to-region beg end)
943 (goto-char (point-min))
944 (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
946 (while (re-search-forward regexp nil t)
947 (setq name (buffer-substring-no-properties
948 (match-beginning 1)(1- (match-end 1))))
949 (if downcase-field-name
950 (setq name (downcase name)))
951 (setq body (buffer-substring-no-properties
952 (match-end 0) (std11-field-end)))
953 (or (assoc name dest)
954 (setq dest (cons (cons name body) dest))))
957 (defsubst elmo-collect-field-from-string (string downcase-field-name)
960 (goto-char (point-min))
961 (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
963 (while (re-search-forward regexp nil t)
964 (setq name (buffer-substring-no-properties
965 (match-beginning 1)(1- (match-end 1))))
966 (if downcase-field-name
967 (setq name (downcase name)))
968 (setq body (buffer-substring-no-properties
969 (match-end 0) (std11-field-end)))
970 (or (assoc name dest)
971 (setq dest (cons (cons name body) dest))))
974 (defun elmo-safe-filename (folder)
975 (elmo-replace-in-string
976 (elmo-replace-in-string
977 (elmo-replace-in-string folder "/" " ")
981 (defvar elmo-filename-replace-chars nil)
983 (defsubst elmo-replace-string-as-filename (msgid)
984 "Replace string as filename."
985 (setq msgid (elmo-replace-in-string msgid " " " "))
986 (if (null elmo-filename-replace-chars)
987 (setq elmo-filename-replace-chars
988 (regexp-quote (mapconcat
989 'car elmo-filename-replace-string-alist ""))))
990 (while (string-match (concat "[" elmo-filename-replace-chars "]")
993 (substring msgid 0 (match-beginning 0))
996 (match-beginning 0) (match-end 0))
997 elmo-filename-replace-string-alist))
998 (substring msgid (match-end 0)))))
1001 (defsubst elmo-recover-string-from-filename (filename)
1002 "Recover string from FILENAME."
1004 (while (string-match " " filename)
1005 (setq tmp (substring filename
1007 (+ (match-end 0) 1)))
1008 (if (string= tmp " ")
1010 (setq tmp (car (rassoc tmp
1011 elmo-filename-replace-string-alist))))
1014 (substring filename 0 (match-beginning 0))
1016 (setq filename (substring filename (+ (match-end 0) 1))))
1017 (concat result filename)))
1019 (defsubst elmo-copy-file (src dst)
1021 (elmo-add-name-to-file src dst t)
1022 (error (copy-file src dst t))))
1024 (defsubst elmo-buffer-exists-p (buffer)
1025 (if (bufferp buffer)
1026 (buffer-live-p buffer)
1027 (get-buffer buffer)))
1029 (defsubst elmo-kill-buffer (buffer)
1030 (when (elmo-buffer-exists-p buffer)
1031 (kill-buffer buffer)))
1033 (defun elmo-delete-if (pred lst)
1034 "Return new list contain items which don't satisfy PRED in LST."
1037 (unless (funcall pred (car lst))
1038 (setq result (nconc result (list (car lst)))))
1039 (setq lst (cdr lst)))
1042 (defun elmo-list-delete (list1 list2)
1043 "Delete by side effect any occurrences equal to elements of LIST1 from LIST2.
1044 Return the modified LIST2. Deletion is done with `delete'.
1045 Write `(setq foo (elmo-list-delete bar foo))' to be sure of changing
1046 the value of `foo'."
1048 (setq list2 (delete (car list1) list2))
1049 (setq list1 (cdr list1)))
1052 (defun elmo-list-member (list1 list2)
1053 "If any element of LIST1 is member of LIST2, return t."
1056 (if (member (car list1) list2)
1058 (setq list1 (cdr list1)))))
1060 (defun elmo-count-matches (regexp beg end)
1064 (while (re-search-forward regexp end t)
1065 (setq count (1+ count)))
1068 (if (fboundp 'display-error)
1069 (defalias 'elmo-display-error 'display-error)
1070 (defun elmo-display-error (error-object stream)
1071 "A tiny function to display ERROR-OBJECT to the STREAM."
1073 (errobj error-object)
1076 (setq err-mes (concat err-mes (format
1077 (if (stringp (car errobj))
1079 (if (boundp 'nemacs-version)
1081 "%S")) (car errobj))))
1082 (setq errobj (cdr errobj))
1083 (if errobj (setq err-mes (concat err-mes (if first ": " ", "))))
1085 (princ err-mes stream))))
1087 (if (fboundp 'define-error)
1088 (defalias 'elmo-define-error 'define-error)
1089 (defun elmo-define-error (error doc &optional parents)
1091 (setq parents 'error))
1092 (let ((conds (get parents 'error-conditions)))
1094 (error "Not an error symbol: %s" error))
1096 (list 'error-message doc
1097 'error-conditions (cons error conds))))))
1099 (cond ((fboundp 'progress-feedback-with-label)
1100 (defalias 'elmo-display-progress 'progress-feedback-with-label))
1101 ((fboundp 'lprogress-display)
1102 (defalias 'elmo-display-progress 'lprogress-display))
1104 (defun elmo-display-progress (label format &optional value &rest args)
1105 "Print a progress message."
1106 (if (and (null format) (null args))
1108 (apply (function message) (concat format " %d%%")
1109 (nconc args (list value)))))))
1111 (defun elmo-time-expire (before-time diff-time)
1112 (let* ((current (current-time))
1113 (rest (when (< (nth 1 current) (nth 1 before-time))
1117 (list (- (+ (car current) (if rest -1 0)) (car before-time))
1118 (- (+ (or rest 0) (nth 1 current)) (nth 1 before-time))))
1119 (and (eq (car diff) 0)
1120 (< diff-time (nth 1 diff)))))
1122 (if (fboundp 'std11-fetch-field)
1123 (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
1124 (defalias 'elmo-field-body 'std11-field-body))
1126 (defmacro elmo-string (string)
1127 "STRING without text property."
1128 (` (let ((obj (copy-sequence (, string))))
1129 (set-text-properties 0 (length obj) nil obj)
1132 (defun elmo-flatten (list-of-list)
1133 "Flatten LIST-OF-LIST."
1134 (unless (null list-of-list)
1135 (append (if (and (car list-of-list)
1136 (listp (car list-of-list)))
1138 (list (car list-of-list)))
1139 (elmo-flatten (cdr list-of-list)))))
1141 (defun elmo-y-or-n-p (prompt &optional auto default)
1142 "Same as `y-or-n-p'.
1143 But if optional argument AUTO is non-nil, DEFAULT is returned."
1148 (defun elmo-string-member (string slist)
1149 "Return t if STRING is a member of the SLIST."
1152 (if (and (stringp (car slist))
1153 (string= string (car slist)))
1155 (setq slist (cdr slist)))))
1157 (defun elmo-string-match-member (str list &optional case-ignore)
1158 (let ((case-fold-search case-ignore))
1161 (if (string-match (car list) str)
1162 (throw 'member (car list)))
1163 (setq list (cdr list))))))
1165 (defun elmo-string-matched-member (str list &optional case-ignore)
1166 (let ((case-fold-search case-ignore))
1169 (if (string-match str (car list))
1170 (throw 'member (car list)))
1171 (setq list (cdr list))))))
1173 (defsubst elmo-string-delete-match (string pos)
1174 (concat (substring string
1175 0 (match-beginning pos))
1180 (defun elmo-string-match-assoc (key alist &optional case-ignore)
1181 (let ((case-fold-search case-ignore)
1185 (setq a (car alist))
1188 (string-match key (car a)))
1190 (setq alist (cdr alist))))))
1192 (defun elmo-string-matched-assoc (key alist &optional case-ignore)
1193 (let ((case-fold-search case-ignore)
1197 (setq a (car alist))
1200 (string-match (car a) key))
1202 (setq alist (cdr alist))))))
1204 (defun elmo-string-assoc (key alist)
1208 (setq a (car alist))
1211 (string= key (car a)))
1213 (setq alist (cdr alist))))))
1215 (defun elmo-string-rassoc (key alist)
1219 (setq a (car alist))
1222 (string= key (cdr a)))
1224 (setq alist (cdr alist))))))
1226 (defun elmo-string-rassoc-all (key alist)
1229 (if (string= key (cdr (car alist)))
1233 (setq alist (cdr alist)))
1236 ;;; Number set defined by OKAZAKI Tetsurou <okazaki@be.to>
1238 ;; number ::= [0-9]+
1241 ;; number-range ::= "(" beg " . " end ")" ;; cons cell
1242 ;; number-set-elem ::= number / number-range
1243 ;; number-set ::= "(" *number-set-elem ")" ;; list
1245 (defun elmo-number-set-member (number number-set)
1246 "Return non-nil if NUMBER is an element of NUMBER-SET.
1247 The value is actually the tail of NUMBER-RANGE whose car contains NUMBER."
1248 (or (memq number number-set)
1250 (while (and number-set (not found))
1251 (if (and (consp (car number-set))
1252 (and (<= (car (car number-set)) number)
1253 (<= number (cdr (car number-set)))))
1255 (setq number-set (cdr number-set))))
1258 (defun elmo-number-set-append-list (number-set list)
1259 "Append LIST of numbers to the NUMBER-SET.
1260 NUMBER-SET is altered."
1261 (let ((appended number-set))
1263 (setq appended (elmo-number-set-append appended (car list)))
1264 (setq list (cdr list)))
1267 (defun elmo-number-set-append (number-set number)
1268 "Append NUMBER to the NUMBER-SET.
1269 NUMBER-SET is altered."
1270 (let ((number-set-1 number-set)
1272 (while (and number-set (not found))
1273 (setq elem (car number-set))
1276 (eq (+ 1 (cdr elem)) number))
1277 (setcdr elem number)
1279 ((and (integerp elem)
1280 (eq (+ 1 elem) number))
1281 (setcar number-set (cons elem number))
1283 ((or (and (integerp elem) (eq elem number))
1285 (<= (car elem) number)
1286 (<= number (cdr elem))))
1288 (setq number-set (cdr number-set)))
1290 (setq number-set-1 (nconc number-set-1 (list number))))
1293 (defun elmo-number-set-to-number-list (number-set)
1294 "Return a number list which corresponds to NUMBER-SET."
1295 (let (number-list elem i)
1297 (setq elem (car number-set))
1301 (while (<= i (cdr elem))
1302 (setq number-list (cons i number-list))
1305 (setq number-list (cons elem number-list))))
1306 (setq number-set (cdr number-set)))
1307 (nreverse number-list)))
1309 (defcustom elmo-list-subdirectories-ignore-regexp "^\\(\\.\\.?\\|[0-9]+\\)$"
1310 "*Regexp to filter subfolders."
1314 (defun elmo-list-subdirectories (directory file one-level)
1315 (let ((root (zerop (length file)))
1316 (w32-get-true-file-link-count t) ; for Meadow
1317 files attr dirs dir)
1318 (setq files (directory-files (setq dir (expand-file-name file directory))))
1320 (if (and (not (string-match elmo-list-subdirectories-ignore-regexp
1322 (car (setq attr (file-attributes (expand-file-name
1323 (car files) dir)))))
1324 (if (and (not one-level)
1325 (and elmo-have-link-count (< 2 (nth 1 attr))))
1328 (elmo-list-subdirectories
1331 (and (not root) elmo-path-sep)
1334 (setq dirs (nconc dirs
1337 (and (not root) elmo-path-sep)
1339 (setq files (cdr files)))
1340 (nconc (and (not root) (list file)) dirs)))
1342 (defun elmo-parse (string regexp &optional matchn)
1343 (or matchn (setq matchn 1))
1345 (store-match-data nil)
1346 (while (string-match regexp string (match-end 0))
1347 (setq list (cons (substring string (match-beginning matchn)
1348 (match-end matchn)) list)))
1351 (defconst elmo-warning-buffer-name "*elmo warning*")
1353 (defun elmo-warning (&rest args)
1354 "Display a warning, making warning message by passing all args to `insert'."
1355 (with-current-buffer (get-buffer-create elmo-warning-buffer-name)
1356 (goto-char (point-max))
1357 (apply 'insert (append args '("\n")))
1359 (display-buffer elmo-warning-buffer-name))
1361 (defvar elmo-obsolete-variable-alist nil)
1362 (defvar elmo-obsolete-variable-show-warnings nil)
1364 (defun elmo-define-obsolete-variable (obsolete var)
1365 "Define obsolete variable.
1366 OBSOLETE is a symbol for obsolete variable.
1367 VAR is a symbol for new variable.
1368 Definition is stored in `elmo-obsolete-variable-alist'."
1369 (let ((pair (assq var elmo-obsolete-variable-alist)))
1371 (setcdr pair obsolete)
1372 (setq elmo-obsolete-variable-alist
1373 (cons (cons var obsolete)
1374 elmo-obsolete-variable-alist)))))
1376 (defun elmo-resque-obsolete-variable (obsolete var)
1377 "Resque obsolete variable OBSOLETE as VAR.
1378 If `elmo-obsolete-variable-show-warnings' is non-nil, show warning message."
1379 (when (boundp obsolete)
1380 (set var (symbol-value obsolete))
1381 (if elmo-obsolete-variable-show-warnings
1382 (elmo-warning (format "%s is obsolete. Use %s instead."
1383 (symbol-name obsolete)
1384 (symbol-name var))))))
1386 (defun elmo-resque-obsolete-variables (&optional alist)
1387 "Resque obsolete variables in ALIST.
1388 ALIST is a list of cons cell of
1389 \(OBSOLETE-VARIABLE-SYMBOL . NEW-VARIABLE-SYMBOL\).
1390 If ALIST is nil, `elmo-obsolete-variable-alist' is used."
1391 (dolist (pair elmo-obsolete-variable-alist)
1392 (elmo-resque-obsolete-variable (cdr pair)
1397 (product-provide (provide 'elmo-util) (require 'elmo-version))
1399 ;;; elmo-util.el ends here