* Version number is increased to 2.5.8.
[elisp/wanderlust.git] / elmo / elmo-util.el
1 ;;; elmo-util.el -- Utilities for Elmo.
2
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
4
5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
6 ;; Keywords: mail, net news
7
8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
9
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)
13 ;; any later version.
14 ;;
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.
19 ;;
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.
24 ;;
25
26 ;;; Commentary:
27 ;; 
28
29 ;;; Code:
30 ;; 
31
32 (require 'elmo-vars)
33 (require 'elmo-date)
34 (eval-when-compile (require 'cl))
35 (require 'std11)
36 (require 'eword-decode)
37 (require 'utf7)
38
39 (defmacro elmo-set-buffer-multibyte (flag)
40   "Set the multibyte flag of the current buffer to FLAG."
41   (cond ((boundp 'MULE)
42          (list 'setq 'mc-flag flag))
43         ((featurep 'xemacs)
44          flag)
45         ((and (boundp 'emacs-major-version) (>= emacs-major-version 20))
46          (list 'set-buffer-multibyte flag))
47         (t
48          flag)))
49
50 (defvar elmo-work-buf-name " *elmo work*")
51 (defvar elmo-temp-buf-name " *elmo temp*")
52
53 (or (boundp 'default-enable-multibyte-characters)
54     (defvar default-enable-multibyte-characters (featurep 'mule)
55       "The mock variable except for Emacs 20."))
56
57 (defun elmo-base64-encode-string (string &optional no-line-break))
58 (defun elmo-base64-decode-string (string))
59
60 ;; base64 encoding/decoding
61 (require 'mel)
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"))
66
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)))
74
75 (defsubst elmo-call-func (folder func-name &rest args)
76   (let* ((spec (if (stringp folder)
77                    (elmo-folder-get-spec folder)
78                  folder))
79          (type (symbol-name (car spec)))
80          (backend-str (concat "elmo-" type))
81          (backend-sym (intern backend-str)))
82     (unless (featurep backend-sym)
83       (require backend-sym))
84     (apply (intern (format "%s-%s" backend-str func-name))
85            spec
86            args)))
87
88 ;; Nemacs's `read' is different.
89 (static-if (fboundp 'nemacs-version)
90     (defun elmo-read (obj)
91       (prog1 (read obj)
92         (if (bufferp obj)
93             (or (bobp) (forward-char -1)))))
94   (defalias 'elmo-read 'read))
95
96 (defmacro elmo-set-work-buf (&rest body)
97   "Execute BODY on work buffer.  Work buffer remains."
98   (` (save-excursion
99        (set-buffer (get-buffer-create elmo-work-buf-name))
100        (elmo-set-buffer-multibyte default-enable-multibyte-characters)
101        (erase-buffer)
102        (,@ body))))
103
104 (defmacro elmo-match-substring (pos string from)
105   "Substring of POSth matched string of STRING."
106   (` (substring (, string)
107                 (+ (match-beginning (, pos)) (, from))
108                 (match-end (, pos)))))
109
110 (defmacro elmo-match-string (pos string)
111   "Substring POSth matched STRING."
112   (` (substring (, string) (match-beginning (, pos)) (match-end (, pos)))))
113
114 (defmacro elmo-match-buffer (pos)
115   "Substring POSth matched from the current buffer."
116   (` (buffer-substring-no-properties
117       (match-beginning (, pos)) (match-end (, pos)))))
118
119 (defmacro elmo-bind-directory (dir &rest body)
120   "Set current directory DIR and execute BODY."
121   (` (let ((default-directory (file-name-as-directory (, dir))))
122        (,@ body))))
123
124 (defmacro elmo-folder-get-type (folder)
125   "Get type of FOLDER."
126   (` (and (stringp (, folder))
127           (cdr (assoc (string-to-char (, folder)) elmo-spec-alist)))))
128
129 (defun elmo-object-load (filename &optional mime-charset no-err)
130   "Load OBJECT from the file specified by FILENAME.
131 File content is decoded with MIME-CHARSET."
132     (if (not (file-readable-p filename))
133         nil
134       (elmo-set-work-buf
135        (as-binary-input-file
136         (insert-file-contents filename))
137        (when mime-charset
138          (elmo-set-buffer-multibyte default-enable-multibyte-characters)
139          (decode-mime-charset-region (point-min) (point-max) mime-charset))
140        (condition-case nil
141            (read (current-buffer))
142          (error (unless no-err
143                   (message "Warning: Loading object from %s failed."
144                            filename)
145                   (elmo-object-save filename nil))
146                 nil)))))
147
148 (defsubst elmo-save-buffer (filename &optional mime-charset)
149   "Save current buffer to the file specified by FILENAME.
150 Directory of the file is created if it doesn't exist.
151 File content is encoded with MIME-CHARSET."
152   (let ((dir (directory-file-name (file-name-directory filename))))
153     (if (file-directory-p dir)
154         () ; ok.
155       (unless (file-exists-p dir)
156         (elmo-make-directory dir)))
157     (if (file-writable-p filename)
158         (progn
159           (when mime-charset
160 ;;;         (elmo-set-buffer-multibyte default-enable-multibyte-characters)
161             (encode-mime-charset-region (point-min) (point-max) mime-charset))
162           (as-binary-output-file
163            (write-region (point-min) (point-max) filename nil 'no-msg)))
164       (message (format "%s is not writable." filename)))))
165
166 (defun elmo-object-save (filename object &optional mime-charset)
167   "Save OBJECT to the file specified by FILENAME.
168 Directory of the file is created if it doesn't exist.
169 File content is encoded with MIME-CHARSET."
170   (elmo-set-work-buf
171    (prin1 object (current-buffer))
172 ;;;(princ "\n" (current-buffer))
173    (elmo-save-buffer filename mime-charset)))
174
175 (defsubst elmo-imap4-decode-folder-string (string)
176   (if elmo-imap4-use-modified-utf7
177       (utf7-decode-string string 'imap)
178     string))
179
180 (defsubst elmo-imap4-encode-folder-string (string)
181   (if elmo-imap4-use-modified-utf7
182       (utf7-encode-string string 'imap)
183     string))
184
185 (defun elmo-get-network-stream-type (stream-type stream-type-alist)
186   (catch 'found
187     (while stream-type-alist
188       (if (eq (nth 1 (car stream-type-alist)) stream-type)
189           (throw 'found (car stream-type-alist)))
190       (setq stream-type-alist (cdr stream-type-alist)))))
191
192 (defun elmo-network-get-spec (folder server port stream-type stream-type-alist)
193   (setq stream-type (elmo-get-network-stream-type
194                      stream-type stream-type-alist))
195   (when (string-match "\\(@[^@:/!]+\\)?\\(:[0-9]+\\)?\\(!.*\\)?$" folder)
196     (if (match-beginning 1)
197         (setq server (elmo-match-substring 1 folder 1)))
198     (if (match-beginning 2)
199         (setq port (string-to-int (elmo-match-substring 2 folder 1))))
200     (if (match-beginning 3)
201         (setq stream-type (assoc (elmo-match-string 3 folder)
202                                  stream-type-alist)))
203     (setq folder (substring folder 0 (match-beginning 0))))
204   (cons folder (list server port stream-type)))
205
206 (defun elmo-imap4-get-spec (folder)
207   (let ((default-user        elmo-default-imap4-user)
208         (default-server      elmo-default-imap4-server)
209         (default-port        elmo-default-imap4-port)
210         (default-stream-type elmo-default-imap4-stream-type)
211         (stream-type-alist elmo-network-stream-type-alist)
212         spec mailbox user auth)
213     (when (string-match "\\(.*\\)@\\(.*\\)" default-server)
214       ;; case: default-imap4-server is specified like
215       ;; "hoge%imap.server@gateway".
216       (setq default-user (elmo-match-string 1 default-server))
217       (setq default-server (elmo-match-string 2 default-server)))
218     (if elmo-imap4-stream-type-alist
219         (setq stream-type-alist
220               (append elmo-imap4-stream-type-alist stream-type-alist)))
221     (setq spec (elmo-network-get-spec
222                 folder default-server default-port default-stream-type
223                 stream-type-alist))
224     (setq folder (car spec))
225     (when (string-match
226            "^\\(%\\)\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?"
227            folder)
228       (progn
229         (setq mailbox (if (match-beginning 2)
230                           (elmo-match-string 2 folder)
231                         elmo-default-imap4-mailbox))
232         (setq user (if (match-beginning 3)
233                        (elmo-match-substring 3 folder 1)
234                      default-user))
235         (setq auth (if (match-beginning 4)
236                        (intern (elmo-match-substring 4 folder 1))
237                      elmo-default-imap4-authenticate-type))
238         (setq auth (or auth 'clear))
239         (append (list 'imap4
240                       (elmo-imap4-encode-folder-string mailbox)
241                       user auth)
242                 (cdr spec))))))
243
244 (defsubst elmo-imap4-spec-mailbox (spec)
245   (nth 1 spec))
246
247 (defsubst elmo-imap4-spec-username (spec)
248   (nth 2 spec))
249
250 (defsubst elmo-imap4-spec-auth (spec)
251   (nth 3 spec))
252
253 (defsubst elmo-imap4-spec-hostname (spec)
254   (nth 4 spec))
255
256 (defsubst elmo-imap4-spec-port (spec)
257   (nth 5 spec))
258
259 (defsubst elmo-imap4-spec-stream-type (spec)
260   (nth 6 spec))
261
262 (defalias 'elmo-imap4-spec-folder 'elmo-imap4-spec-mailbox)
263 (make-obsolete 'elmo-imap4-spec-folder 'elmo-imap4-spec-mailbox)
264
265 (defsubst elmo-imap4-connection-get-process (conn)
266   (nth 1 conn))
267
268 (defsubst elmo-imap4-connection-get-buffer (conn)
269   (nth 0 conn))
270
271 (defsubst elmo-imap4-connection-get-cwf (conn)
272   (nth 2 conn))
273
274 (defun elmo-nntp-get-spec (folder)
275   (let ((stream-type-alist elmo-network-stream-type-alist)
276         spec group user)
277     (if elmo-nntp-stream-type-alist
278         (setq stream-type-alist
279               (append elmo-nntp-stream-type-alist stream-type-alist)))
280     (setq spec (elmo-network-get-spec folder
281                                       elmo-default-nntp-server
282                                       elmo-default-nntp-port
283                                       elmo-default-nntp-stream-type
284                                       stream-type-alist))
285     (setq folder (car spec))
286     (when (string-match
287            "^\\(-\\)\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?"
288            folder)
289       (setq group
290             (if (match-beginning 2)
291                 (elmo-match-string 2 folder)))
292       (setq user
293             (if (match-beginning 3)
294                 (elmo-match-substring 3 folder 1)
295               elmo-default-nntp-user))
296       (append (list 'nntp group user)
297               (cdr spec)))))
298
299 (defsubst elmo-nntp-spec-group (spec)
300   (nth 1 spec))
301
302 (defsubst elmo-nntp-spec-username (spec)
303   (nth 2 spec))
304
305 ;; future use?
306 ;; (defsubst elmo-nntp-spec-auth (spec))
307
308 (defsubst elmo-nntp-spec-hostname (spec)
309   (nth 3 spec))
310
311 (defsubst elmo-nntp-spec-port (spec)
312   (nth 4 spec))
313
314 (defsubst elmo-nntp-spec-stream-type (spec)
315   (nth 5 spec))
316
317 (defun elmo-localdir-get-spec (folder)
318   (let (fld-name path)
319     (when (string-match
320            "^\\(\\+\\)\\(.*\\)$"
321            folder)
322       (if (eq (length (setq fld-name
323                             (elmo-match-string 2 folder))) 0)
324           (setq fld-name "")
325         )
326       (if (file-name-absolute-p fld-name)
327           (setq path (expand-file-name fld-name))
328 ;;;     (setq path (expand-file-name fld-name
329 ;;;                                  elmo-localdir-folder-path))
330         (setq path fld-name))
331       (list (if (elmo-folder-maildir-p folder)
332                 'maildir
333               'localdir) path))))
334
335 (defun elmo-maildir-get-spec (folder)
336   (let (fld-name path)
337     (when (string-match
338            "^\\(\\.\\)\\(.*\\)$"
339            folder)
340       (if (eq (length (setq fld-name
341                             (elmo-match-string 2 folder))) 0)
342           (setq fld-name ""))
343       (if (file-name-absolute-p fld-name)
344           (setq path (expand-file-name fld-name))
345         (setq path fld-name))
346       (list 'maildir path))))
347
348 (defun elmo-folder-maildir-p (folder)
349   (catch 'found
350     (let ((li elmo-maildir-list))
351       (while li
352         (if (string-match (car li) folder)
353             (throw 'found t))
354         (setq li (cdr li))))))
355
356 (defun elmo-localnews-get-spec (folder)
357   (let (fld-name)
358     (when (string-match
359          "^\\(=\\)\\(.*\\)$"
360          folder)
361       (if (eq (length (setq fld-name
362                             (elmo-match-string 2 folder))) 0)
363           (setq fld-name "")
364         )
365       (list 'localnews
366             (elmo-replace-in-string fld-name "\\." "/")))))
367
368 (defun elmo-cache-get-spec (folder)
369   (let (fld-name)
370     (when (string-match
371          "^\\(!\\)\\(.*\\)$"
372          folder)
373       (if (eq (length (setq fld-name
374                             (elmo-match-string 2 folder))) 0)
375           (setq fld-name "")
376         )
377       (list 'cache
378             (elmo-replace-in-string fld-name "\\." "/")))))
379
380 ;; Archive interface by OKUNISHI Fujikazu <fuji0924@mbox.kyoto-inet.or.jp>
381 (defun elmo-archive-get-spec (folder)
382   (require 'elmo-archive)
383   (let (fld-name type prefix)
384     (when (string-match
385            "^\\(\\$\\)\\([^;]*\\);?\\([^;]*\\);?\\([^;]*\\)$"
386            folder)
387       ;; Drive letter is OK!
388       (if (eq (length (setq fld-name
389                             (elmo-match-string 2 folder))) 0)
390           (setq fld-name "")
391         )
392       (if (eq (length (setq type
393                             (elmo-match-string 3 folder))) 0)
394           (setq type (symbol-name elmo-archive-default-type)))
395       (if (eq (length (setq prefix
396                             (elmo-match-string 4 folder))) 0)
397           (setq prefix ""))
398       (list 'archive fld-name (intern-soft type) prefix))))
399
400 (defun elmo-pop3-get-spec (folder)
401   (let ((stream-type-alist elmo-network-stream-type-alist)
402         spec user auth)
403     (if elmo-pop3-stream-type-alist
404         (setq stream-type-alist
405               (append elmo-pop3-stream-type-alist stream-type-alist)))
406     (setq spec (elmo-network-get-spec folder
407                                       elmo-default-pop3-server
408                                       elmo-default-pop3-port
409                                       elmo-default-pop3-stream-type
410                                       stream-type-alist))
411     (setq folder (car spec))
412     (when (string-match
413            "^\\(&\\)\\([^:/!]*\\)\\(/[^/:@!]+\\)?"
414            folder)
415       (setq user (if (match-beginning 2)
416                      (elmo-match-string 2 folder)))
417       (if (eq (length user) 0)
418           (setq user elmo-default-pop3-user))
419       (setq auth (if (match-beginning 3)
420                      (intern (elmo-match-substring 3 folder 1))
421                    elmo-default-pop3-authenticate-type))
422       (setq auth (or auth 'user))
423       (append (list 'pop3 user auth)
424               (cdr spec)))))
425
426 (defsubst elmo-pop3-spec-username (spec)
427   (nth 1 spec))
428
429 (defsubst elmo-pop3-spec-auth (spec)
430   (nth 2 spec))
431
432 (defsubst elmo-pop3-spec-hostname (spec)
433   (nth 3 spec))
434
435 (defsubst elmo-pop3-spec-port (spec)
436   (nth 4 spec))
437
438 (defsubst elmo-pop3-spec-stream-type (spec)
439   (nth 5 spec))
440
441 (defun elmo-internal-get-spec (folder)
442   (if (string-match "\\('\\)\\([^/]*\\)/?\\(.*\\)$" folder)
443       (let* ((item (downcase (elmo-match-string 2 folder)))
444              (sym (and (> (length item) 0) (intern item))))
445         (cond ((or (null sym)
446                    (eq sym 'mark))
447                (list 'internal sym (elmo-match-string 3 folder)))
448               ((eq sym 'cache)
449                (list 'cache (elmo-match-string 3 folder)))
450               (t (error "Invalid internal folder spec"))))))
451
452 (defun elmo-multi-get-spec (folder)
453   (save-match-data
454     (when (string-match
455            "^\\(\\*\\)\\(.*\\)$"
456            folder)
457       (append (list 'multi)
458               (split-string
459                (elmo-match-string 2 folder)
460                ",")))))
461
462 (defun elmo-filter-get-spec (folder)
463   (when (string-match "^\\(/\\)\\(.*\\)$" folder)
464     (let ((folder (elmo-match-string 2 folder))
465           pair)
466       (setq pair (elmo-parse-search-condition folder))
467       (if (string-match "^ */\\(.*\\)$" (cdr pair))
468           (list 'filter (car pair) (elmo-match-string 1 (cdr pair)))
469         (error "Folder syntax error `%s'" folder)))))
470
471 (defun elmo-pipe-get-spec (folder)
472   (when (string-match "^\\(|\\)\\([^|]*\\)|\\(.*\\)$" folder)
473     (list 'pipe
474           (elmo-match-string 2 folder)
475           (elmo-match-string 3 folder))))
476
477 (defsubst elmo-pipe-spec-src (spec)
478   (nth 1 spec))
479
480 (defsubst elmo-pipe-spec-dst (spec)
481   (nth 2 spec))
482
483 (defun elmo-folder-get-spec (folder)
484   "Return spec of FOLDER."
485   (let ((type (elmo-folder-get-type folder)))
486     (if type
487         (save-match-data
488           (funcall (intern (concat "elmo-" (symbol-name type) "-get-spec"))
489                    folder))
490       (error "%s is not supported folder type" folder))))
491
492 ;;; Search Condition
493
494 (defconst elmo-condition-atom-regexp "[^/ \")|&]*")
495
496 (defun elmo-read-search-condition (default)
497   "Read search condition string interactively."
498   (elmo-read-search-condition-internal "Search by" default))
499
500 (defun elmo-read-search-condition-internal (prompt default)
501   (let* ((completion-ignore-case t)
502          (field (completing-read
503                  (format "%s (%s): " prompt default)
504                  (mapcar 'list
505                          (append '("AND" "OR"
506                                    "Last" "First"
507                                    "From" "Subject" "To" "Cc" "Body"
508                                    "Since" "Before" "ToCc"
509                                    "!From" "!Subject" "!To" "!Cc" "!Body"
510                                    "!Since" "!Before" "!ToCc")
511                                  elmo-msgdb-extra-fields)) nil t))
512          value)
513     (setq field (if (string= field "")
514                     (setq field default)
515                   field))
516     (cond
517      ((or (string= field "AND") (string= field "OR"))
518       (concat "("
519               (elmo-read-search-condition-internal
520                (concat field "(1) Search by") default)
521               (if (string= field "AND") "&" "|")
522               (elmo-read-search-condition-internal
523                (concat field "(2) Search by") default)
524               ")"))
525      ((string-match "Since\\|Before" field)
526       (concat (downcase field) ":"
527               (completing-read (format "Value for '%s': " field)
528                                (mapcar (function
529                                         (lambda (x)
530                                           (list (format "%s" (car x)))))
531                                        elmo-date-descriptions))))
532      (t
533       (setq value (read-from-minibuffer (format "Value for '%s': " field)))
534       (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
535                             value)
536         (setq value (prin1-to-string value)))
537       (concat (downcase field) ":" value)))))
538
539 (defsubst elmo-condition-parse-error ()
540   (error "Syntax error in '%s'" (buffer-string)))
541
542 (defun elmo-parse-search-condition (condition)
543   "Parse CONDITION.
544 Return value is a cons cell of (STRUCTURE . REST)"
545   (with-temp-buffer
546     (insert condition)
547     (goto-char (point-min))
548     (cons (elmo-condition-parse) (buffer-substring (point) (point-max)))))
549
550 ;; condition    ::= or-expr
551 (defun elmo-condition-parse ()
552   (or (elmo-condition-parse-or-expr)
553       (elmo-condition-parse-error)))
554
555 ;; or-expr      ::= and-expr /
556 ;;                  and-expr "|" or-expr
557 (defun elmo-condition-parse-or-expr ()
558   (let ((left (elmo-condition-parse-and-expr)))
559     (if (looking-at "| *")
560         (progn
561           (goto-char (match-end 0))
562           (list 'or left (elmo-condition-parse-or-expr)))
563       left)))
564
565 ;; and-expr     ::= primitive /
566 ;;                  primitive "&" and-expr
567 (defun elmo-condition-parse-and-expr ()
568   (let ((left (elmo-condition-parse-primitive)))
569     (if (looking-at "& *")
570         (progn
571           (goto-char (match-end 0))
572           (list 'and left (elmo-condition-parse-and-expr)))
573       left)))
574
575 ;; primitive    ::= "(" expr ")" /
576 ;;                  ["!"] search-key SPACE* ":" SPACE* search-value
577 (defun elmo-condition-parse-primitive ()
578   (cond
579    ((looking-at "( *")
580     (goto-char (match-end 0))
581     (prog1 (elmo-condition-parse)
582       (unless (looking-at ") *")
583         (elmo-condition-parse-error))
584       (goto-char (match-end 0))))
585 ;; search-key   ::= [A-Za-z-]+
586 ;;                 ;; "since" / "before" / "last" / "first" /
587 ;;                 ;; "body" / field-name
588    ((looking-at "\\(!\\)? *\\([A-Za-z-]+\\) *: *")
589     (goto-char (match-end 0))
590     (let ((search-key (vector
591                        (if (match-beginning 1) 'unmatch 'match)
592                        (elmo-match-buffer 2)
593                        (elmo-condition-parse-search-value))))
594       ;; syntax sugar.
595       (if (string= (aref search-key 1) "tocc")
596           (if (eq (aref search-key 0) 'match)
597               (list 'or
598                     (vector 'match "to" (aref search-key 2))
599                     (vector 'match "cc" (aref search-key 2)))
600             (list 'and
601                   (vector 'unmatch "to" (aref search-key 2))
602                   (vector 'unmatch "cc" (aref search-key 2))))
603         search-key)))))
604
605 ;; search-value ::= quoted / time / number / atom
606 ;; quoted       ::= <elisp string expression>
607 ;; time         ::= "yesterday" / "lastweek" / "lastmonth" / "lastyear" /
608 ;;                   number SPACE* "daysago" /
609 ;;                   number "-" month "-" number  ; ex. 10-May-2000
610 ;; number       ::= [0-9]+
611 ;; month        ::= "Jan" / "Feb" / "Mar" / "Apr" / "May" / "Jun" /
612 ;;                  "Jul" / "Aug" / "Sep" / "Oct" / "Nov" / "Dec"
613 ;; atom         ::= ATOM_CHARS*
614 ;; SPACE        ::= <ascii space character, 0x20>
615 ;; ATOM_CHARS   ::= <any character except specials>
616 ;; specials     ::= SPACE / <"> / </> / <)> / <|> / <&>
617 ;;                  ;; These characters should be quoted.
618 (defun elmo-condition-parse-search-value ()
619   (cond
620    ((looking-at "\"")
621     (elmo-read (current-buffer)))
622    ((or (looking-at "yesterday") (looking-at "lastweek")
623         (looking-at "lastmonth") (looking-at "lastyear")
624         (looking-at "[0-9]+ *daysago")
625         (looking-at "[0-9]+-[A-Za-z]+-[0-9]+")
626         (looking-at "[0-9]+")
627         (looking-at elmo-condition-atom-regexp))
628     (prog1 (elmo-match-buffer 0)
629       (goto-char (match-end 0))))
630    (t (error "Syntax error '%s'" (buffer-string)))))
631
632 ;;;
633 (defun elmo-multi-get-real-folder-number (folder number)
634   (let* ((spec (elmo-folder-get-spec folder))
635          (flds (cdr spec))
636          (num number)
637          (fld (nth (- (/ num elmo-multi-divide-number) 1) flds)))
638     (cons fld (% num elmo-multi-divide-number))))
639
640 (defsubst elmo-buffer-replace (regexp &optional newtext)
641   (goto-char (point-min))
642   (while (re-search-forward regexp nil t)
643     (replace-match (or newtext ""))))
644
645 (defsubst elmo-delete-char (char string &optional unibyte)
646   (save-match-data
647     (elmo-set-work-buf
648      (let ((coding-system-for-read 'no-conversion)
649            (coding-system-for-write 'no-conversion))
650        (if unibyte (elmo-set-buffer-multibyte nil))
651        (insert string)
652        (goto-char (point-min))
653        (while (search-forward (char-to-string char) nil t)
654          (replace-match ""))
655        (buffer-string)))))
656
657 (defsubst elmo-delete-cr-get-content-type ()
658   (save-excursion
659     (goto-char (point-min))
660     (while (search-forward "\r\n" nil t)
661       (replace-match "\n"))
662     (goto-char (point-min))
663     (or (std11-field-body "content-type")
664         t)))
665
666 (defun elmo-delete-cr (string)
667   (save-match-data
668     (elmo-set-work-buf
669      (insert string)
670      (goto-char (point-min))
671      (while (search-forward "\r\n" nil t)
672        (replace-match "\n"))
673      (buffer-string))))
674
675 (defun elmo-uniq-list (lst)
676   "Distractively uniqfy elements of LST."
677   (let ((tmp lst))
678     (while tmp (setq tmp
679                      (setcdr tmp
680                              (and (cdr tmp)
681                                   (delete (car tmp)
682                                           (cdr tmp)))))))
683   lst)
684
685 (defun elmo-list-insert (list element after)
686   "Insert an ELEMENT to the LIST, just after AFTER."
687   (let ((li list)
688         (curn 0)
689         p pn)
690     (while li
691       (if (eq (car li) after)
692           (setq p li pn curn li nil)
693         (incf curn))
694       (setq li (cdr li)))
695     (if pn
696         (setcdr (nthcdr pn list) (cons element (cdr p)))
697       (nconc list (list element)))))
698
699 (defun elmo-string-partial-p (string)
700   (and (stringp string) (string-match "message/partial" string)))
701
702 (defun elmo-get-file-string (filename &optional remove-final-newline)
703   (elmo-set-work-buf
704    (let (insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
705          insert-file-contents-post-hook)
706      (when (file-exists-p filename)
707        (if filename
708            (as-binary-input-file (insert-file-contents filename)))
709        (when (and remove-final-newline
710                   (> (buffer-size) 0)
711                   (= (char-after (1- (point-max))) ?\n))
712          (goto-char (point-max))
713          (delete-backward-char 1))
714        (buffer-string)))))
715
716 (defun elmo-save-string (string filename)
717   (if string
718       (elmo-set-work-buf
719        (as-binary-output-file
720         (insert string)
721         (write-region (point-min) (point-max)
722                       filename nil 'no-msg))
723        )))
724
725 (defun elmo-max-of-list (nlist)
726   (let ((l nlist)
727         (max-num 0))
728     (while l
729       (if (< max-num (car l))
730           (setq max-num (car l)))
731       (setq l (cdr l)))
732     max-num))
733
734 (defun elmo-concat-path (path filename)
735   (if (not (string= path ""))
736       (if (string= elmo-path-sep (substring path (- (length path) 1)))
737           (concat path filename)
738         (concat path elmo-path-sep filename))
739     filename))
740
741 (defvar elmo-passwd-alist nil)
742
743 (defun elmo-passwd-alist-load ()
744   (save-excursion
745     (let ((filename (expand-file-name elmo-passwd-alist-file-name
746                                       elmo-msgdb-dir))
747           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))
748           insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
749           insert-file-contents-post-hook
750           ret-val)
751       (if (not (file-readable-p filename))
752           ()
753         (set-buffer tmp-buffer)
754         (insert-file-contents filename)
755         (setq ret-val
756               (condition-case nil
757                   (read (current-buffer))
758                 (error nil nil))))
759       (kill-buffer tmp-buffer)
760       ret-val)))
761
762 (defun elmo-passwd-alist-clear ()
763   "Clear password cache."
764   (interactive)
765   (setq elmo-passwd-alist nil))
766   
767 (defun elmo-passwd-alist-save ()
768   "Save password into file."
769   (interactive)
770   (save-excursion
771     (let ((filename (expand-file-name elmo-passwd-alist-file-name
772                                       elmo-msgdb-dir))
773           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*")))
774       (set-buffer tmp-buffer)
775       (erase-buffer)
776       (prin1 elmo-passwd-alist tmp-buffer)
777       (princ "\n" tmp-buffer)
778 ;;;   (if (and (file-exists-p filename)
779 ;;;            (not (equal 384 (file-modes filename))))
780 ;;;       (error "%s is not safe.chmod 600 %s!" filename filename))
781       (if (file-writable-p filename)
782          (progn
783            (write-region (point-min) (point-max)
784                          filename nil 'no-msg)
785            (set-file-modes filename 384))
786         (message (format "%s is not writable." filename)))
787       (kill-buffer tmp-buffer))))
788
789 (defun elmo-get-passwd (key)
790   "Get password from password pool."
791   (let (pair pass)
792     (if (not elmo-passwd-alist)
793         (setq elmo-passwd-alist (elmo-passwd-alist-load)))
794     (setq pair (assoc key elmo-passwd-alist))
795     (if pair
796         (elmo-base64-decode-string (cdr pair))
797       (setq pass (elmo-read-passwd (format "Password for %s: "
798                                            key) t))
799       (setq elmo-passwd-alist
800             (append elmo-passwd-alist
801                     (list (cons key
802                                 (elmo-base64-encode-string pass)))))
803       (if elmo-passwd-life-time
804           (run-with-timer elmo-passwd-life-time nil
805                           (` (lambda () (elmo-remove-passwd (, key))))))
806       pass)))
807
808 (defun elmo-remove-passwd (key)
809   "Remove password from password pool (for failure)."
810   (let (pass-cons)
811     (if (setq pass-cons (assoc key elmo-passwd-alist))
812         (progn
813           (unwind-protect
814               (fillarray (cdr pass-cons) 0))
815           (setq elmo-passwd-alist
816                 (delete pass-cons elmo-passwd-alist))))))
817
818 (defmacro elmo-read-char-exclusive ()
819   (cond ((featurep 'xemacs)
820          '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?)
821                                (left . ?\C-h))))
822                 event key)
823             (while (not
824                     (and
825                      (key-press-event-p (setq event (next-command-event)))
826                      (setq key (or (event-to-character event)
827                                    (cdr (assq (event-key event) table)))))))
828             key))
829         ((fboundp 'read-char-exclusive)
830          '(read-char-exclusive))
831         (t
832          '(read-char))))
833
834 (defun elmo-read-passwd (prompt &optional stars)
835   "Read a single line of text from user without echoing, and return it."
836   (let ((ans "")
837         (c 0)
838         (echo-keystrokes 0)
839         (cursor-in-echo-area t)
840         (log-message-max-size 0)
841         message-log-max done msg truncate)
842     (while (not done)
843       (if (or (not stars) (string= "" ans))
844           (setq msg prompt)
845         (setq msg (concat prompt (make-string (length ans) ?.)))
846         (setq truncate
847               (1+ (- (length msg) (window-width (minibuffer-window)))))
848         (and (> truncate 0)
849              (setq msg (concat "$" (substring msg (1+ truncate))))))
850       (message "%s" msg)
851       (setq c (elmo-read-char-exclusive))
852       (cond ((= c ?\C-g)
853              (setq quit-flag t
854                    done t))
855             ((or (= c ?\r) (= c ?\n) (= c ?\e))
856              (setq done t))
857             ((= c ?\C-u)
858              (setq ans ""))
859             ((and (/= c ?\b) (/= c ?\177))
860              (setq ans (concat ans (char-to-string c))))
861             ((> (length ans) 0)
862              (setq ans (substring ans 0 -1)))))
863     (if quit-flag
864         (prog1
865             (setq quit-flag nil)
866           (message "Quit")
867           (beep t))
868       (message "")
869       ans)))
870
871 ;; from subr.el
872 (defun elmo-replace-in-string (str regexp newtext &optional literal)
873   "Replace all matches in STR for REGEXP with NEWTEXT string.
874 And returns the new string.
875 Optional LITERAL non-nil means do a literal replacement.
876 Otherwise treat \\ in NEWTEXT string as special:
877   \\& means substitute original matched text,
878   \\N means substitute match for \(...\) number N,
879   \\\\ means insert one \\."
880   (let ((rtn-str "")
881         (start 0)
882         (special)
883         match prev-start)
884     (while (setq match (string-match regexp str start))
885       (setq prev-start start
886             start (match-end 0)
887             rtn-str
888             (concat
889              rtn-str
890              (substring str prev-start match)
891              (cond (literal newtext)
892                    (t (mapconcat
893                        (function
894                         (lambda (c)
895                           (if special
896                               (progn
897                                 (setq special nil)
898                                 (cond ((eq c ?\\) "\\")
899                                       ((eq c ?&)
900                                        (elmo-match-string 0 str))
901                                       ((and (>= c ?0) (<= c ?9))
902                                        (if (> c (+ ?0 (length
903                                                        (match-data))))
904                                            ;; Invalid match num
905                                            (error "Invalid match num: %c" c)
906                                          (setq c (- c ?0))
907                                          (elmo-match-string c str)))
908                                       (t (char-to-string c))))
909                             (if (eq c ?\\) (progn (setq special t) nil)
910                               (char-to-string c)))))
911                        newtext ""))))))
912     (concat rtn-str (substring str start))))
913
914 (defun elmo-string-to-list (string)
915   (elmo-set-work-buf
916    (insert string)
917    (goto-char (point-min))
918    (insert "(")
919    (goto-char (point-max))
920    (insert ")")
921    (goto-char (point-min))
922    (read (current-buffer))))
923
924 (defun elmo-list-to-string (list)
925   (let ((tlist list)
926         str)
927     (if (listp tlist)
928         (progn
929           (setq str "(")
930           (while (car tlist)
931             (setq str
932                   (concat str
933                           (if (symbolp (car tlist))
934                               (symbol-name (car tlist))
935                             (car tlist))))
936             (if (cdr tlist)
937                 (setq str
938                       (concat str " ")))
939             (setq tlist (cdr tlist)))
940           (setq str
941                 (concat str ")")))
942       (setq str 
943             (if (symbolp tlist)
944                 (symbol-name tlist)
945               tlist)))
946     str))
947  
948
949 (defun elmo-plug-on-by-servers (alist &optional servers)
950   (let ((server-list (or servers elmo-plug-on-servers)))
951     (catch 'plugged
952       (while server-list
953         (if (elmo-plugged-p (car server-list))
954             (throw 'plugged t))
955         (setq server-list (cdr server-list))))))
956
957 (defun elmo-plug-on-by-exclude-servers (alist &optional servers)
958   (let ((server-list (or servers elmo-plug-on-exclude-servers))
959         server other-servers)
960     (while alist
961       (when (and (not (member (setq server (caaar alist)) server-list))
962                  (not (member server other-servers)))
963         (push server other-servers))
964       (setq alist (cdr alist)))
965     (elmo-plug-on-by-servers alist other-servers)))
966
967 (defun elmo-plugged-p (&optional server port alist label-exp)
968   (let ((alist (or alist elmo-plugged-alist))
969         plugged-info)
970     (cond ((and (not port) (not server))
971            (cond ((eq elmo-plugged-condition 'one)
972                   (catch 'plugged
973                     (while alist
974                       (if (nth 2 (car alist))
975                           (throw 'plugged t))
976                       (setq alist (cdr alist)))))
977                  ((eq elmo-plugged-condition 'all)
978                   (catch 'plugged
979                     (while alist
980                       (if (not (nth 2 (car alist)))
981                           (throw 'plugged nil))
982                       (setq alist (cdr alist)))
983                     t))
984                  ((functionp elmo-plugged-condition)
985                   (funcall elmo-plugged-condition alist))
986                  (t ;; independent
987                   elmo-plugged)))
988           ((not port) ;; server
989            (catch 'plugged
990              (while alist
991                (when (string= server (caaar alist))
992                  (if (nth 2 (car alist))
993                      (throw 'plugged t)))
994                (setq alist (cdr alist)))))
995           (t
996            (setq plugged-info (assoc (cons server port) alist))
997            (if (not plugged-info)
998                ;; add elmo-plugged-alist automatically
999                (progn
1000                  (elmo-set-plugged elmo-plugged server port nil nil label-exp)
1001                  elmo-plugged)
1002              (if (and elmo-auto-change-plugged
1003                       (> elmo-auto-change-plugged 0)
1004                       (nth 3 plugged-info)  ;; time
1005                       (elmo-time-expire (nth 3 plugged-info)
1006                                         elmo-auto-change-plugged))
1007                  t
1008                (nth 2 plugged-info)))))))
1009
1010 (defun elmo-set-plugged (plugged &optional server port time
1011                                  alist label-exp add)
1012   (let ((alist (or alist elmo-plugged-alist))
1013         label plugged-info)
1014     (cond ((and (not port) (not server))
1015            (setq elmo-plugged plugged)
1016            ;; set plugged all element of elmo-plugged-alist.
1017            (while alist
1018              (setcdr (cdar alist) (list plugged time))
1019              (setq alist (cdr alist))))
1020           ((not port)
1021            ;; set plugged all port of server
1022            (while alist
1023              (when (string= server (caaar alist))
1024                (setcdr (cdar alist) (list plugged time)))
1025              (setq alist (cdr alist))))
1026           (t
1027            ;; set plugged one port of server
1028            (setq plugged-info (assoc (cons server port) alist))
1029            (setq label (if label-exp
1030                            (eval label-exp)
1031                          (nth 1 plugged-info)))
1032            (if plugged-info
1033                ;; if add is non-nil, don't reset plug state.
1034                (unless add
1035                  (setcdr plugged-info (list label plugged time)))
1036              (setq alist
1037                    (setq elmo-plugged-alist
1038                          (nconc elmo-plugged-alist
1039                                 (list
1040                                  (list (cons server port) label plugged time))))))))
1041     alist))
1042
1043 (defun elmo-delete-plugged (&optional server port alist)
1044   (let* ((alist (or alist elmo-plugged-alist))
1045          (alist2 alist))
1046     (cond ((and (not port) (not server))
1047            (setq alist nil))
1048           ((not port)
1049            ;; delete plugged all port of server
1050            (while alist2
1051              (when (string= server (caaar alist2))
1052                (setq alist (delete (car alist2) alist)))
1053              (setq alist2 (cdr alist2))))
1054           (t
1055            ;; delete plugged one port of server
1056            (setq alist
1057                  (delete (assoc (cons server port) alist) alist))))
1058     alist))
1059
1060 (defun elmo-disk-usage (path)
1061   "Get disk usage (bytes) in PATH."
1062   (let ((file-attr
1063          (condition-case () (file-attributes path) (error nil))))
1064     (if file-attr
1065         (if (nth 0 file-attr) ; directory
1066             (let ((files (condition-case ()
1067                              (directory-files path t "^[^\\.]")
1068                            (error nil)))
1069                   (result 0.0))
1070               ;; (result (nth 7 file-attr))) ... directory size
1071               (while files
1072                 (setq result (+ result (or (elmo-disk-usage (car files)) 0)))
1073                 (setq files (cdr files)))
1074               result)
1075           (float (nth 7 file-attr))))))
1076
1077 (defun elmo-get-last-accessed-time (path &optional dir)
1078   "Return the last accessed time of PATH."
1079   (let ((last-accessed (nth 4 (file-attributes (or (and dir
1080                                                         (expand-file-name
1081                                                          path dir))
1082                                                    path)))))
1083     (if last-accessed
1084         (setq last-accessed (+ (* (nth 0 last-accessed)
1085                                   (float 65536)) (nth 1 last-accessed)))
1086       0)))
1087
1088 (defun elmo-get-last-modification-time (path &optional dir)
1089   "Return the last accessed time of PATH."
1090   (let ((last-modified (nth 5 (file-attributes (or (and dir
1091                                                         (expand-file-name
1092                                                          path dir))
1093                                                    path)))))
1094     (setq last-modified (+ (* (nth 0 last-modified)
1095                               (float 65536)) (nth 1 last-modified)))))
1096
1097 (defun elmo-make-directory (path)
1098   "Create directory recursively."
1099   (let ((parent (directory-file-name (file-name-directory path))))
1100     (if (null (file-directory-p parent))
1101         (elmo-make-directory parent))
1102     (make-directory path)
1103     (if (string= path (expand-file-name elmo-msgdb-dir))
1104         (set-file-modes path (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700
1105
1106 (defun elmo-delete-directory (path &optional no-hierarchy)
1107   "Delete directory recursively."
1108   (let ((dirent (directory-files path))
1109         relpath abspath hierarchy)
1110     (while dirent
1111       (setq relpath (car dirent)
1112             dirent (cdr dirent)
1113             abspath (expand-file-name relpath path))
1114       (when (not (string-match "^\\.\\.?$" relpath))
1115         (if (eq (nth 0 (file-attributes abspath)) t)
1116             (if no-hierarchy
1117                 (setq hierarchy t)
1118               (elmo-delete-directory abspath no-hierarchy))
1119           (delete-file abspath))))
1120     (unless hierarchy
1121       (delete-directory path))))
1122
1123 (defun elmo-list-filter (l1 l2)
1124   "L1 is filter."
1125   (if (eq l1 t)
1126       ;; t means filter all.
1127       nil
1128     (if l1
1129         (elmo-delete-if (lambda (x) (not (memq x l1))) l2)
1130       ;; filter is nil
1131       l2)))
1132
1133 (defun elmo-folder-local-p (folder)
1134   "Return whether FOLDER is a local folder or not."
1135   (let ((spec (elmo-folder-get-spec folder)))
1136     (case (car spec)
1137       (filter (elmo-folder-local-p (nth 2 spec)))
1138       (pipe (elmo-folder-local-p (elmo-pipe-spec-dst spec)))
1139       (t (memq (car spec)
1140                '(localdir localnews archive maildir internal cache))))))
1141
1142 (defun elmo-folder-writable-p (folder)
1143   (let ((type (elmo-folder-get-type folder)))
1144     (memq type '(imap4 localdir archive))))
1145
1146 (defun elmo-multi-get-intlist-list (numlist &optional as-is)
1147   (let ((numbers (sort numlist '<))
1148         (cur-number 0)
1149         one-list int-list-list)
1150     (while numbers
1151       (setq cur-number (+ cur-number 1))
1152       (setq one-list nil)
1153       (while (and numbers
1154                   (eq 0
1155                       (/ (- (car numbers)
1156                             (* elmo-multi-divide-number cur-number))
1157                          elmo-multi-divide-number)))
1158         (setq one-list (nconc
1159                         one-list
1160                         (list
1161                          (if as-is
1162                              (car numbers)
1163                            (% (car numbers)
1164                               (* elmo-multi-divide-number cur-number))))))
1165         (setq numbers (cdr numbers)))
1166       (setq int-list-list (nconc int-list-list (list one-list))))
1167     int-list-list))
1168
1169 (defsubst elmo-list-delete-if-smaller (list number)
1170   (let ((ret-val (copy-sequence list)))
1171     (while list
1172       (if (< (car list) number)
1173           (setq ret-val (delq (car list) ret-val)))
1174       (setq list (cdr list)))
1175     ret-val))
1176
1177 (defun elmo-list-diff (list1 list2 &optional mes)
1178   (if mes
1179       (message mes))
1180   (let ((clist1 (copy-sequence list1))
1181         (clist2 (copy-sequence list2)))
1182     (while list2
1183       (setq clist1 (delq (car list2) clist1))
1184       (setq list2 (cdr list2)))
1185     (while list1
1186       (setq clist2 (delq (car list1) clist2))
1187       (setq list1 (cdr list1)))
1188     (if mes
1189         (message (concat mes "done.")))
1190     (list clist1 clist2)))
1191
1192 (defun elmo-list-bigger-diff (list1 list2 &optional mes)
1193   "Returns a list (- +). + is bigger than max of LIST1, in LIST2."
1194   (if (null list2)
1195       (cons list1  nil)
1196     (let* ((l1 list1)
1197            (l2 list2)
1198            (max-of-l2 (or (nth (max 0 (1- (length l2))) l2) 0))
1199            diff1 num i percent
1200            )
1201       (setq i 0)
1202       (setq num (+ (length l1)))
1203       (while l1
1204         (if (memq (car l1) l2)
1205             (if (eq (car l1) (car l2))
1206                 (setq l2 (cdr l2))
1207               (delq (car l1) l2))
1208           (if (> (car l1) max-of-l2)
1209               (setq diff1 (nconc diff1 (list (car l1))))))
1210         (if mes
1211             (progn
1212               (setq i (+ i 1))
1213               (setq percent (/ (* i 100) num))
1214               (if (eq (% percent 5) 0)
1215                   (elmo-display-progress
1216                    'elmo-list-bigger-diff "%s%d%%" percent mes))))
1217         (setq l1 (cdr l1)))
1218       (cons diff1 (list l2)))))
1219
1220 (defun elmo-multi-list-bigger-diff (list1 list2 &optional mes)
1221   (let ((list1-list (elmo-multi-get-intlist-list list1 t))
1222         (list2-list (elmo-multi-get-intlist-list list2 t))
1223         result
1224         dels news)
1225     (while (or list1-list list2-list)
1226       (setq result (elmo-list-bigger-diff (car list1-list) (car list2-list)
1227                                           mes))
1228       (setq dels (append dels (car result)))
1229       (setq news (append news (cadr result)))
1230       (setq list1-list (cdr list1-list))
1231       (setq list2-list (cdr list2-list)))
1232     (cons dels (list news))))
1233
1234 (defvar elmo-imap4-name-space-regexp-list nil)
1235 (defun elmo-imap4-identical-name-space-p (fld1 fld2)
1236   ;; only on UW?
1237   (if (or (eq (string-to-char fld1) ?#)
1238           (eq (string-to-char fld2) ?#))
1239       (string= (car (split-string fld1 "/"))
1240                (car (split-string fld2 "/")))
1241     t))
1242
1243 (defun elmo-folder-identical-system-p (folder1 folder2)
1244   "FOLDER1 and FOLDER2 should be real folder (not virtual)."
1245   (cond ((eq (elmo-folder-get-type folder1) 'imap4)
1246          (let ((spec1 (elmo-folder-get-spec folder1))
1247                (spec2 (elmo-folder-get-spec folder2)))
1248            (and 
1249 ;;; No use.         
1250 ;;;         (elmo-imap4-identical-name-space-p 
1251 ;;;          (nth 1 spec1) (nth 1 spec2))
1252             (string= (elmo-imap4-spec-hostname spec1)
1253                      (elmo-imap4-spec-hostname spec2)) ; hostname
1254             (string= (elmo-imap4-spec-username spec1)
1255                      (elmo-imap4-spec-username spec2))))) ; username
1256         (t
1257          (elmo-folder-direct-copy-p folder1 folder2))))
1258
1259 (defun elmo-folder-get-store-type (folder)
1260   (let ((spec (elmo-folder-get-spec folder)))
1261     (case (car spec)
1262       (filter (elmo-folder-get-store-type (nth 2 spec)))
1263       (pipe (elmo-folder-get-store-type (elmo-pipe-spec-dst spec)))
1264       (multi (elmo-folder-get-store-type (nth 1 spec)))
1265       (t (car spec)))))
1266
1267 (defconst elmo-folder-direct-copy-alist
1268   '((localdir  . (localdir localnews archive))
1269     (maildir   . (maildir  localdir localnews archive))
1270     (localnews . (localdir localnews archive))
1271     (archive   . (localdir localnews archive))
1272     (cache     . (localdir localnews archive))))
1273
1274 (defun elmo-folder-direct-copy-p (src-folder dst-folder)
1275   (let ((src-type (elmo-folder-get-store-type src-folder))
1276         (dst-type (elmo-folder-get-store-type dst-folder))
1277         dst-copy-type)
1278     (and (setq dst-copy-type
1279                (cdr (assq src-type elmo-folder-direct-copy-alist)))
1280          (memq dst-type dst-copy-type))))
1281
1282 (defmacro elmo-filter-type (filter)
1283   (` (aref (, filter) 0)))
1284
1285 (defmacro elmo-filter-key (filter)
1286   (` (aref (, filter) 1)))
1287
1288 (defmacro elmo-filter-value (filter)
1289   (` (aref (, filter) 2)))
1290
1291 (defsubst elmo-buffer-field-primitive-condition-match (condition
1292                                                        number
1293                                                        number-list)
1294   (let (result)
1295     (goto-char (point-min))
1296     (cond
1297      ((string= (elmo-filter-key condition) "last")
1298       (setq result (<= (length (memq number number-list))
1299                        (string-to-int (elmo-filter-value condition)))))
1300      ((string= (elmo-filter-key condition) "first")
1301       (setq result (< (- (length number-list)
1302                          (length (memq number number-list)))
1303                       (string-to-int (elmo-filter-value condition)))))
1304      ((string= (elmo-filter-key condition) "since")
1305       (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
1306         (setq result
1307               (string<
1308                (timezone-make-sortable-date (aref date 0)
1309                                             (aref date 1)
1310                                             (aref date 2)
1311                                             (timezone-make-time-string
1312                                              (aref date 3)
1313                                              (aref date 4)
1314                                              (aref date 5)))
1315                (timezone-make-date-sortable (std11-field-body "date"))))))
1316      ((string= (elmo-filter-key condition) "before")
1317       (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
1318         (setq result
1319               (string<
1320                (timezone-make-date-sortable (std11-field-body "date"))
1321                (timezone-make-sortable-date (aref date 0)
1322                                             (aref date 1)
1323                                             (aref date 2)
1324                                             (timezone-make-time-string
1325                                              (aref date 3)
1326                                              (aref date 4)
1327                                              (aref date 5)))))))
1328      ((string= (elmo-filter-key condition) "body")
1329       (and (re-search-forward "^$" nil t)          ; goto body
1330            (setq result (search-forward (elmo-filter-value condition)
1331                                         nil t))))
1332      (t
1333       (let ((fval (std11-field-body (elmo-filter-key condition))))
1334         (if (eq (length fval) 0) (setq fval nil))
1335         (if fval (setq fval (eword-decode-string fval)))
1336         (setq result (and fval (string-match
1337                                 (elmo-filter-value condition) fval))))))
1338     (if (eq (elmo-filter-type condition) 'unmatch)
1339         (setq result (not result)))
1340     result))
1341
1342 (defun elmo-condition-find-key-internal (condition key)
1343   (cond
1344    ((vectorp condition)
1345     (if (string= (elmo-filter-key condition) key)
1346         (throw 'found t)))
1347    ((or (eq (car condition) 'and)
1348         (eq (car condition) 'or))
1349     (elmo-condition-find-key-internal (nth 1 condition) key)
1350     (elmo-condition-find-key-internal (nth 2 condition) key))))
1351
1352 (defun elmo-condition-find-key (condition key)
1353   (catch 'found
1354     (elmo-condition-find-key-internal condition key)))
1355
1356 (defun elmo-buffer-field-condition-match (condition number number-list)
1357   (cond
1358    ((vectorp condition)
1359     (elmo-buffer-field-primitive-condition-match
1360      condition number number-list))
1361    ((eq (car condition) 'and)
1362     (and (elmo-buffer-field-condition-match
1363           (nth 1 condition) number number-list)
1364          (elmo-buffer-field-condition-match
1365           (nth 2 condition) number number-list)))
1366    ((eq (car condition) 'or)
1367     (or (elmo-buffer-field-condition-match
1368          (nth 1 condition) number number-list)
1369         (elmo-buffer-field-condition-match
1370          (nth 2 condition) number number-list)))))
1371
1372 (defsubst elmo-file-field-condition-match (file condition number number-list)
1373   (elmo-set-work-buf
1374    (as-binary-input-file (insert-file-contents file))
1375    (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1376    ;; Should consider charset?
1377    (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
1378    (elmo-buffer-field-condition-match condition number number-list)))
1379
1380 (defmacro elmo-get-hash-val (string hashtable)
1381   (let ((sym (list 'intern-soft string hashtable)))
1382     (list 'if (list 'boundp sym)
1383        (list 'symbol-value sym))))
1384
1385 (defmacro elmo-set-hash-val (string value hashtable)
1386   (list 'set (list 'intern string hashtable) value))
1387
1388 (defmacro elmo-clear-hash-val (string hashtable)
1389   (static-if (fboundp 'unintern)
1390       (list 'unintern string hashtable)
1391     (list 'makunbound (list 'intern string hashtable))))
1392
1393 (defmacro elmo-unintern (string)
1394   "`unintern' symbol named STRING,  When can use `unintern'.
1395 Emacs 19.28 or earlier does not have `unintern'."
1396   (static-if (fboundp 'unintern)
1397       (list 'unintern string)))
1398
1399 ;; Make a hash table (default and minimum size is 1024).
1400 (defun elmo-make-hash (&optional hashsize)
1401   (make-vector
1402    (if hashsize (max (min (elmo-create-hash-size hashsize)
1403                           elmo-hash-maximum-size) 1024) 1024) 0))
1404
1405 (defsubst elmo-mime-string (string)
1406   "Normalize MIME encoded STRING."
1407     (and string
1408          (let (str)
1409            (elmo-set-work-buf
1410             (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1411             (setq str (eword-decode-string
1412                        (decode-mime-charset-string string elmo-mime-charset)))
1413             (setq str (encode-mime-charset-string str elmo-mime-charset))
1414             (elmo-set-buffer-multibyte nil)
1415             str))))
1416
1417 (defsubst elmo-collect-field (beg end downcase-field-name)
1418   (save-excursion
1419     (save-restriction
1420       (narrow-to-region beg end)
1421       (goto-char (point-min))
1422       (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1423             dest name body)
1424         (while (re-search-forward regexp nil t)
1425           (setq name (buffer-substring-no-properties
1426                       (match-beginning 1)(1- (match-end 1))))
1427           (if downcase-field-name
1428               (setq name (downcase name)))
1429           (setq body (buffer-substring-no-properties
1430                       (match-end 0) (std11-field-end)))
1431           (or (assoc name dest)
1432               (setq dest (cons (cons name body) dest))))
1433         dest))))
1434
1435 (defsubst elmo-collect-field-from-string (string downcase-field-name)
1436   (with-temp-buffer
1437     (insert string)
1438     (goto-char (point-min))
1439     (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1440           dest name body)
1441       (while (re-search-forward regexp nil t)
1442         (setq name (buffer-substring-no-properties
1443                     (match-beginning 1)(1- (match-end 1))))
1444         (if downcase-field-name
1445             (setq name (downcase name)))
1446         (setq body (buffer-substring-no-properties
1447                     (match-end 0) (std11-field-end)))
1448         (or (assoc name dest)
1449             (setq dest (cons (cons name body) dest))))
1450       dest)))
1451
1452 (defun elmo-create-hash-size (min)
1453   (let ((i 1))
1454     (while (< i min)
1455       (setq i (* 2 i)))
1456     i))
1457
1458 (defun elmo-safe-filename (folder)
1459   (elmo-replace-in-string
1460    (elmo-replace-in-string
1461     (elmo-replace-in-string folder "/" " ")
1462     ":" "__")
1463    "|" "_or_"))
1464
1465 (defvar elmo-msgid-replace-chars nil)
1466
1467 (defsubst elmo-replace-msgid-as-filename (msgid)
1468   "Replace Message-ID string (MSGID) as filename."
1469   (setq msgid (elmo-replace-in-string msgid " " "  "))
1470   (if (null elmo-msgid-replace-chars)
1471       (setq elmo-msgid-replace-chars
1472             (regexp-quote (mapconcat
1473                            'car elmo-msgid-replace-string-alist ""))))
1474   (while (string-match (concat "[" elmo-msgid-replace-chars "]")
1475                        msgid)
1476     (setq msgid (concat
1477                  (substring msgid 0 (match-beginning 0))
1478                  (cdr (assoc
1479                        (substring msgid
1480                                   (match-beginning 0) (match-end 0))
1481                        elmo-msgid-replace-string-alist))
1482                  (substring msgid (match-end 0)))))
1483   msgid)
1484
1485 (defsubst elmo-recover-msgid-from-filename (filename)
1486   "Recover Message-ID from FILENAME."
1487   (let (tmp result)
1488     (while (string-match " " filename)
1489       (setq tmp (substring filename
1490                            (match-beginning 0)
1491                            (+ (match-end 0) 1)))
1492       (if (string= tmp "  ")
1493           (setq tmp " ")
1494         (setq tmp (car (rassoc tmp
1495                                elmo-msgid-replace-string-alist))))
1496       (setq result
1497             (concat result
1498                     (substring filename 0 (match-beginning 0))
1499                     tmp))
1500       (setq filename (substring filename (+ (match-end 0) 1))))
1501     (concat result filename)))
1502
1503 (defsubst elmo-copy-file (src dst)
1504   (condition-case err
1505       (elmo-add-name-to-file src dst t)
1506     (error (copy-file src dst t))))
1507
1508 (defsubst elmo-buffer-exists-p (buffer)
1509   (if (bufferp buffer)
1510       (buffer-live-p buffer)
1511     (get-buffer buffer)))
1512
1513 (defsubst elmo-kill-buffer (buffer)
1514   (when (elmo-buffer-exists-p buffer)
1515     (kill-buffer buffer)))
1516
1517 (defun elmo-delete-if (pred lst)
1518   "Return new list contain items which don't satisfy PRED in LST."
1519   (let (result)
1520     (while lst
1521       (unless (funcall pred (car lst))
1522         (setq result (nconc result (list (car lst)))))
1523       (setq lst (cdr lst)))
1524     result))
1525
1526 (defun elmo-list-delete (list1 list2)
1527   "Delete by side effect any occurrences equal to elements of LIST1 from LIST2.
1528 Return the modified LIST2.  Deletion is done with `delete'.
1529 Write `(setq foo (elmo-list-delete bar foo))' to be sure of changing
1530 the value of `foo'."
1531   (while list1
1532     (setq list2 (delete (car list1) list2))
1533     (setq list1 (cdr list1)))
1534   list2)
1535
1536 (defun elmo-list-member (list1 list2)
1537   "If any element of LIST1 is member of LIST2, return t."
1538   (catch 'done
1539     (while list1
1540       (if (member (car list1) list2)
1541           (throw 'done t))
1542       (setq list1 (cdr list1)))))
1543
1544 (defun elmo-count-matches (regexp beg end)
1545   (let ((count 0))
1546     (save-excursion
1547       (goto-char beg)
1548       (while (re-search-forward regexp end t)
1549         (setq count (1+ count)))
1550       count)))
1551
1552 (if (fboundp 'display-error)
1553     (defalias 'elmo-display-error 'display-error)
1554   (defun elmo-display-error (error-object stream)
1555     "A tiny function to display ERROR-OBJECT to the STREAM."
1556     (let ((first t)
1557           (errobj error-object)
1558           err-mes)
1559       (while errobj
1560         (setq err-mes (concat err-mes (format
1561                                        (if (stringp (car errobj))
1562                                            "%s"
1563                                          (if (boundp 'nemacs-version)
1564                                              "%s"
1565                                            "%S")) (car errobj))))
1566         (setq errobj (cdr errobj))
1567         (if errobj (setq err-mes (concat err-mes (if first ": " ", "))))
1568         (setq first nil))
1569       (princ err-mes stream))))
1570
1571 (if (fboundp 'define-error)
1572     (defalias 'elmo-define-error 'define-error)
1573   (defun elmo-define-error (error doc &optional parents)
1574     (or parents
1575         (setq parents 'error))
1576     (let ((conds (get parents 'error-conditions)))
1577       (or conds
1578           (error "Not an error symbol: %s" error))
1579       (setplist error
1580                 (list 'error-message doc
1581                       'error-conditions (cons error conds))))))
1582
1583 (cond ((fboundp 'progress-feedback-with-label)
1584        (defalias 'elmo-display-progress 'progress-feedback-with-label))
1585       ((fboundp 'lprogress-display)
1586        (defalias 'elmo-display-progress 'lprogress-display))
1587       (t
1588        (defun elmo-display-progress (label format &optional value &rest args)
1589          "Print a progress message."
1590          (if (and (null format) (null args))
1591              (message nil)
1592            (apply (function message) (concat format " %d%%")
1593                   (nconc args (list value)))))))
1594
1595 (defun elmo-time-expire (before-time diff-time)
1596   (let* ((current (current-time))
1597          (rest (when (< (nth 1 current) (nth 1 before-time))
1598                  (expt 2 16)))
1599          diff)
1600     (setq diff
1601           (list (- (+ (car current) (if rest -1 0)) (car before-time))
1602                 (- (+ (or rest 0) (nth 1 current)) (nth 1 before-time))))
1603     (and (eq (car diff) 0)
1604          (< diff-time (nth 1 diff)))))
1605
1606 (if (fboundp 'std11-fetch-field)
1607     (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
1608   (defalias 'elmo-field-body 'std11-field-body))
1609
1610 (defmacro elmo-string (string)
1611   "STRING without text property."
1612   (` (let ((obj (copy-sequence (, string))))
1613        (set-text-properties 0 (length obj) nil obj)
1614        obj)))
1615
1616 (defun elmo-flatten (list-of-list)
1617   "Flatten LIST-OF-LIST."
1618   (unless (null list-of-list)
1619     (append (if (and (car list-of-list)
1620                      (listp (car list-of-list)))
1621                 (car list-of-list)
1622               (list (car list-of-list)))
1623             (elmo-flatten (cdr list-of-list)))))
1624
1625 (defun elmo-y-or-n-p (prompt &optional auto default)
1626   "Same as `y-or-n-p'.
1627 But if optional argument AUTO is non-nil, DEFAULT is returned."
1628   (if auto
1629       default
1630     (y-or-n-p prompt)))
1631
1632 (defun elmo-string-member (string slist)
1633   "Return t if STRING is a member of the SLIST."
1634   (catch 'found
1635     (while slist
1636       (if (and (stringp (car slist))
1637                (string= string (car slist)))
1638           (throw 'found t))
1639       (setq slist (cdr slist)))))
1640
1641 (defun elmo-string-match-member (str list &optional case-ignore)
1642   (let ((case-fold-search case-ignore))
1643     (catch 'member
1644       (while list
1645         (if (string-match (car list) str)
1646             (throw 'member (car list)))
1647         (setq list (cdr list))))))
1648
1649 (defun elmo-string-matched-member (str list &optional case-ignore)
1650   (let ((case-fold-search case-ignore))
1651     (catch 'member
1652       (while list
1653         (if (string-match str (car list))
1654             (throw 'member (car list)))
1655         (setq list (cdr list))))))
1656
1657 (defsubst elmo-string-delete-match (string pos)
1658   (concat (substring string
1659                      0 (match-beginning pos))
1660           (substring string
1661                      (match-end pos)
1662                      (length string))))
1663
1664 (defun elmo-string-match-assoc (key alist &optional case-ignore)
1665   (let ((case-fold-search case-ignore)
1666         a)
1667     (catch 'loop
1668       (while alist
1669         (setq a (car alist))
1670         (if (and (consp a)
1671                  (stringp (car a))
1672                  (string-match key (car a)))
1673             (throw 'loop a))
1674         (setq alist (cdr alist))))))
1675
1676 (defun elmo-string-matched-assoc (key alist &optional case-ignore)
1677   (let ((case-fold-search case-ignore)
1678         a)
1679     (catch 'loop
1680       (while alist
1681         (setq a (car alist))
1682         (if (and (consp a)
1683                  (stringp (car a))
1684                  (string-match (car a) key))
1685             (throw 'loop a))
1686         (setq alist (cdr alist))))))
1687
1688 (defun elmo-string-assoc (key alist)
1689   (let (a)
1690     (catch 'loop
1691       (while alist
1692         (setq a (car alist))
1693         (if (and (consp a)
1694                  (stringp (car a))
1695                  (string= key (car a)))
1696             (throw 'loop a))
1697         (setq alist (cdr alist))))))
1698
1699 (defun elmo-string-rassoc (key alist)
1700   (let (a)
1701     (catch 'loop
1702       (while alist
1703         (setq a (car alist))
1704         (if (and (consp a)
1705                  (stringp (cdr a))
1706                  (string= key (cdr a)))
1707             (throw 'loop a))
1708         (setq alist (cdr alist))))))
1709
1710 (defun elmo-string-rassoc-all (key alist)
1711   (let (matches)
1712     (while alist
1713       (if (string= key (cdr (car alist)))
1714           (setq matches
1715                 (cons (car alist)
1716                       matches)))
1717       (setq alist (cdr alist)))
1718     matches))
1719
1720 ;;; Number set defined by OKAZAKI Tetsurou <okazaki@be.to>
1721 ;; 
1722 ;; number          ::= [0-9]+
1723 ;; beg             ::= number
1724 ;; end             ::= number
1725 ;; number-range    ::= "(" beg " . " end ")"      ;; cons cell
1726 ;; number-set-elem ::= number / number-range
1727 ;; number-set      ::= "(" *number-set-elem ")"   ;; list
1728
1729 (defun elmo-number-set-member (number number-set)
1730   "Return non-nil if NUMBER is an element of NUMBER-SET.
1731 The value is actually the tail of NUMBER-RANGE whose car contains NUMBER."
1732   (or (memq number number-set)
1733       (let (found)
1734         (while (and number-set (not found))
1735           (if (and (consp (car number-set))
1736                    (and (<= (car (car number-set)) number)
1737                         (<= number (cdr (car number-set)))))
1738               (setq found t)
1739             (setq number-set (cdr number-set))))
1740         number-set)))
1741
1742 (defun elmo-number-set-append-list (number-set list)
1743   "Append LIST of numbers to the NUMBER-SET.
1744 NUMBER-SET is altered."
1745   (let ((appended number-set))
1746     (while list
1747       (setq appended (elmo-number-set-append appended (car list)))
1748       (setq list (cdr list)))
1749     appended))
1750
1751 (defun elmo-number-set-append (number-set number)
1752   "Append NUMBER to the NUMBER-SET.
1753 NUMBER-SET is altered."
1754   (let ((number-set-1 number-set)
1755         found elem)
1756     (while (and number-set (not found))
1757       (setq elem (car number-set))
1758       (cond
1759        ((and (consp elem)
1760              (eq (+ 1 (cdr elem)) number))
1761         (setcdr elem number)
1762         (setq found t))
1763        ((and (integerp elem)
1764              (eq (+ 1 elem) number))
1765         (setcar number-set (cons elem number))
1766         (setq found t))
1767        ((or (and (integerp elem) (eq elem number))
1768             (and (consp elem)
1769                  (<= (car elem) number)
1770                  (<= number (cdr elem))))
1771         (setq found t)))
1772       (setq number-set (cdr number-set)))
1773     (if (not found)
1774         (setq number-set-1 (nconc number-set-1 (list number))))
1775     number-set-1))
1776
1777 (require 'product)
1778 (product-provide (provide 'elmo-util) (require 'elmo-version))
1779
1780 ;;; elmo-util.el ends here