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.
40 (require 'eword-decode)
46 (autoload 'md5 "md5"))
48 (defvar elmo-work-buf-name " *elmo work*")
49 (defvar elmo-temp-buf-name " *elmo temp*")
51 (or (boundp 'default-enable-multibyte-characters)
52 (defvar default-enable-multibyte-characters (featurep 'mule)
53 "The mock variable except for Emacs 20."))
55 (defun elmo-base64-encode-string (string &optional no-line-break))
56 (defun elmo-base64-decode-string (string))
58 ;; base64 encoding/decoding
60 (fset 'elmo-base64-encode-string
61 (mel-find-function 'mime-encode-string "base64"))
62 (fset 'elmo-base64-decode-string
63 (mel-find-function 'mime-decode-string "base64"))
67 (defalias 'elmo-add-name-to-file 'add-name-to-file)
68 (defun elmo-add-name-to-file
69 (filename newname &optional ok-if-already-exists)
70 (copy-file filename newname ok-if-already-exists t))))
72 (defmacro elmo-set-work-buf (&rest body)
73 "Execute BODY on work buffer. Work buffer remains."
74 `(with-current-buffer (get-buffer-create elmo-work-buf-name)
75 (set-buffer-multibyte default-enable-multibyte-characters)
79 (put 'elmo-set-work-buf 'lisp-indent-function 0)
80 (def-edebug-spec elmo-set-work-buf t)
82 (defmacro elmo-bind-directory (dir &rest body)
83 "Set current directory DIR and execute BODY."
84 `(let ((default-directory (file-name-as-directory ,dir)))
87 (put 'elmo-bind-directory 'lisp-indent-function 1)
88 (def-edebug-spec elmo-bind-directory
91 (defconst elmo-multibyte-buffer-name " *elmo-multibyte-buffer*")
93 (defmacro elmo-with-enable-multibyte (&rest body)
94 "Evaluate BODY with `default-enable-multibyte-character'."
95 `(with-current-buffer (get-buffer-create elmo-multibyte-buffer-name)
98 (put 'elmo-with-enable-multibyte 'lisp-indent-function 0)
99 (def-edebug-spec elmo-with-enable-multibyte t)
101 (static-if (condition-case nil
102 (plist-get '(one) 'other)
104 (defmacro elmo-safe-plist-get (plist prop)
106 (plist-get ,plist ,prop)))
107 (defalias 'elmo-safe-plist-get 'plist-get))
110 (unless (fboundp 'coding-system-base)
111 (defalias 'coding-system-base 'ignore))
112 (unless (fboundp 'coding-system-name)
113 (defalias 'coding-system-name 'ignore))
114 (unless (fboundp 'find-file-coding-system-for-read-from-filename)
115 (defalias 'find-file-coding-system-for-read-from-filename 'ignore))
116 (unless (fboundp 'find-operation-coding-system)
117 (defalias 'find-operation-coding-system 'ignore)))
119 (defun elmo-set-auto-coding (&optional filename)
120 "Find coding system used to decode the contents of the current buffer.
121 This function looks for the coding system magic cookie or examines the
122 coding system specified by `file-coding-system-alist' being associated
123 with FILENAME which defaults to `buffer-file-name'."
125 ((boundp 'set-auto-coding-function) ;; Emacs
127 (or (funcall (symbol-value 'set-auto-coding-function)
128 filename (- (point-max) (point-min)))
129 (car (find-operation-coding-system 'insert-file-contents
131 (let (auto-coding-alist)
133 (funcall (symbol-value 'set-auto-coding-function)
134 nil (- (point-max) (point-min)))
136 ((featurep 'file-coding) ;; XEmacs
137 (let ((case-fold-search t)
141 (and (re-search-forward "-\\*-+[\t ]*" end t)
143 (setq start (match-end 0))
144 (re-search-forward "[\t ]*-+\\*-" end t))
146 (setq end (match-beginning 0))
148 (or (looking-at "coding:[\t ]*\\([^\t ;]+\\)")
150 "[\t ;]+coding:[\t ]*\\([^\t ;]+\\)"
152 (find-coding-system (setq codesys
153 (intern (match-string 1))))
155 (and (re-search-forward "^[\t ]*;+[\t ]*Local[\t ]+Variables:"
158 (setq start (match-end 0))
159 (re-search-forward "^[\t ]*;+[\t ]*End:" nil t))
161 (setq end (match-beginning 0))
164 "^[\t ]*;+[\t ]*coding:[\t ]*\\([^\t\n\r ]+\\)"
166 (find-coding-system (setq codesys
167 (intern (match-string 1))))
170 (goto-char (point-min))
171 (setq case-fold-search nil)
172 (re-search-forward "^;;;coding system: "
173 ;;; (+ (point-min) 3000) t))
175 (looking-at "[^\t\n\r ]+")
177 (setq codesys (intern (match-string 0))))
181 (find-file-coding-system-for-read-from-filename
183 (coding-system-name (coding-system-base codesys))))))))
185 (defun elmo-object-load (filename &optional mime-charset no-err)
186 "Load OBJECT from the file specified by FILENAME.
187 File content is decoded with MIME-CHARSET."
188 (if (not (file-readable-p filename))
191 (insert-file-contents-as-binary filename)
192 (let ((coding-system (or (elmo-set-auto-coding)
193 (mime-charset-to-coding-system
196 (decode-coding-region (point-min) (point-max) coding-system)))
197 (goto-char (point-min))
199 (read (current-buffer))
200 (error (unless no-err
201 (message "Warning: Loading object from %s failed."
203 (elmo-object-save filename nil mime-charset))
206 (defsubst elmo-save-buffer (filename &optional mime-charset)
207 "Save current buffer to the file specified by FILENAME.
208 Directory of the file is created if it doesn't exist.
209 File content is encoded with MIME-CHARSET."
210 (let ((dir (directory-file-name (file-name-directory filename))))
211 (if (file-directory-p dir)
213 (unless (file-exists-p dir)
214 (elmo-make-directory dir)))
215 (if (file-writable-p filename)
218 ;;; (set-buffer-multibyte default-enable-multibyte-characters)
219 (encode-mime-charset-region (point-min) (point-max) mime-charset))
220 (as-binary-output-file
221 (write-region (point-min) (point-max) filename nil 'no-msg)))
222 (message "%s is not writable." filename))))
224 (defun elmo-object-save (filename object &optional mime-charset)
225 "Save OBJECT to the file specified by FILENAME.
226 Directory of the file is created if it doesn't exist.
227 File content is encoded with MIME-CHARSET."
229 (let (print-length print-level)
230 (prin1 object (current-buffer)))
232 (let ((coding (mime-charset-to-coding-system
233 (or (detect-mime-charset-region (point-min) (point-max))
235 (goto-char (point-min))
236 (insert ";;; -*- mode: emacs-lisp; coding: "
237 (symbol-name coding) " -*-\n")
238 (encode-coding-region (point-min) (point-max) coding)))
239 (elmo-save-buffer filename)))
243 (defconst elmo-condition-atom-regexp "[^/ \")|&]*")
245 (defsubst elmo-condition-parse-error ()
246 (error "Syntax error in '%s'" (buffer-string)))
248 (defun elmo-parse-search-condition (condition)
250 Return value is a cons cell of (STRUCTURE . REST)"
253 (goto-char (point-min))
254 (cons (elmo-condition-parse) (buffer-substring (point) (point-max)))))
256 ;; condition ::= or-expr
257 (defun elmo-condition-parse ()
258 (or (elmo-condition-parse-or-expr)
259 (elmo-condition-parse-error)))
261 ;; or-expr ::= and-expr /
262 ;; and-expr "|" or-expr
263 (defun elmo-condition-parse-or-expr ()
264 (let ((left (elmo-condition-parse-and-expr)))
265 (if (looking-at "| *")
267 (goto-char (match-end 0))
268 (list 'or left (elmo-condition-parse-or-expr)))
271 ;; and-expr ::= primitive /
272 ;; primitive "&" and-expr
273 (defun elmo-condition-parse-and-expr ()
274 (let ((left (elmo-condition-parse-primitive)))
275 (if (looking-at "& *")
277 (goto-char (match-end 0))
278 (list 'and left (elmo-condition-parse-and-expr)))
281 ;; primitive ::= "(" expr ")" /
282 ;; ["!"] search-key SPACE* ":" SPACE* search-value
283 (defun elmo-condition-parse-primitive ()
286 (goto-char (match-end 0))
287 (prog1 (elmo-condition-parse)
288 (unless (looking-at ") *")
289 (elmo-condition-parse-error))
290 (goto-char (match-end 0))))
291 ;; search-key ::= [A-Za-z-]+
292 ;; ;; "since" / "before" / "last" / "first" /
293 ;; ;; "body" / "flag" / field-name
294 ((looking-at "\\(!\\)? *\\([A-Za-z-]+\\) *: *")
295 (goto-char (match-end 0))
296 (let ((search-key (vector
297 (if (match-beginning 1) 'unmatch 'match)
298 (downcase (elmo-match-buffer 2))
299 (elmo-condition-parse-search-value))))
301 (if (string= (aref search-key 1) "tocc")
302 (if (eq (aref search-key 0) 'match)
304 (vector 'match "to" (aref search-key 2))
305 (vector 'match "cc" (aref search-key 2)))
307 (vector 'unmatch "to" (aref search-key 2))
308 (vector 'unmatch "cc" (aref search-key 2))))
311 ;; search-value ::= quoted / time / number / atom
312 ;; quoted ::= <elisp string expression>
313 ;; time ::= "yesterday" / "lastweek" / "lastmonth" / "lastyear" /
314 ;; number SPACE* "daysago" /
315 ;; number "-" month "-" number ; ex. 10-May-2000
316 ;; number "-" number "-" number ; ex. 2000-05-10
318 ;; month ::= "Jan" / "Feb" / "Mar" / "Apr" / "May" / "Jun" /
319 ;; "Jul" / "Aug" / "Sep" / "Oct" / "Nov" / "Dec"
320 ;; atom ::= ATOM_CHARS*
321 ;; SPACE ::= <ascii space character, 0x20>
322 ;; ATOM_CHARS ::= <any character except specials>
323 ;; specials ::= SPACE / <"> / </> / <)> / <|> / <&>
324 ;; ;; These characters should be quoted.
325 (defun elmo-condition-parse-search-value ()
328 (read (current-buffer)))
329 ((or (looking-at elmo-condition-atom-regexp)
330 (looking-at "yesterday") (looking-at "lastweek")
331 (looking-at "lastmonth") (looking-at "lastyear")
332 (looking-at "[0-9]+ *daysago")
333 (looking-at "[0-9]+-[A-Za-z]+-[0-9]+")
334 (looking-at "[0-9]+-[0-9]+-[0-9]+")
335 (looking-at "[0-9]+"))
336 (prog1 (elmo-match-buffer 0)
337 (goto-char (match-end 0))))
338 (t (error "Syntax error '%s'" (buffer-string)))))
340 (defmacro elmo-filter-condition-p (filter)
341 `(or (vectorp ,filter) (consp ,filter)))
343 (defmacro elmo-filter-type (filter)
346 (defmacro elmo-filter-key (filter)
349 (defmacro elmo-filter-value (filter)
352 (defun elmo-condition-match (condition match-primitive args)
355 (if (eq (elmo-filter-type condition) 'unmatch)
356 (not (apply match-primitive condition args))
357 (apply match-primitive condition args)))
358 ((eq (car condition) 'and)
359 (let ((lhs (elmo-condition-match (nth 1 condition) match-primitive args)))
361 ((elmo-filter-condition-p lhs)
362 (let ((rhs (elmo-condition-match (nth 2 condition)
363 match-primitive args)))
364 (cond ((elmo-filter-condition-p rhs)
369 (elmo-condition-match (nth 2 condition) match-primitive args)))))
370 ((eq (car condition) 'or)
371 (let ((lhs (elmo-condition-match (nth 1 condition) match-primitive args)))
373 ((elmo-filter-condition-p lhs)
374 (let ((rhs (elmo-condition-match (nth 2 condition)
375 match-primitive args)))
376 (cond ((elmo-filter-condition-p rhs)
385 (elmo-condition-match (nth 2 condition) match-primitive args)))))))
387 (defun elmo-condition-optimize (condition)
390 (let ((key (elmo-filter-key condition)))
391 (cond ((cdr (assoc key '(("first" . 0)
395 ((member key '("since" "before" "from" "subject" "to" "cc"))
397 ((member key elmo-msgdb-extra-fields)
402 (let ((weight-l (elmo-condition-optimize (nth 1 condition)))
403 (weight-r (elmo-condition-optimize (nth 2 condition))))
404 (if (> weight-l weight-r)
405 (let ((lhs (nth 1 condition)))
406 (setcar (nthcdr 1 condition) (nth 2 condition))
407 (setcar (nthcdr 2 condition) lhs)
412 (defsubst elmo-buffer-replace (regexp &optional newtext)
413 (goto-char (point-min))
414 (while (re-search-forward regexp nil t)
415 (replace-match (or newtext ""))))
417 (defsubst elmo-delete-char (char string &optional unibyte)
420 (let ((coding-system-for-read 'no-conversion)
421 (coding-system-for-write 'no-conversion))
422 (if unibyte (set-buffer-multibyte nil))
424 (goto-char (point-min))
425 (while (search-forward (char-to-string char) nil t)
429 (defsubst elmo-delete-cr-buffer ()
430 "Delete CR from buffer."
432 (goto-char (point-min))
433 (while (search-forward "\r\n" nil t)
434 (replace-match "\n")) ))
436 (defsubst elmo-delete-cr-get-content-type ()
438 (goto-char (point-min))
439 (while (search-forward "\r\n" nil t)
440 (replace-match "\n"))
441 (goto-char (point-min))
442 (or (std11-field-body "content-type")
445 (defun elmo-delete-cr (string)
449 (goto-char (point-min))
450 (while (search-forward "\r\n" nil t)
451 (replace-match "\n"))
454 (defun elmo-last (list)
455 (and list (nth (1- (length list)) list)))
457 (defun elmo-set-list (vars vals)
460 (set (car vars) (car vals)))
461 (setq vars (cdr vars)
464 (defun elmo-uniq-list (lst &optional delete-function)
465 "Distractively uniqfy elements of LST."
466 (setq delete-function (or delete-function #'delete))
472 (funcall delete-function
477 (defun elmo-uniq-sorted-list (list &optional equal-function)
478 "Distractively uniqfy elements of sorted LIST."
479 (setq equal-function (or equal-function #'equal))
482 (while (funcall equal-function (car list) (cadr list))
483 (setcdr list (cddr list)))
484 (setq list (cdr list))))
487 (defun elmo-union (l1 l2)
488 "Make a union of two lists"
489 (elmo-uniq-sorted-list (sort (append l1 l2) #'<)))
491 (defun elmo-list-insert (list element after)
492 (let* ((match (memq after list))
493 (rest (and match (cdr (memq after list)))))
496 (setcdr match (list element))
498 (nconc list (list element)))))
500 (defun elmo-get-file-string (filename &optional remove-final-newline)
502 (let (insert-file-contents-pre-hook ; To avoid autoconv-xmas...
503 insert-file-contents-post-hook)
504 (when (file-exists-p filename)
506 (as-binary-input-file (insert-file-contents filename)))
507 (when (and remove-final-newline
509 (= (char-after (1- (point-max))) ?\n))
510 (goto-char (point-max))
511 (delete-backward-char 1))
514 (defun elmo-save-string (string filename)
517 (as-binary-output-file
519 (write-region (point-min) (point-max)
520 filename nil 'no-msg))
523 (defun elmo-max-of-list (nlist)
527 (if (< max-num (car l))
528 (setq max-num (car l)))
532 (defun elmo-concat-path (path filename)
533 (if (not (string= path ""))
534 (elmo-replace-in-string
535 (if (string= elmo-path-sep (substring path (- (length path) 1)))
536 (concat path filename)
537 (concat path elmo-path-sep filename))
538 (concat (regexp-quote elmo-path-sep)(regexp-quote elmo-path-sep))
542 (defvar elmo-passwd-alist nil)
544 (defun elmo-passwd-alist-load ()
545 (let ((filename (expand-file-name elmo-passwd-alist-file-name
546 elmo-msgdb-directory)))
547 (if (not (file-readable-p filename))
550 (let (insert-file-contents-pre-hook ; To avoid autoconv-xmas...
551 insert-file-contents-post-hook)
552 (insert-file-contents filename)
553 (goto-char (point-min))
555 (read (current-buffer))))))))
557 (defun elmo-passwd-alist-clear ()
558 "Clear password cache."
560 (dolist (pair elmo-passwd-alist)
561 (when (stringp (cdr-safe pair))
562 (fillarray (cdr pair) 0)))
563 (setq elmo-passwd-alist nil))
565 (defun elmo-passwd-alist-save ()
566 "Save password into file."
569 (let ((filename (expand-file-name elmo-passwd-alist-file-name
570 elmo-msgdb-directory))
571 print-length print-level)
572 (prin1 elmo-passwd-alist (current-buffer))
573 (princ "\n" (current-buffer))
574 ;;; (if (and (file-exists-p filename)
575 ;;; (not (equal 384 (file-modes filename))))
576 ;;; (error "%s is not safe.chmod 600 %s!" filename filename))
577 (if (file-writable-p filename)
579 (write-region (point-min) (point-max)
580 filename nil 'no-msg)
581 (set-file-modes filename 384))
582 (message "%s is not writable." filename)))))
584 (defun elmo-get-passwd (key)
585 "Get password from password pool."
587 (if (not elmo-passwd-alist)
588 (setq elmo-passwd-alist (elmo-passwd-alist-load)))
589 (setq pair (assoc key elmo-passwd-alist))
591 (elmo-base64-decode-string (cdr pair))
592 (setq pass (elmo-read-passwd (format "Password for %s: "
594 (setq elmo-passwd-alist
595 (append elmo-passwd-alist
597 (elmo-base64-encode-string pass)))))
598 (if elmo-passwd-life-time
599 (run-with-timer elmo-passwd-life-time nil
600 `(lambda () (elmo-remove-passwd ,key))))
603 (defun elmo-remove-passwd (key)
604 "Remove password from password pool (for failure)."
606 (while (setq pass-cons (assoc key elmo-passwd-alist))
608 (fillarray (cdr pass-cons) 0)
609 (setq elmo-passwd-alist
610 (delete pass-cons elmo-passwd-alist))))))
612 (defmacro elmo-read-char-exclusive ()
613 (cond ((featurep 'xemacs)
614 '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?)
619 (key-press-event-p (setq event (next-command-event)))
620 (setq key (or (event-to-character event)
621 (cdr (assq (event-key event) table)))))))
623 ((fboundp 'read-char-exclusive)
624 '(read-char-exclusive))
628 (defun elmo-read-passwd (prompt &optional stars)
629 "Read a single line of text from user without echoing, and return it."
633 (cursor-in-echo-area t)
634 (log-message-max-size 0)
635 message-log-max done msg truncate)
637 (if (or (not stars) (string= "" ans))
639 (setq msg (concat prompt (make-string (length ans) ?.)))
641 (1+ (- (length msg) (window-width (minibuffer-window)))))
643 (setq msg (concat "$" (substring msg (1+ truncate))))))
645 (setq c (elmo-read-char-exclusive))
649 ((or (= c ?\r) (= c ?\n) (= c ?\e))
653 ((and (/= c ?\b) (/= c ?\177))
654 (setq ans (concat ans (char-to-string c))))
656 (setq ans (substring ans 0 -1)))))
665 (defun elmo-string-to-list (string)
668 (goto-char (point-min))
670 (goto-char (point-max))
672 (goto-char (point-min))
673 (read (current-buffer))))
675 (defun elmo-list-to-string (list)
684 (if (symbolp (car tlist))
685 (symbol-name (car tlist))
690 (setq tlist (cdr tlist)))
700 (defun elmo-plug-on-by-servers (alist &optional servers)
701 (let ((server-list (or servers elmo-plug-on-servers)))
704 (if (elmo-plugged-p (car server-list))
706 (setq server-list (cdr server-list))))))
708 (defun elmo-plug-on-by-exclude-servers (alist &optional servers)
709 (let ((server-list (or servers elmo-plug-on-exclude-servers))
710 server other-servers)
712 (when (and (not (member (setq server (caaar alist)) server-list))
713 (not (member server other-servers)))
714 (push server other-servers))
715 (setq alist (cdr alist)))
716 (elmo-plug-on-by-servers alist other-servers)))
718 (defun elmo-plugged-p (&optional server port stream-type alist label-exp)
719 (let ((alist (or alist elmo-plugged-alist))
721 (cond ((and (not port) (not server))
722 (cond ((eq elmo-plugged-condition 'one)
726 (if (nth 2 (car alist))
728 (setq alist (cdr alist))))
730 ((eq elmo-plugged-condition 'all)
734 (if (not (nth 2 (car alist)))
735 (throw 'plugged nil))
736 (setq alist (cdr alist)))
739 ((functionp elmo-plugged-condition)
740 (funcall elmo-plugged-condition alist))
743 ((not port) ;; server
746 (when (string= server (caaar alist))
747 (if (nth 2 (car alist))
749 (setq alist (cdr alist)))))
751 (setq plugged-info (assoc (list server port stream-type) alist))
752 (if (not plugged-info)
753 ;; add elmo-plugged-alist automatically
755 (elmo-set-plugged elmo-plugged server port stream-type
756 nil nil nil label-exp)
758 (if (and elmo-auto-change-plugged
759 (> elmo-auto-change-plugged 0)
760 (nth 3 plugged-info) ;; time
761 (elmo-time-expire (nth 3 plugged-info)
762 elmo-auto-change-plugged))
764 (nth 2 plugged-info)))))))
766 (defun elmo-set-plugged (plugged &optional server port stream-type time
768 (let ((alist (or alist elmo-plugged-alist))
770 (cond ((and (not port) (not server))
771 (setq elmo-plugged plugged)
772 ;; set plugged all element of elmo-plugged-alist.
774 (setcdr (cdar alist) (list plugged time))
775 (setq alist (cdr alist))))
777 ;; set plugged all port of server
779 (when (string= server (caaar alist))
780 (setcdr (cdar alist) (list plugged time)))
781 (setq alist (cdr alist))))
783 ;; set plugged one port of server
784 (setq plugged-info (assoc (list server port stream-type) alist))
785 (setq label (if label-exp
787 (nth 1 plugged-info)))
789 ;; if add is non-nil, don't reset plug state.
791 (setcdr plugged-info (list label plugged time)))
793 (setq elmo-plugged-alist
797 (list (list server port stream-type)
798 label plugged time))))))))
801 (defun elmo-delete-plugged (&optional server port alist)
802 (let* ((alist (or alist elmo-plugged-alist))
804 (cond ((and (not port) (not server))
807 ;; delete plugged all port of server
809 (when (string= server (caaar alist2))
810 (setq alist (delete (car alist2) alist)))
811 (setq alist2 (cdr alist2))))
813 ;; delete plugged one port of server
815 (delete (assoc (cons server port) alist) alist))))
818 (defun elmo-disk-usage (path)
819 "Get disk usage (bytes) in PATH."
821 (condition-case () (file-attributes path) (error nil))))
823 (if (nth 0 file-attr) ; directory
824 (let ((files (condition-case ()
825 (directory-files path t "^[^\\.]")
828 ;;; (result (nth 7 file-attr))) ; ... directory size
830 (setq result (+ result (or (elmo-disk-usage (car files)) 0)))
831 (setq files (cdr files)))
833 (float (nth 7 file-attr)))
836 (defun elmo-get-last-accessed-time (path &optional dir)
837 "Return the last accessed time of PATH."
838 (let ((last-accessed (nth 4 (file-attributes (or (and dir
843 (setq last-accessed (+ (* (nth 0 last-accessed)
844 (float 65536)) (nth 1 last-accessed)))
847 (defun elmo-get-last-modification-time (path &optional dir)
848 "Return the last accessed time of PATH."
849 (let ((last-modified (nth 5 (file-attributes (or (and dir
853 (setq last-modified (+ (* (nth 0 last-modified)
854 (float 65536)) (nth 1 last-modified)))))
856 (defun elmo-make-directory (path &optional mode)
857 "Create directory recursively."
858 (let ((parent (directory-file-name (file-name-directory path))))
859 (if (null (file-directory-p parent))
860 (elmo-make-directory parent))
861 (make-directory path)
862 (set-file-modes path (or mode
863 (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700
865 (defun elmo-delete-directory (path &optional no-hierarchy)
866 "Delete directory recursively."
867 (if (stringp path) ; nil is not permitted.
868 (let ((dirent (directory-files path))
869 relpath abspath hierarchy)
871 (setq relpath (car dirent)
873 abspath (expand-file-name relpath path))
874 (when (not (string-match "^\\.\\.?$" relpath))
875 (if (eq (nth 0 (file-attributes abspath)) t)
878 (elmo-delete-directory abspath no-hierarchy))
879 (delete-file abspath))))
881 (delete-directory path)))))
883 (defun elmo-delete-match-files (path regexp &optional remove-if-empty)
884 "Delete directory files specified by PATH.
885 If optional REMOVE-IF-EMPTY is non-nil, delete directory itself if
886 the directory becomes empty after deletion."
887 (when (stringp path) ; nil is not permitted.
888 (dolist (file (directory-files path t regexp))
892 (delete-directory path) ; should be removed if empty.
895 (defun elmo-list-filter (l1 l2)
896 "Return a list from L2 in which each element is a member of L1."
899 (if (memq element l1)
900 (setq result (cons element result))))
903 (defsubst elmo-list-delete-if-smaller (list number)
904 (let ((ret-val (copy-sequence list)))
906 (if (< (car list) number)
907 (setq ret-val (delq (car list) ret-val)))
908 (setq list (cdr list)))
911 (defun elmo-list-diff (list1 list2)
912 (let ((clist1 (sort (copy-sequence list1) #'<))
913 (clist2 (sort (copy-sequence list2) #'<))
914 list1-only list2-only)
915 (while (or clist1 clist2)
919 (setq list2-only (cons (car clist2) list2-only))
920 (setq clist2 (cdr clist2))))
923 (setq list1-only (cons (car clist1) list1-only))
924 (setq clist1 (cdr clist1))))
925 ((< (car clist1) (car clist2))
926 (while (and clist1 (< (car clist1) (car clist2)))
927 (setq list1-only (cons (car clist1) list1-only))
928 (setq clist1 (cdr clist1))))
929 ((< (car clist2) (car clist1))
930 (while (and clist2 (< (car clist2) (car clist1)))
931 (setq list2-only (cons (car clist2) list2-only))
932 (setq clist2 (cdr clist2))))
933 ((= (car clist1) (car clist2))
934 (setq clist1 (cdr clist1)
935 clist2 (cdr clist2)))))
936 (list list1-only list2-only)))
938 (defun elmo-list-diff-nonsortable (list1 list2)
939 (let ((clist1 (copy-sequence list1))
940 (clist2 (copy-sequence list2)))
942 (setq clist1 (delq (car list2) clist1))
943 (setq list2 (cdr list2)))
945 (setq clist2 (delq (car list1) clist2))
946 (setq list1 (cdr list1)))
947 (list clist1 clist2)))
949 (defmacro elmo-get-hash-val (string hashtable)
950 (static-if (fboundp 'unintern)
951 `(symbol-value (intern-soft ,string ,hashtable))
952 `(let ((sym (intern-soft ,string ,hashtable)))
954 (symbol-value sym)))))
956 (defmacro elmo-set-hash-val (string value hashtable)
957 `(set (intern ,string ,hashtable) ,value))
959 (defmacro elmo-clear-hash-val (string hashtable)
960 (static-if (fboundp 'unintern)
961 (list 'unintern string hashtable)
962 (list 'makunbound (list 'intern string hashtable))))
964 (defmacro elmo-unintern (string)
965 "`unintern' symbol named STRING, When can use `unintern'.
966 Emacs 19.28 or earlier does not have `unintern'."
967 (static-if (fboundp 'unintern)
968 (list 'unintern string)))
970 (defun elmo-make-hash (&optional hashsize)
971 "Make a new hash table which have HASHSIZE size."
975 ;; Prime numbers as lengths tend to result in good
976 ;; hashing; lengths one less than a power of two are
980 (while (< (- i 1) hashsize)
983 elmo-hash-maximum-size)
984 elmo-hash-minimum-size)
985 elmo-hash-minimum-size)
988 (defsubst elmo-mime-string (string)
989 "Normalize MIME encoded STRING."
991 (elmo-with-enable-multibyte
992 (encode-mime-charset-string
994 (eword-decode-and-unfold-unstructured-field-body string))
996 elmo-mime-charset))))
998 (defsubst elmo-collect-field (beg end downcase-field-name)
1001 (narrow-to-region beg end)
1002 (goto-char (point-min))
1003 (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1005 (while (re-search-forward regexp nil t)
1006 (setq name (buffer-substring-no-properties
1007 (match-beginning 1)(1- (match-end 1))))
1008 (if downcase-field-name
1009 (setq name (downcase name)))
1010 (setq body (buffer-substring-no-properties
1011 (match-end 0) (std11-field-end)))
1012 (or (assoc name dest)
1013 (setq dest (cons (cons name body) dest))))
1016 (defsubst elmo-collect-field-from-string (string downcase-field-name)
1019 (goto-char (point-min))
1020 (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1022 (while (re-search-forward regexp nil t)
1023 (setq name (buffer-substring-no-properties
1024 (match-beginning 1)(1- (match-end 1))))
1025 (if downcase-field-name
1026 (setq name (downcase name)))
1027 (setq body (buffer-substring-no-properties
1028 (match-end 0) (std11-field-end)))
1029 (or (assoc name dest)
1030 (setq dest (cons (cons name body) dest))))
1033 (defun elmo-safe-filename (filename)
1034 (let* ((replace-alist '(("/" . " ")
1039 (regexp-quote (mapconcat 'car replace-alist ""))
1043 (while (string-match regexp rest)
1044 (setq converted (concat converted
1045 (substring rest 0 (match-beginning 0))
1046 (cdr (assoc (substring rest
1050 rest (substring rest (match-end 0))))
1051 (concat converted rest)))
1053 (defvar elmo-filename-replace-chars nil)
1055 (defsubst elmo-replace-string-as-filename (msgid)
1056 "Replace string as filename."
1057 (setq msgid (elmo-replace-in-string msgid " " " "))
1058 (if (null elmo-filename-replace-chars)
1059 (setq elmo-filename-replace-chars
1060 (regexp-quote (mapconcat
1061 'car elmo-filename-replace-string-alist ""))))
1062 (while (string-match (concat "[" elmo-filename-replace-chars "]")
1065 (substring msgid 0 (match-beginning 0))
1068 (match-beginning 0) (match-end 0))
1069 elmo-filename-replace-string-alist))
1070 (substring msgid (match-end 0)))))
1073 (defsubst elmo-recover-string-from-filename (filename)
1074 "Recover string from FILENAME."
1076 (while (string-match " " filename)
1077 (setq tmp (substring filename
1079 (+ (match-end 0) 1)))
1080 (if (string= tmp " ")
1082 (setq tmp (car (rassoc tmp
1083 elmo-filename-replace-string-alist))))
1086 (substring filename 0 (match-beginning 0))
1088 (setq filename (substring filename (+ (match-end 0) 1))))
1089 (concat result filename)))
1091 (defsubst elmo-copy-file (src dst &optional ok-if-already-exists)
1093 (elmo-add-name-to-file src dst ok-if-already-exists)
1094 (error (copy-file src dst ok-if-already-exists t))))
1096 (defsubst elmo-buffer-exists-p (buffer)
1097 (if (bufferp buffer)
1098 (buffer-live-p buffer)
1099 (get-buffer buffer)))
1101 (defsubst elmo-kill-buffer (buffer)
1102 (when (elmo-buffer-exists-p buffer)
1103 (kill-buffer buffer)))
1105 (defun elmo-delete-if (pred lst)
1106 "Return new list contain items which don't satisfy PRED in LST."
1109 (unless (funcall pred (car lst))
1110 (setq result (cons (car lst) result)))
1111 (setq lst (cdr lst)))
1114 (defun elmo-list-delete (list1 list2 &optional delete-function)
1115 "Delete by side effect any occurrences equal to elements of LIST1 from LIST2.
1116 Return the modified LIST2. Deletion is done with `delete'.
1117 Write `(setq foo (elmo-list-delete bar foo))' to be sure of changing
1119 If optional DELETE-FUNCTION is speficied, it is used as delete procedure."
1120 (setq delete-function (or delete-function 'delete))
1122 (setq list2 (funcall delete-function (car list1) list2))
1123 (setq list1 (cdr list1)))
1126 (defun elmo-list-member (list1 list2)
1127 "If any element of LIST1 is member of LIST2, return t."
1130 (if (member (car list1) list2)
1132 (setq list1 (cdr list1)))))
1134 (defun elmo-count-matches (regexp beg end)
1138 (while (re-search-forward regexp end t)
1139 (setq count (1+ count)))
1142 (if (fboundp 'display-error)
1143 (defalias 'elmo-display-error 'display-error)
1144 (defun elmo-display-error (error-object stream)
1145 "A tiny function to display ERROR-OBJECT to the STREAM."
1147 (errobj error-object)
1150 (setq err-mes (concat err-mes (format
1151 (if (stringp (car errobj))
1155 (setq errobj (cdr errobj))
1156 (if errobj (setq err-mes (concat err-mes (if first ": " ", "))))
1158 (princ err-mes stream))))
1160 (if (fboundp 'define-error)
1161 (defalias 'elmo-define-error 'define-error)
1162 (defun elmo-define-error (error doc &optional parents)
1164 (setq parents 'error))
1165 (let ((conds (get parents 'error-conditions)))
1167 (error "Not an error symbol: %s" error))
1169 (list 'error-message doc
1170 'error-conditions (cons error conds))))))
1172 (defvar elmo-progress-counter nil)
1174 (defalias 'elmo-progress-counter-label 'car-safe)
1176 (defmacro elmo-progress-counter-value (counter)
1177 `(aref (cdr ,counter) 0))
1179 (defmacro elmo-progress-counter-set-value (counter value)
1180 `(aset (cdr ,counter) 0 ,value))
1182 (defmacro elmo-progress-counter-total (counter)
1183 `(aref (cdr ,counter) 1))
1185 (defmacro elmo-progress-counter-set-total (counter value)
1186 `(aset (cdr ,counter) 1 ,value))
1188 (defmacro elmo-progress-counter-action (counter)
1189 `(aref (cdr ,counter) 2))
1191 (defmacro elmo-progress-counter-set-action (counter action)
1192 `(aset (cdr ,counter) 2, action))
1194 (defvar elmo-progress-callback-function nil)
1196 (defun elmo-progress-call-callback (counter &optional value)
1197 (when elmo-progress-callback-function
1198 (funcall elmo-progress-callback-function
1199 (elmo-progress-counter-label counter)
1200 (elmo-progress-counter-action counter)
1202 (elmo-progress-counter-value counter))
1203 (elmo-progress-counter-total counter))))
1205 (defun elmo-progress-start (label total action)
1206 (when (and (null elmo-progress-counter)
1209 (let ((counter (cons label (vector 0 total action))))
1210 (elmo-progress-call-callback counter 'start)
1211 (setq elmo-progress-counter
1214 ((elmo-progress-call-callback counter 'query)
1215 (elmo-progress-call-callback counter)
1221 (defun elmo-progress-clear (counter)
1223 (when (and (elmo-progress-counter-label elmo-progress-counter)
1224 (elmo-progress-counter-total elmo-progress-counter))
1225 (elmo-progress-call-callback elmo-progress-counter 100))
1226 (setq elmo-progress-counter nil)))
1228 (defun elmo-progress-done (counter)
1229 (when (elmo-progress-counter-label counter)
1230 (elmo-progress-call-callback counter 'done)))
1232 (defun elmo-progress-notify (label &rest params)
1233 (when (eq label (elmo-progress-counter-label elmo-progress-counter))
1234 (let ((counter elmo-progress-counter))
1235 (if (or (elmo-progress-counter-total counter)
1236 (and (elmo-progress-counter-set-total
1238 (elmo-safe-plist-get params :total))
1239 (elmo-progress-call-callback counter 'query)))
1241 (elmo-progress-counter-set-value
1243 (or (elmo-safe-plist-get params :set)
1244 (+ (elmo-progress-counter-value counter)
1245 (or (elmo-safe-plist-get params :inc)
1248 (elmo-progress-call-callback counter))
1249 (setq elmo-progress-counter t)))))
1251 (defmacro elmo-with-progress-display (spec message &rest body)
1252 "Evaluate BODY with progress message and return its value.
1253 SPEC is a list as followed (LABEL TOTAL [VAR]).
1254 LABEL is an identifier what is specidied by `elmo-progress-notify'.
1255 If TOTAL is nil, the first `elmo-progress-notify' call must be
1256 with a `:total' parameter.
1257 If optional parameter VAR is specified, bind it with a progress counter object.
1258 MESSAGE is a doing part of progress message."
1259 (let ((label (nth 0 spec))
1260 (total (nth 1 spec))
1261 (var (or (nth 2 spec) (make-symbol "--elmo-progress-temp--"))))
1262 `(let ((,var (elmo-progress-start (quote ,label) ,total ,message)))
1267 (elmo-progress-clear ,var))
1268 (elmo-progress-done ,var)))))
1270 (put 'elmo-with-progress-display 'lisp-indent-function '2)
1271 (def-edebug-spec elmo-with-progress-display
1272 ((symbolp form &optional symbolp) form &rest form))
1274 (defun elmo-time-expire (before-time diff-time)
1275 (let* ((current (current-time))
1276 (rest (when (< (nth 1 current) (nth 1 before-time))
1280 (list (- (+ (car current) (if rest -1 0)) (car before-time))
1281 (- (+ (or rest 0) (nth 1 current)) (nth 1 before-time))))
1282 (and (eq (car diff) 0)
1283 (< diff-time (nth 1 diff)))))
1286 (if (fboundp 'std11-fetch-field)
1287 (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
1288 (defalias 'elmo-field-body 'std11-field-body)))
1290 (defun elmo-unfold-field-body (name)
1291 (let ((value (elmo-field-body name)))
1293 (std11-unfold-string value))))
1295 (defun elmo-decoded-field-body (field-name &optional mode)
1296 (let ((field-body (elmo-field-body field-name)))
1299 (elmo-with-enable-multibyte
1300 (mime-decode-field-body field-body field-name mode)))
1303 (defun elmo-address-quote-specials (word)
1304 "Make quoted string of WORD if needed."
1305 (let ((lal (std11-lexical-analyze word)))
1306 (if (or (assq 'specials lal)
1307 (assq 'domain-literal lal))
1308 (prin1-to-string word)
1311 (defmacro elmo-string (string)
1312 "STRING without text property."
1313 `(let ((obj (copy-sequence ,string)))
1314 (and obj (set-text-properties 0 (length obj) nil obj))
1317 (defun elmo-flatten (list-of-list)
1318 "Flatten LIST-OF-LIST."
1321 (mapcar (lambda (element)
1322 (if (listp element) element (list element)))
1325 (defun elmo-y-or-n-p (prompt &optional auto default)
1326 "Same as `y-or-n-p'.
1327 But if optional argument AUTO is non-nil, DEFAULT is returned."
1332 (defun elmo-string-member (string slist)
1334 (dolist (element slist)
1335 (cond ((null element))
1337 (when (string= string element)
1340 (when (string= string (symbol-value element))
1341 (throw 'found t)))))))
1343 (static-cond ((fboundp 'member-ignore-case)
1344 (defalias 'elmo-string-member-ignore-case 'member-ignore-case))
1345 ((fboundp 'compare-strings)
1346 (defun elmo-string-member-ignore-case (elt list)
1347 "Like `member', but ignores differences in case and text representation.
1348 ELT must be a string. Upper-case and lower-case letters are treated as equal.
1349 Unibyte strings are converted to multibyte for comparison."
1350 (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t))))
1351 (setq list (cdr list)))
1354 (defun elmo-string-member-ignore-case (elt list)
1355 "Like `member', but ignores differences in case and text representation.
1356 ELT must be a string. Upper-case and lower-case letters are treated as equal."
1357 (let ((str (downcase elt)))
1358 (while (and list (not (string= str (downcase (car list)))))
1359 (setq list (cdr list)))
1362 (defun elmo-string-match-member (str list &optional case-ignore)
1363 (let ((case-fold-search case-ignore))
1366 (if (string-match (car list) str)
1367 (throw 'member (car list)))
1368 (setq list (cdr list))))))
1370 (defun elmo-string-matched-member (str list &optional case-ignore)
1371 (let ((case-fold-search case-ignore))
1374 (if (string-match str (car list))
1375 (throw 'member (car list)))
1376 (setq list (cdr list))))))
1378 (defsubst elmo-string-delete-match (string pos)
1379 (concat (substring string
1380 0 (match-beginning pos))
1385 (defun elmo-string-match-assoc (key alist &optional case-ignore)
1386 (let ((case-fold-search case-ignore)
1390 (setq a (car alist))
1393 (string-match key (car a)))
1395 (setq alist (cdr alist))))))
1397 (defun elmo-string-matched-assoc (key alist &optional case-ignore)
1398 (let ((case-fold-search case-ignore)
1402 (setq a (car alist))
1405 (string-match (car a) key))
1407 (setq alist (cdr alist))))))
1409 (defun elmo-string-assoc (key alist)
1413 (setq a (car alist))
1416 (string= key (car a)))
1418 (setq alist (cdr alist))))))
1420 (defun elmo-string-assoc-all (key alist)
1423 (if (string= key (car (car alist)))
1427 (setq alist (cdr alist)))
1430 (defun elmo-string-rassoc (key alist)
1434 (setq a (car alist))
1437 (string= key (cdr a)))
1439 (setq alist (cdr alist))))))
1441 (defun elmo-string-rassoc-all (key alist)
1444 (if (string= key (cdr (car alist)))
1448 (setq alist (cdr alist)))
1451 (defun elmo-expand-newtext (newtext original)
1452 (let ((len (length newtext))
1454 c expanded beg N did-expand)
1457 (while (and (< pos len)
1458 (not (= (aref newtext pos) ?\\)))
1459 (setq pos (1+ pos)))
1461 (push (substring newtext beg pos) expanded))
1463 ;; We hit a \; expand it.
1466 c (aref newtext pos))
1467 (if (not (or (= c ?\&)
1470 ;; \ followed by some character we don't expand.
1471 (push (char-to-string c) expanded)
1476 (when (match-beginning N)
1477 (push (substring original (match-beginning N) (match-end N))
1479 (setq pos (1+ pos)))
1481 (apply (function concat) (nreverse expanded))
1484 ;;; Folder parser utils.
1485 (defconst elmo-quoted-specials-list '(?\\ ?\"))
1487 (defun elmo-quoted-token (string)
1489 (std11-wrap-as-quoted-pairs string elmo-quoted-specials-list)
1492 (defun elmo-token-valid-p (token requirement)
1493 (cond ((null requirement))
1494 ((stringp requirement)
1495 (string-match requirement token))
1496 ((functionp requirement)
1497 (funcall requirement token))))
1499 (defun elmo-parse-token (string &optional seps requirement)
1500 "Parse atom from STRING using SEPS as a string of separator char list."
1501 (let ((len (length string))
1502 (seps (and seps (string-to-char-list seps)))
1508 (while (and (< i len) (or in (null sep)))
1509 (setq c (aref string i))
1511 ((and in (eq c ?\\))
1513 content (cons (aref string i) content)
1518 (in (setq content (cons c content)
1522 (t (setq content (cons c content)
1524 (if in (error "Parse error in quoted"))
1525 (let ((atom (if (null content)
1527 (char-list-to-string (nreverse content)))))
1528 (if (elmo-token-valid-p atom requirement)
1529 (cons atom (substring string i))
1530 (cons "" string))))))
1532 (defun elmo-parse-prefixed-element (prefix string &optional seps requirement)
1534 (if (and (not (eq (length string) 0))
1535 (eq (aref string 0) prefix)
1536 (setq parsed (elmo-parse-token (substring string 1) seps))
1537 (elmo-token-valid-p (car parsed) requirement))
1541 (defun elmo-collect-separators (spec)
1543 (let ((result (elmo-collect-separators-internal spec)))
1545 (char-list-to-string (elmo-uniq-list result #'delq))))))
1547 (defun elmo-collect-separators-internal (specs &optional separators)
1549 (let ((spec (car specs)))
1552 (setq separators (elmo-collect-separators-internal spec separators)
1555 (setq separators (cons spec separators)
1558 (setq specs nil)))))
1561 (defun elmo-collect-trail-separators (element specs)
1566 (eq (aref specs 0) element))
1569 (while (setq spec (car specs))
1570 (if (setq result (elmo-collect-trail-separators element spec))
1571 (setq result (concat (if (stringp result) result)
1572 (elmo-collect-separators (cdr specs)))
1574 (setq specs (cdr specs))))
1577 (defun elmo-parse-separated-tokens (string spec)
1578 (let ((result (elmo-parse-separated-tokens-internal string spec)))
1579 (if (eq (car result) t)
1580 (cons nil (cdr result))
1583 (defun elmo-parse-separated-tokens-internal (string spec &optional separators)
1586 (let ((parse (elmo-parse-token string separators)))
1587 (cons (list (cons spec (car parse))) (cdr parse))))
1589 (let ((parse (elmo-parse-token string separators)))
1590 (if (elmo-token-valid-p (car parse) (aref spec 1))
1591 (cons (list (cons (aref spec 0) (car parse))) (cdr parse))
1592 (cons nil string))))
1594 (if (and (> (length string) 0)
1595 (eq (aref string 0) spec))
1596 (cons t (substring string 1))
1603 (setq result (elmo-parse-separated-tokens-internal
1606 (concat (elmo-collect-separators (cdr spec))
1608 (cond ((null (car result))
1609 (throw 'unmatch (cons t string)))
1610 ((eq t (car result)))
1612 (setq tokens (nconc (car result) tokens))))
1613 (setq rest (cdr result)
1615 (cons (or tokens t) rest))))))
1617 (defun elmo-quote-syntactical-element (value element syntax)
1618 (let ((separators (elmo-collect-trail-separators element syntax)))
1620 (string-match (concat "[" separators "]") value))
1621 (elmo-quoted-token value)
1624 ;;; Number set defined by OKAZAKI Tetsurou <okazaki@be.to>
1626 ;; number ::= [0-9]+
1629 ;; number-range ::= "(" beg " . " end ")" ;; cons cell
1630 ;; number-set-elem ::= number / number-range
1631 ;; number-set ::= "(" *number-set-elem ")" ;; list
1633 (defun elmo-number-set-member (number number-set)
1634 "Return non-nil if NUMBER is an element of NUMBER-SET.
1635 The value is actually the tail of NUMBER-RANGE whose car contains NUMBER."
1636 (or (memq number number-set)
1638 (while (and number-set (not found))
1639 (if (and (consp (car number-set))
1640 (and (<= (car (car number-set)) number)
1641 (<= number (cdr (car number-set)))))
1643 (setq number-set (cdr number-set))))
1646 (defun elmo-number-set-append-list (number-set list)
1647 "Append LIST of numbers to the NUMBER-SET.
1648 NUMBER-SET is altered."
1649 (let ((appended number-set))
1651 (setq appended (elmo-number-set-append appended (car list)))
1652 (setq list (cdr list)))
1655 (defun elmo-number-set-append (number-set number)
1656 "Append NUMBER to the NUMBER-SET.
1657 NUMBER-SET is altered."
1658 (let ((number-set-1 number-set)
1660 (while (and number-set (not found))
1661 (setq elem (car number-set))
1664 (eq (+ 1 (cdr elem)) number))
1665 (setcdr elem number)
1667 ((and (integerp elem)
1668 (eq (+ 1 elem) number))
1669 (setcar number-set (cons elem number))
1671 ((or (and (integerp elem) (eq elem number))
1673 (<= (car elem) number)
1674 (<= number (cdr elem))))
1676 (setq number-set (cdr number-set)))
1678 (setq number-set-1 (nconc number-set-1 (list number))))
1681 (defun elmo-number-set-delete-list (number-set list)
1682 "Delete LIST of numbers from the NUMBER-SET.
1683 NUMBER-SET is altered."
1684 (let ((deleted number-set))
1685 (dolist (number list)
1686 (setq deleted (elmo-number-set-delete deleted number)))
1689 (defun elmo-number-set-delete (number-set number)
1690 "Delete NUMBER from the NUMBER-SET.
1691 NUMBER-SET is altered."
1692 (let* ((curr number-set)
1693 (top (cons 'dummy number-set))
1696 (while (and curr (not found))
1697 (setq elem (car curr))
1700 ((eq (car elem) number)
1701 (if (eq (cdr elem) (1+ number))
1702 (setcar curr (cdr elem))
1703 (setcar elem (1+ number)))
1705 ((eq (cdr elem) number)
1706 (if (eq (car elem) (1- number))
1707 (setcar curr (car elem))
1708 (setcdr elem (1- number)))
1710 ((and (> number (car elem))
1711 (< number (cdr elem)))
1716 ;;; (beg . (1- number))
1717 (let ((new (cons (car elem) (1- number))))
1718 (if (eq (car new) (cdr new))
1721 ;;; ((1+ number) . end)
1722 (let ((new (cons (1+ number) (cdr elem))))
1723 (if (eq (car new) (cdr new))
1727 (when (eq elem number)
1728 (setcdr prev (cdr curr))
1734 (defun elmo-make-number-list (beg end)
1735 (let (number-list i)
1738 (setq number-list (cons i number-list))
1742 (defun elmo-number-set-to-number-list (number-set)
1743 "Return a number list which corresponds to NUMBER-SET."
1744 (let ((number-list (list 'dummy))
1747 (setq elem (car number-set))
1750 (nconc number-list (elmo-make-number-list (car elem) (cdr elem))))
1752 (nconc number-list (list elem))))
1753 (setq number-set (cdr number-set)))
1756 (defcustom elmo-list-subdirectories-ignore-regexp "^\\(\\.\\.?\\|[0-9]+\\)$"
1757 "*Regexp to filter subfolders."
1761 (defun elmo-list-subdirectories-1 (basedir curdir one-level)
1762 (let ((root (zerop (length curdir)))
1763 (w32-get-true-file-link-count t) ; for Meadow
1766 (dolist (file (directory-files (setq dir (expand-file-name curdir basedir))))
1767 (when (and (not (string-match
1768 elmo-list-subdirectories-ignore-regexp
1770 (car (setq attr (file-attributes
1771 (expand-file-name file dir)))))
1772 (when (eq one-level 'check) (throw 'done t))
1774 (concat curdir (and (not root) elmo-path-sep) file))
1776 (setq dirs (nconc dirs
1777 (if (if elmo-have-link-count (< 2 (nth 1 attr))
1779 (elmo-list-subdirectories-1
1782 (if one-level 'check))))
1784 (list (list relpath))
1787 (elmo-list-subdirectories-1
1791 (list relpath)))))))
1794 (defun elmo-list-subdirectories (directory file one-level)
1795 (let ((subdirs (elmo-list-subdirectories-1 directory file one-level)))
1796 (if (zerop (length file))
1798 (cons file subdirs))))
1800 (defun elmo-mapcar-list-of-list (func list-of-list)
1803 (cond ((listp x) (elmo-mapcar-list-of-list func x))
1804 (t (funcall func x))))
1807 (defun elmo-map-recursive (function object)
1809 (let* ((prev (list 'dummy))
1811 (while (consp object)
1812 (setq prev (setcdr prev (list (elmo-map-recursive function
1814 object (cdr object)))
1816 (setcdr prev (funcall function object)))
1818 (funcall function object)))
1820 (defun elmo-map-until-success (function sequence)
1822 (while (and (null result)
1824 (setq result (funcall function (car sequence))
1825 sequence (cdr sequence)))
1828 (defun elmo-string-match-substring (regexp string &optional matchn)
1829 (when (string-match regexp string)
1830 (match-string (or matchn 1) string)))
1832 (defun elmo-parse (string regexp &optional matchn)
1833 (or matchn (setq matchn 1))
1835 (store-match-data nil)
1836 (while (string-match regexp string (match-end 0))
1837 (setq list (cons (substring string (match-beginning matchn)
1838 (match-end matchn)) list)))
1841 (defun elmo-find-list-match-value (specs getter)
1842 (lexical-let ((getter getter))
1843 (elmo-map-until-success
1847 (funcall getter spec))
1849 (lexical-let ((value (funcall getter (car spec))))
1851 (elmo-map-until-success
1855 (elmo-string-match-substring rule value))
1857 (elmo-string-match-substring (car rule) value (cdr rule)))))
1862 (defmacro elmo-make-file-cache (path status)
1863 "PATH is the cache file name.
1864 STATUS is one of 'section, 'entire or nil.
1865 nil means no cache exists.
1866 'section means partial section cache exists.
1867 'entire means entire cache exists.
1868 If the cache is partial file-cache, TYPE is 'partial."
1869 `(cons ,path ,status))
1871 (defmacro elmo-file-cache-path (file-cache)
1872 "Returns the file path of the FILE-CACHE."
1875 (defmacro elmo-file-cache-status (file-cache)
1876 "Returns the status of the FILE-CACHE."
1879 (defsubst elmo-cache-to-msgid (filename)
1880 (concat "<" (elmo-recover-string-from-filename filename) ">"))
1882 (defsubst elmo-cache-get-path-subr (msgid)
1883 (let ((chars '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?A ?B ?C ?D ?E ?F))
1884 (clist (string-to-char-list msgid))
1887 (setq sum (+ sum (car clist)))
1888 (setq clist (cdr clist)))
1890 (nth (% (/ sum 16) 2) chars)
1891 (nth (% sum 16) chars))))
1894 (defun elmo-file-cache-get-path (msgid &optional section)
1895 "Get cache path for MSGID.
1896 If optional argument SECTION is specified, partial cache path is returned."
1897 (if (setq msgid (elmo-msgid-to-cache msgid))
1900 (format "%s/%s/%s/%s"
1901 elmo-cache-directory
1902 (elmo-cache-get-path-subr msgid)
1906 elmo-cache-directory
1907 (elmo-cache-get-path-subr msgid)
1910 (defmacro elmo-file-cache-expand-path (path section)
1911 "Return file name for the file-cache corresponds to the section.
1912 PATH is the file-cache path.
1913 SECTION is the section string."
1914 `(expand-file-name (or ,section "") ,path))
1916 (defun elmo-file-cache-delete (path)
1917 "Delete a cache on PATH."
1918 (when (file-exists-p path)
1919 (if (file-directory-p path)
1921 (dolist (file (directory-files path t "^[^\\.]"))
1923 (delete-directory path))
1927 (defun elmo-file-cache-exists-p (msgid)
1928 "Returns 'section or 'entire if a cache which corresponds to MSGID exists."
1929 (elmo-file-cache-status (elmo-file-cache-get msgid)))
1931 (defun elmo-file-cache-save (cache-path section)
1932 "Save current buffer as cache on PATH.
1933 Return t if cache is saved successfully."
1935 (let ((path (if section (expand-file-name section cache-path)
1938 (if (and (null section)
1939 (file-directory-p path))
1941 (setq files (directory-files path t "^[^\\.]"))
1943 (delete-file (car files))
1944 (setq files (cdr files)))
1945 (delete-directory path))
1947 (not (file-directory-p cache-path)))
1948 (delete-file cache-path)))
1950 (setq dir (directory-file-name (file-name-directory path)))
1951 (if (not (file-exists-p dir))
1952 (elmo-make-directory dir))
1953 (write-region-as-binary (point-min) (point-max)
1959 (defun elmo-file-cache-load (cache-path section)
1960 "Load cache on PATH into the current buffer.
1961 Return t if cache is loaded successfully."
1964 (when (and cache-path
1965 (if (elmo-cache-path-section-p cache-path)
1968 (setq cache-file (elmo-file-cache-expand-path
1971 (file-exists-p cache-file))
1972 (insert-file-contents-as-binary cache-file)
1977 (defun elmo-cache-path-section-p (path)
1978 "Return non-nil when PATH is `section' cache path."
1979 (file-directory-p path))
1981 (defun elmo-file-cache-get (msgid &optional section)
1982 "Returns the current file-cache object associated with MSGID.
1983 MSGID is the message-id of the message.
1984 If optional argument SECTION is specified, get partial file-cache object
1985 associated with SECTION."
1987 (let ((path (elmo-cache-get-path msgid)))
1988 (if (and path (file-exists-p path))
1989 (if (elmo-cache-path-section-p path)
1991 (if (file-exists-p (setq path (expand-file-name
1993 (cons path 'section))
1994 ;; section is not specified but sectional.
1995 (cons path 'section))
1998 (cons path 'entire)))
2005 (defun elmo-cache-expire ()
2007 (let* ((completion-ignore-case t)
2008 (method (completing-read (format "Expire by (%s): "
2009 elmo-cache-expire-default-method)
2013 (when (string= method "")
2014 (setq method elmo-cache-expire-default-method))
2015 (funcall (intern (concat "elmo-cache-expire-by-" method)))))
2017 (defun elmo-read-float-value-from-minibuffer (prompt &optional initial)
2018 (let ((str (read-from-minibuffer prompt initial)))
2020 ((string-match "[0-9]*\\.[0-9]+" str)
2021 (string-to-number str))
2022 ((string-match "[0-9]+" str)
2023 (string-to-number (concat str ".0")))
2024 (t (error "%s is not number" str)))))
2026 (defun elmo-cache-expire-by-size (&optional kbytes)
2027 "Expire cache file by size.
2028 If KBYTES is kilo bytes (This value must be float)."
2030 (let ((size (or kbytes
2031 (and (interactive-p)
2032 (elmo-read-float-value-from-minibuffer
2033 "Enter cache disk size (Kbytes): "
2035 (if (integerp elmo-cache-expire-default-size)
2036 (float elmo-cache-expire-default-size)
2037 elmo-cache-expire-default-size))))
2038 (if (integerp elmo-cache-expire-default-size)
2039 (float elmo-cache-expire-default-size))))
2043 (message "Checking disk usage...")
2044 (setq total (/ (elmo-disk-usage
2045 elmo-cache-directory) Kbytes))
2046 (setq beginning total)
2047 (message "Checking disk usage...done")
2048 (let ((cfl (elmo-cache-get-sorted-cache-file-list))
2052 (while (and (<= size total)
2053 (setq oldest (elmo-cache-get-oldest-cache-file-entity cfl)))
2054 (setq cur-file (expand-file-name (car (cdr oldest)) (car oldest)))
2055 (setq cur-size (/ (elmo-disk-usage cur-file) Kbytes))
2056 (when (elmo-file-cache-delete cur-file)
2057 (setq count (+ count 1))
2058 (message "%d cache(s) are expired." count))
2059 (setq deleted (+ deleted cur-size))
2060 (setq total (- total cur-size)))
2061 (message "%d cache(s) are expired from disk (%d Kbytes/%d Kbytes)."
2062 count deleted beginning))))
2064 (defun elmo-cache-make-file-entity (filename path)
2065 (cons filename (elmo-get-last-accessed-time filename path)))
2067 (defun elmo-cache-get-oldest-cache-file-entity (cache-file-list)
2068 (let ((cfl cache-file-list)
2069 flist firsts oldest-entity wonlist)
2071 (setq flist (cdr (car cfl)))
2072 (setq firsts (append firsts (list
2073 (cons (car (car cfl))
2075 (setq cfl (cdr cfl)))
2078 (if (and (not oldest-entity)
2079 (cdr (cdr (car firsts))))
2080 (setq oldest-entity (car firsts)))
2081 (if (and (cdr (cdr (car firsts)))
2082 (cdr (cdr oldest-entity))
2083 (> (cdr (cdr oldest-entity)) (cdr (cdr (car firsts)))))
2084 (setq oldest-entity (car firsts)))
2085 (setq firsts (cdr firsts)))
2086 (setq wonlist (assoc (car oldest-entity) cache-file-list))
2088 (setcdr wonlist (delete (car (cdr wonlist)) (cdr wonlist))))
2091 (defun elmo-cache-get-sorted-cache-file-list ()
2092 (let ((dirs (directory-files elmo-cache-directory t "^[^\\.]"))
2094 (elmo-with-progress-display (elmo-collecting-cache (length dirs))
2095 "Collecting cache info"
2097 (setq elist (mapcar (lambda (x)
2098 (elmo-cache-make-file-entity x dir))
2099 (directory-files dir nil "^[^\\.]")))
2100 (setq ret-val (append ret-val
2110 (defun elmo-cache-expire-by-age (&optional days)
2111 "Expire cache file by age.
2112 Optional argument DAYS specifies the days to expire caches."
2114 (let ((age (or (and days (number-to-string days))
2115 (and (interactive-p)
2116 (read-from-minibuffer
2117 (format "Enter days (%s): "
2118 elmo-cache-expire-default-age)))
2119 (number-to-string elmo-cache-expire-default-age)))
2120 (dirs (directory-files
2121 elmo-cache-directory
2125 (if (string= age "")
2126 (setq age elmo-cache-expire-default-age)
2127 (setq age (string-to-number age)))
2128 (setq curtime (current-time))
2129 (setq curtime (+ (* (nth 0 curtime)
2130 (float 65536)) (nth 1 curtime)))
2132 (let ((files (directory-files (car dirs) t "^[^\\.]"))
2133 (limit-age (* age 86400)))
2135 (when (> (- curtime (elmo-get-last-accessed-time (car files)))
2137 (when (elmo-file-cache-delete (car files))
2138 (setq count (+ 1 count))
2139 (message "%d cache file(s) are expired." count)))
2140 (setq files (cdr files))))
2141 (setq dirs (cdr dirs)))))
2145 (defun elmo-msgid-to-cache (msgid)
2148 (string-match "<\\(.+\\)>$" msgid))
2149 (elmo-replace-string-as-filename (elmo-match-string 1 msgid)))))
2151 (defun elmo-cache-get-path (msgid &optional folder number)
2152 "Get path for cache file associated with MSGID, FOLDER, and NUMBER."
2153 (if (setq msgid (elmo-msgid-to-cache msgid))
2157 (format "%s/%s/%s@%s"
2158 (elmo-cache-get-path-subr msgid)
2161 (elmo-safe-filename folder))
2163 (elmo-cache-get-path-subr msgid)
2165 elmo-cache-directory))))
2170 (static-if (fboundp 'display-warning)
2171 (defmacro elmo-warning (&rest args)
2172 "Display a warning with `elmo' group."
2173 `(display-warning 'elmo (format ,@args)))
2174 (defconst elmo-warning-buffer-name "*elmo warning*")
2175 (defun elmo-warning (&rest args)
2176 "Display a warning. ARGS are passed to `format'."
2177 (with-current-buffer (get-buffer-create elmo-warning-buffer-name)
2178 (goto-char (point-max))
2179 (funcall 'insert (apply 'format (append args '("\n"))))
2180 (ignore-errors (recenter 1))
2181 (display-buffer elmo-warning-buffer-name))))
2183 (defvar elmo-obsolete-variable-alist nil)
2185 (defcustom elmo-obsolete-variable-show-warnings t
2186 "Show warning window if obsolete variable is treated."
2190 (defun elmo-define-obsolete-variable (obsolete var)
2191 "Define obsolete variable.
2192 OBSOLETE is a symbol for obsolete variable.
2193 VAR is a symbol for new variable.
2194 Definition is stored in `elmo-obsolete-variable-alist'."
2195 (let ((pair (assq var elmo-obsolete-variable-alist)))
2197 (setcdr pair obsolete)
2198 (setq elmo-obsolete-variable-alist
2199 (cons (cons var obsolete)
2200 elmo-obsolete-variable-alist)))))
2202 (defun elmo-resque-obsolete-variable (obsolete var)
2203 "Resque obsolete variable OBSOLETE as VAR.
2204 If `elmo-obsolete-variable-show-warnings' is non-nil, show warning message."
2205 (when (boundp obsolete)
2206 (static-if (and (fboundp 'defvaralias)
2207 (subrp (symbol-function 'defvaralias)))
2208 (defvaralias var obsolete)
2209 (set var (symbol-value obsolete)))
2210 (if elmo-obsolete-variable-show-warnings
2211 (elmo-warning "%s is obsolete. Use %s instead."
2212 (symbol-name obsolete)
2213 (symbol-name var)))))
2215 (defun elmo-resque-obsolete-variables (&optional alist)
2216 "Resque obsolete variables in ALIST.
2217 ALIST is a list of cons cell of
2218 \(OBSOLETE-VARIABLE-SYMBOL . NEW-VARIABLE-SYMBOL\).
2219 If ALIST is nil, `elmo-obsolete-variable-alist' is used."
2220 (dolist (pair elmo-obsolete-variable-alist)
2221 (elmo-resque-obsolete-variable (cdr pair)
2224 (defsubst elmo-msgdb-get-last-message-id (string)
2230 (goto-char (point-max))
2231 (when (search-backward "<" nil t)
2233 (if (search-forward ">" nil t)
2234 (elmo-replace-in-string
2235 (buffer-substring beg (point)) "\n[ \t]*" ""))))))))
2237 (defun elmo-msgdb-get-message-id-from-buffer ()
2238 (let ((msgid (elmo-field-body "message-id")))
2240 (if (string-match "<\\(.+\\)>$" msgid)
2242 (concat "<" msgid ">")) ; Invaild message-id.
2243 ;; no message-id, so put dummy msgid.
2245 (if (elmo-unfold-field-body "date")
2246 (timezone-make-date-sortable (elmo-unfold-field-body "date"))
2247 (md5 (string-as-unibyte (buffer-string))))
2248 (nth 1 (eword-extract-address-components
2249 (or (elmo-field-body "from") "nobody"))) ">"))))
2251 (defun elmo-msgdb-get-references-from-buffer ()
2252 (if elmo-msgdb-prefer-in-reply-to-for-parent
2253 (or (elmo-msgdb-get-last-message-id (elmo-field-body "in-reply-to"))
2254 (elmo-msgdb-get-last-message-id (elmo-field-body "references")))
2255 (or (elmo-msgdb-get-last-message-id (elmo-field-body "references"))
2256 (elmo-msgdb-get-last-message-id (elmo-field-body "in-reply-to")))))
2258 (defsubst elmo-msgdb-insert-file-header (file)
2259 "Insert the header of the article."
2261 insert-file-contents-pre-hook ; To avoid autoconv-xmas...
2262 insert-file-contents-post-hook
2264 (when (file-exists-p file)
2265 ;; Read until header separator is found.
2266 (while (and (eq elmo-msgdb-file-header-chop-length
2268 (insert-file-contents-as-binary
2270 (incf beg elmo-msgdb-file-header-chop-length))))
2271 (prog1 (not (search-forward "\n\n" nil t))
2272 (goto-char (point-max)))))
2273 (elmo-delete-cr-buffer))))
2276 ;; overview handling
2278 (defun elmo-multiple-field-body (name &optional boundary)
2281 (std11-narrow-to-header boundary)
2282 (goto-char (point-min))
2283 (let ((case-fold-search t)
2285 (while (re-search-forward (concat "^" name ":[ \t]*") nil t)
2288 (list (buffer-substring-no-properties
2289 (match-end 0) (std11-field-end))))))
2292 (defun elmo-parse-addresses (string)
2296 (let (list start s char)
2298 (goto-char (point-min))
2299 (skip-chars-forward "\t\f\n\r ")
2300 (setq start (point))
2302 (skip-chars-forward "^\"\\,(")
2303 (setq char (following-char))
2309 (setq s (buffer-substring start (point)))
2310 (if (or (null (string-match "^[\t\f\n\r ]+$" s))
2311 (not (string= s "")))
2312 (setq list (cons s list)))
2313 (skip-chars-forward ",\t\f\n\r ")
2314 (setq start (point)))
2316 (re-search-forward "[^\\]\"" nil 0))
2320 (while (and (not (eobp)) (not (zerop parens)))
2321 (re-search-forward "[()]" nil 0)
2323 (= (char-after (- (point) 2)) ?\\)))
2324 ((= (preceding-char) ?\()
2325 (setq parens (1+ parens)))
2327 (setq parens (1- parens)))))))))
2328 (setq s (buffer-substring start (point)))
2329 (if (and (null (string-match "^[\t\f\n\r ]+$" s))
2330 (not (string= s "")))
2331 (setq list (cons s list)))
2335 (defvar elmo-dop-queue-filename "queue"
2336 "*Disconnected operation queue is saved in this file.")
2338 (defun elmo-dop-queue-load ()
2339 (setq elmo-dop-queue
2341 (expand-file-name elmo-dop-queue-filename
2342 elmo-msgdb-directory))))
2344 (defun elmo-dop-queue-save ()
2346 (expand-file-name elmo-dop-queue-filename
2347 elmo-msgdb-directory)
2350 (if (and (fboundp 'regexp-opt)
2351 (not (featurep 'xemacs)))
2352 (defalias 'elmo-regexp-opt 'regexp-opt)
2353 (defun elmo-regexp-opt (strings &optional paren)
2354 "Return a regexp to match a string in STRINGS.
2355 Each string should be unique in STRINGS and should not contain any regexps,
2356 quoted or not. If optional PAREN is non-nil, ensure that the returned regexp
2357 is enclosed by at least one regexp grouping construct."
2358 (let ((open-paren (if paren "\\(" "")) (close-paren (if paren "\\)" "")))
2359 (concat open-paren (mapconcat 'regexp-quote strings "\\|")
2363 (product-provide (provide 'elmo-util) (require 'elmo-version))
2365 ;;; elmo-util.el ends here