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 (eval-when-compile (require 'cl))
  33 (require 'elmo-vars)
  34 (require 'elmo-date)
  35 (require 'mcharset)
  36 (require 'pces)
  37 (require 'std11)
  38 (require 'eword-decode)
  39 (require 'utf7)
  40 (require 'poem)
  41
  42 (defmacro elmo-set-buffer-multibyte (flag)
  43   "Set the multibyte flag of the current buffer to FLAG."
  44   (cond ((boundp 'MULE)
  45          (list 'setq 'mc-flag flag))
  46         ((featurep 'xemacs)
  47          flag)
  48         ((and (boundp 'emacs-major-version) (>= emacs-major-version 20))
  49          (list 'set-buffer-multibyte flag))
  50         (t
  51          flag)))
  52
  53 (defvar elmo-work-buf-name " *elmo work*")
  54 (defvar elmo-temp-buf-name " *elmo temp*")
  55
  56 (or (boundp 'default-enable-multibyte-characters)
  57     (defvar default-enable-multibyte-characters (featurep 'mule)
  58       "The mock variable except for Emacs 20."))
  59
  60 (defun elmo-base64-encode-string (string &optional no-line-break))
  61 (defun elmo-base64-decode-string (string))
  62
  63 ;; base64 encoding/decoding
  64 (require 'mel)
  65 (fset 'elmo-base64-encode-string
  66       (mel-find-function 'mime-encode-string "base64"))
  67 (fset 'elmo-base64-decode-string
  68       (mel-find-function 'mime-decode-string "base64"))
  69
  70 ;; Any Emacsen may have add-name-to-file(), because loadup.el requires it. :-p
  71 ;; Check make-symbolic-link() instead.  -- 981002 by Fuji
  72 (if (fboundp 'make-symbolic-link)  ;; xxx
  73     (defalias 'elmo-add-name-to-file 'add-name-to-file)
  74   (defun elmo-add-name-to-file
  75     (filename newname &optional ok-if-already-exists)
  76     (copy-file filename newname ok-if-already-exists t)))
  77
  78 (defmacro elmo-set-work-buf (&rest body)
  79   "Execute BODY on work buffer.  Work buffer remains."
  80   (` (save-excursion
  81        (set-buffer (get-buffer-create elmo-work-buf-name))
  82        (elmo-set-buffer-multibyte default-enable-multibyte-characters)
  83        (erase-buffer)
  84        (,@ body))))
  85
  86 (defmacro elmo-bind-directory (dir &rest body)
  87   "Set current directory DIR and execute BODY."
  88   (` (let ((default-directory (file-name-as-directory (, dir))))
  89        (,@ body))))
  90
  91 (defun elmo-object-load (filename &optional mime-charset no-err)
  92   "Load OBJECT from the file specified by FILENAME.
  93 File content is decoded with MIME-CHARSET."
  94     (if (not (file-readable-p filename))
  95         nil
  96       (elmo-set-work-buf
  97        (as-binary-input-file
  98         (insert-file-contents filename))
  99        (when mime-charset
 100          (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 101          (decode-mime-charset-region (point-min) (point-max) mime-charset))
 102        (condition-case nil
 103            (read (current-buffer))
 104          (error (unless no-err
 105                   (message "Warning: Loading object from %s failed."
 106                            filename)
 107                   (elmo-object-save filename nil))
 108                 nil)))))
 109
 110 (defsubst elmo-save-buffer (filename &optional mime-charset)
 111   "Save current buffer to the file specified by FILENAME.
 112 Directory of the file is created if it doesn't exist.
 113 File content is encoded with MIME-CHARSET."
 114   (let ((dir (directory-file-name (file-name-directory filename))))
 115     (if (file-directory-p dir)
 116         () ; ok.
 117       (unless (file-exists-p dir)
 118         (elmo-make-directory dir)))
 119     (if (file-writable-p filename)
 120         (progn
 121           (when mime-charset
 122 ;;;         (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 123             (encode-mime-charset-region (point-min) (point-max) mime-charset))
 124           (as-binary-output-file
 125            (write-region (point-min) (point-max) filename nil 'no-msg)))
 126       (message "%s is not writable." filename))))
 127
 128 (defun elmo-object-save (filename object &optional mime-charset)
 129   "Save OBJECT to the file specified by FILENAME.
 130 Directory of the file is created if it doesn't exist.
 131 File content is encoded with MIME-CHARSET."
 132   (elmo-set-work-buf
 133    (let (print-length print-level)
 134      (prin1 object (current-buffer)))
 135 ;;;(princ "\n" (current-buffer))
 136    (elmo-save-buffer filename mime-charset)))
 137
 138 ;;; Search Condition
 139
 140 (defconst elmo-condition-atom-regexp "[^/ \")|&]*")
 141
 142 (defun elmo-read-search-condition (default)
 143   "Read search condition string interactively."
 144   (elmo-read-search-condition-internal "Search by" default))
 145
 146 (defun elmo-read-search-condition-internal (prompt default)
 147   (let* ((completion-ignore-case t)
 148          (field (completing-read
 149                  (format "%s (%s): " prompt default)
 150                  (mapcar 'list
 151                          (append '("AND" "OR"
 152                                    "Last" "First" "Flag"
 153                                    "From" "Subject" "To" "Cc" "Body"
 154                                    "Since" "Before" "ToCc"
 155                                    "!From" "!Subject" "!To" "!Cc" "!Body"
 156                                    "!Since" "!Before" "!ToCc")
 157                                  elmo-msgdb-extra-fields))))
 158          value)
 159     (setq field (if (string= field "")
 160                     (setq field default)
 161                   field))
 162     (cond
 163      ((or (string= field "AND") (string= field "OR"))
 164       (concat "("
 165               (elmo-read-search-condition-internal
 166                (concat field "(1) Search by") default)
 167               (if (string= field "AND") "&" "|")
 168               (elmo-read-search-condition-internal
 169                (concat field "(2) Search by") default)
 170               ")"))
 171      ((string-match "Since\\|Before" field)
 172       (let ((default (format-time-string "%Y-%m-%d")))
 173         (setq value (completing-read
 174                      (format "Value for '%s' [%s]: " field default)
 175                      (mapcar (function
 176                               (lambda (x)
 177                                 (list (format "%s" (car x)))))
 178                              elmo-date-descriptions)))
 179         (concat (downcase field) ":"
 180                 (if (equal value "") default value))))
 181      ((string= field "Flag")
 182       (setq value (completing-read
 183                    (format "Value for '%s': " field)
 184                    (mapcar 'list
 185                            '("unread" "important" "answered" "digest" "any"))))
 186       (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
 187                             value)
 188         (setq value (prin1-to-string value)))
 189       (concat (downcase field) ":" value))
 190      (t
 191       (setq value (read-from-minibuffer (format "Value for '%s': " field)))
 192       (unless (string-match (concat "^" elmo-condition-atom-regexp "$")
 193                             value)
 194         (setq value (prin1-to-string value)))
 195       (concat (downcase field) ":" value)))))
 196
 197 (defsubst elmo-condition-parse-error ()
 198   (error "Syntax error in '%s'" (buffer-string)))
 199
 200 (defun elmo-parse-search-condition (condition)
 201   "Parse CONDITION.
 202 Return value is a cons cell of (STRUCTURE . REST)"
 203   (with-temp-buffer
 204     (insert condition)
 205     (goto-char (point-min))
 206     (cons (elmo-condition-parse) (buffer-substring (point) (point-max)))))
 207
 208 ;; condition    ::= or-expr
 209 (defun elmo-condition-parse ()
 210   (or (elmo-condition-parse-or-expr)
 211       (elmo-condition-parse-error)))
 212
 213 ;; or-expr      ::= and-expr /
 214 ;;                  and-expr "|" or-expr
 215 (defun elmo-condition-parse-or-expr ()
 216   (let ((left (elmo-condition-parse-and-expr)))
 217     (if (looking-at "| *")
 218         (progn
 219           (goto-char (match-end 0))
 220           (list 'or left (elmo-condition-parse-or-expr)))
 221       left)))
 222
 223 ;; and-expr     ::= primitive /
 224 ;;                  primitive "&" and-expr
 225 (defun elmo-condition-parse-and-expr ()
 226   (let ((left (elmo-condition-parse-primitive)))
 227     (if (looking-at "& *")
 228         (progn
 229           (goto-char (match-end 0))
 230           (list 'and left (elmo-condition-parse-and-expr)))
 231       left)))
 232
 233 ;; primitive    ::= "(" expr ")" /
 234 ;;                  ["!"] search-key SPACE* ":" SPACE* search-value
 235 (defun elmo-condition-parse-primitive ()
 236   (cond
 237    ((looking-at "( *")
 238     (goto-char (match-end 0))
 239     (prog1 (elmo-condition-parse)
 240       (unless (looking-at ") *")
 241         (elmo-condition-parse-error))
 242       (goto-char (match-end 0))))
 243 ;; search-key   ::= [A-Za-z-]+
 244 ;;                 ;; "since" / "before" / "last" / "first" /
 245 ;;                 ;; "body" / "mark" / field-name
 246    ((looking-at "\\(!\\)? *\\([A-Za-z-]+\\) *: *")
 247     (goto-char (match-end 0))
 248     (let ((search-key (vector
 249                        (if (match-beginning 1) 'unmatch 'match)
 250                        (elmo-match-buffer 2)
 251                        (elmo-condition-parse-search-value))))
 252       ;; syntax sugar.
 253       (if (string= (aref search-key 1) "tocc")
 254           (if (eq (aref search-key 0) 'match)
 255               (list 'or
 256                     (vector 'match "to" (aref search-key 2))
 257                     (vector 'match "cc" (aref search-key 2)))
 258             (list 'and
 259                   (vector 'unmatch "to" (aref search-key 2))
 260                   (vector 'unmatch "cc" (aref search-key 2))))
 261         search-key)))))
 262
 263 ;; search-value ::= quoted / time / number / atom
 264 ;; quoted       ::= <elisp string expression>
 265 ;; time         ::= "yesterday" / "lastweek" / "lastmonth" / "lastyear" /
 266 ;;                   number SPACE* "daysago" /
 267 ;;                   number "-" month "-" number  ; ex. 10-May-2000
 268 ;;                   number "-" number "-" number  ; ex. 2000-05-10
 269 ;; number       ::= [0-9]+
 270 ;; month        ::= "Jan" / "Feb" / "Mar" / "Apr" / "May" / "Jun" /
 271 ;;                  "Jul" / "Aug" / "Sep" / "Oct" / "Nov" / "Dec"
 272 ;; atom         ::= ATOM_CHARS*
 273 ;; SPACE        ::= <ascii space character, 0x20>
 274 ;; ATOM_CHARS   ::= <any character except specials>
 275 ;; specials     ::= SPACE / <"> / </> / <)> / <|> / <&>
 276 ;;                  ;; These characters should be quoted.
 277 (defun elmo-condition-parse-search-value ()
 278   (cond
 279    ((looking-at "\"")
 280     (read (current-buffer)))
 281    ((or (looking-at "yesterday") (looking-at "lastweek")
 282         (looking-at "lastmonth") (looking-at "lastyear")
 283         (looking-at "[0-9]+ *daysago")
 284         (looking-at "[0-9]+-[A-Za-z]+-[0-9]+")
 285         (looking-at "[0-9]+-[0-9]+-[0-9]+")
 286         (looking-at "[0-9]+")
 287         (looking-at elmo-condition-atom-regexp))
 288     (prog1 (elmo-match-buffer 0)
 289       (goto-char (match-end 0))))
 290    (t (error "Syntax error '%s'" (buffer-string)))))
 291
 292 ;;;
 293 (defsubst elmo-buffer-replace (regexp &optional newtext)
 294   (goto-char (point-min))
 295   (while (re-search-forward regexp nil t)
 296     (replace-match (or newtext ""))))
 297
 298 (defsubst elmo-delete-char (char string &optional unibyte)
 299   (save-match-data
 300     (elmo-set-work-buf
 301      (let ((coding-system-for-read 'no-conversion)
 302            (coding-system-for-write 'no-conversion))
 303        (if unibyte (elmo-set-buffer-multibyte nil))
 304        (insert string)
 305        (goto-char (point-min))
 306        (while (search-forward (char-to-string char) nil t)
 307          (replace-match ""))
 308        (buffer-string)))))
 309
 310 (defsubst elmo-delete-cr-buffer ()
 311   "Delete CR from buffer."
 312   (save-excursion
 313     (goto-char (point-min))
 314     (while (search-forward "\r\n" nil t)
 315       (replace-match "\n")) ))
 316
 317 (defsubst elmo-delete-cr-get-content-type ()
 318   (save-excursion
 319     (goto-char (point-min))
 320     (while (search-forward "\r\n" nil t)
 321       (replace-match "\n"))
 322     (goto-char (point-min))
 323     (or (std11-field-body "content-type")
 324         t)))
 325
 326 (defun elmo-delete-cr (string)
 327   (save-match-data
 328     (elmo-set-work-buf
 329      (insert string)
 330      (goto-char (point-min))
 331      (while (search-forward "\r\n" nil t)
 332        (replace-match "\n"))
 333      (buffer-string))))
 334
 335 (defun elmo-uniq-list (lst &optional delete-function)
 336   "Distractively uniqfy elements of LST."
 337   (setq delete-function (or delete-function #'delete))
 338   (let ((tmp lst))
 339     (while tmp
 340       (setq tmp
 341             (setcdr tmp
 342                     (and (cdr tmp)
 343                          (funcall delete-function
 344                                   (car tmp)
 345                                   (cdr tmp)))))))
 346   lst)
 347
 348 (defun elmo-list-insert (list element after)
 349   (let* ((match (memq after list))
 350          (rest (and match (cdr (memq after list)))))
 351     (if match
 352         (progn
 353           (setcdr match (list element))
 354           (nconc list rest))
 355       (nconc list (list element)))))
 356
 357 (defun elmo-string-partial-p (string)
 358   (and (stringp string) (string-match "message/partial" string)))
 359
 360 (defun elmo-get-file-string (filename &optional remove-final-newline)
 361   (elmo-set-work-buf
 362    (let (insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 363          insert-file-contents-post-hook)
 364      (when (file-exists-p filename)
 365        (if filename
 366            (as-binary-input-file (insert-file-contents filename)))
 367        (when (and remove-final-newline
 368                   (> (buffer-size) 0)
 369                   (= (char-after (1- (point-max))) ?\n))
 370          (goto-char (point-max))
 371          (delete-backward-char 1))
 372        (buffer-string)))))
 373
 374 (defun elmo-save-string (string filename)
 375   (if string
 376       (elmo-set-work-buf
 377        (as-binary-output-file
 378         (insert string)
 379         (write-region (point-min) (point-max)
 380                       filename nil 'no-msg))
 381        )))
 382
 383 (defun elmo-max-of-list (nlist)
 384   (let ((l nlist)
 385         (max-num 0))
 386     (while l
 387       (if (< max-num (car l))
 388           (setq max-num (car l)))
 389       (setq l (cdr l)))
 390     max-num))
 391
 392 (defun elmo-concat-path (path filename)
 393   (if (not (string= path ""))
 394       (if (string= elmo-path-sep (substring path (- (length path) 1)))
 395           (concat path filename)
 396         (concat path elmo-path-sep filename))
 397     filename))
 398
 399 (defvar elmo-passwd-alist nil)
 400
 401 (defun elmo-passwd-alist-load ()
 402   (save-excursion
 403     (let ((filename (expand-file-name elmo-passwd-alist-file-name
 404                                       elmo-msgdb-directory))
 405           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))
 406           insert-file-contents-pre-hook ; To avoid autoconv-xmas...
 407           insert-file-contents-post-hook
 408           ret-val)
 409       (if (not (file-readable-p filename))
 410           ()
 411         (set-buffer tmp-buffer)
 412         (insert-file-contents filename)
 413         (setq ret-val
 414               (condition-case nil
 415                   (read (current-buffer))
 416                 (error nil nil))))
 417       (kill-buffer tmp-buffer)
 418       ret-val)))
 419
 420 (defun elmo-passwd-alist-clear ()
 421   "Clear password cache."
 422   (interactive)
 423   (setq elmo-passwd-alist nil))
 424
 425 (defun elmo-passwd-alist-save ()
 426   "Save password into file."
 427   (interactive)
 428   (save-excursion
 429     (let ((filename (expand-file-name elmo-passwd-alist-file-name
 430                                       elmo-msgdb-directory))
 431           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))
 432           print-length print-level)
 433       (set-buffer tmp-buffer)
 434       (erase-buffer)
 435       (prin1 elmo-passwd-alist tmp-buffer)
 436       (princ "\n" tmp-buffer)
 437 ;;;   (if (and (file-exists-p filename)
 438 ;;;            (not (equal 384 (file-modes filename))))
 439 ;;;       (error "%s is not safe.chmod 600 %s!" filename filename))
 440       (if (file-writable-p filename)
 441           (progn
 442             (write-region (point-min) (point-max)
 443                           filename nil 'no-msg)
 444             (set-file-modes filename 384))
 445         (message "%s is not writable." filename))
 446       (kill-buffer tmp-buffer))))
 447
 448 (defun elmo-get-passwd (key)
 449   "Get password from password pool."
 450   (let (pair pass)
 451     (if (not elmo-passwd-alist)
 452         (setq elmo-passwd-alist (elmo-passwd-alist-load)))
 453     (setq pair (assoc key elmo-passwd-alist))
 454     (if pair
 455         (elmo-base64-decode-string (cdr pair))
 456       (setq pass (elmo-read-passwd (format "Password for %s: "
 457                                            key) t))
 458       (setq elmo-passwd-alist
 459             (append elmo-passwd-alist
 460                     (list (cons key
 461                                 (elmo-base64-encode-string pass)))))
 462       (if elmo-passwd-life-time
 463           (run-with-timer elmo-passwd-life-time nil
 464                           (` (lambda () (elmo-remove-passwd (, key))))))
 465       pass)))
 466
 467 (defun elmo-remove-passwd (key)
 468   "Remove password from password pool (for failure)."
 469   (let (pass-cons)
 470     (if (setq pass-cons (assoc key elmo-passwd-alist))
 471         (progn
 472           (unwind-protect
 473               (fillarray (cdr pass-cons) 0))
 474           (setq elmo-passwd-alist
 475                 (delete pass-cons elmo-passwd-alist))))))
 476
 477 (defmacro elmo-read-char-exclusive ()
 478   (cond ((featurep 'xemacs)
 479          '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?)
 480                                (left . ?\C-h))))
 481                 event key)
 482             (while (not
 483                     (and
 484                      (key-press-event-p (setq event (next-command-event)))
 485                      (setq key (or (event-to-character event)
 486                                    (cdr (assq (event-key event) table)))))))
 487             key))
 488         ((fboundp 'read-char-exclusive)
 489          '(read-char-exclusive))
 490         (t
 491          '(read-char))))
 492
 493 (defun elmo-read-passwd (prompt &optional stars)
 494   "Read a single line of text from user without echoing, and return it."
 495   (let ((ans "")
 496         (c 0)
 497         (echo-keystrokes 0)
 498         (cursor-in-echo-area t)
 499         (log-message-max-size 0)
 500         message-log-max done msg truncate)
 501     (while (not done)
 502       (if (or (not stars) (string= "" ans))
 503           (setq msg prompt)
 504         (setq msg (concat prompt (make-string (length ans) ?.)))
 505         (setq truncate
 506               (1+ (- (length msg) (window-width (minibuffer-window)))))
 507         (and (> truncate 0)
 508              (setq msg (concat "$" (substring msg (1+ truncate))))))
 509       (message "%s" msg)
 510       (setq c (elmo-read-char-exclusive))
 511       (cond ((= c ?\C-g)
 512              (setq quit-flag t
 513                    done t))
 514             ((or (= c ?\r) (= c ?\n) (= c ?\e))
 515              (setq done t))
 516             ((= c ?\C-u)
 517              (setq ans ""))
 518             ((and (/= c ?\b) (/= c ?\177))
 519              (setq ans (concat ans (char-to-string c))))
 520             ((> (length ans) 0)
 521              (setq ans (substring ans 0 -1)))))
 522     (if quit-flag
 523         (prog1
 524             (setq quit-flag nil)
 525           (message "Quit")
 526           (beep t))
 527       (message "")
 528       ans)))
 529
 530 (defun elmo-string-to-list (string)
 531   (elmo-set-work-buf
 532    (insert string)
 533    (goto-char (point-min))
 534    (insert "(")
 535    (goto-char (point-max))
 536    (insert ")")
 537    (goto-char (point-min))
 538    (read (current-buffer))))
 539
 540 (defun elmo-list-to-string (list)
 541   (let ((tlist list)
 542         str)
 543     (if (listp tlist)
 544         (progn
 545           (setq str "(")
 546           (while (car tlist)
 547             (setq str
 548                   (concat str
 549                           (if (symbolp (car tlist))
 550                               (symbol-name (car tlist))
 551                             (car tlist))))
 552             (if (cdr tlist)
 553                 (setq str
 554                       (concat str " ")))
 555             (setq tlist (cdr tlist)))
 556           (setq str
 557                 (concat str ")")))
 558       (setq str
 559             (if (symbolp tlist)
 560                 (symbol-name tlist)
 561               tlist)))
 562     str))
 563
 564
 565 (defun elmo-plug-on-by-servers (alist &optional servers)
 566   (let ((server-list (or servers elmo-plug-on-servers)))
 567     (catch 'plugged
 568       (while server-list
 569         (if (elmo-plugged-p (car server-list))
 570             (throw 'plugged t))
 571         (setq server-list (cdr server-list))))))
 572
 573 (defun elmo-plug-on-by-exclude-servers (alist &optional servers)
 574   (let ((server-list (or servers elmo-plug-on-exclude-servers))
 575         server other-servers)
 576     (while alist
 577       (when (and (not (member (setq server (caaar alist)) server-list))
 578                  (not (member server other-servers)))
 579         (push server other-servers))
 580       (setq alist (cdr alist)))
 581     (elmo-plug-on-by-servers alist other-servers)))
 582
 583 (defun elmo-plugged-p (&optional server port stream-type alist label-exp)
 584   (let ((alist (or alist elmo-plugged-alist))
 585         plugged-info)
 586     (cond ((and (not port) (not server))
 587            (cond ((eq elmo-plugged-condition 'one)
 588                   (if alist
 589                       (catch 'plugged
 590                         (while alist
 591                           (if (nth 2 (car alist))
 592                               (throw 'plugged t))
 593                           (setq alist (cdr alist))))
 594                     elmo-plugged))
 595                  ((eq elmo-plugged-condition 'all)
 596                   (if alist
 597                       (catch 'plugged
 598                         (while alist
 599                           (if (not (nth 2 (car alist)))
 600                               (throw 'plugged nil))
 601                           (setq alist (cdr alist)))
 602                         t)
 603                     elmo-plugged))
 604                  ((functionp elmo-plugged-condition)
 605                   (funcall elmo-plugged-condition alist))
 606                  (t ;; independent
 607                   elmo-plugged)))
 608           ((not port) ;; server
 609            (catch 'plugged
 610              (while alist
 611                (when (string= server (caaar alist))
 612                  (if (nth 2 (car alist))
 613                      (throw 'plugged t)))
 614                (setq alist (cdr alist)))))
 615           (t
 616            (setq plugged-info (assoc (list server port stream-type) alist))
 617            (if (not plugged-info)
 618                ;; add elmo-plugged-alist automatically
 619                (progn
 620                  (elmo-set-plugged elmo-plugged server port stream-type
 621                                    nil nil nil label-exp)
 622                  elmo-plugged)
 623              (if (and elmo-auto-change-plugged
 624                       (> elmo-auto-change-plugged 0)
 625                       (nth 3 plugged-info)  ;; time
 626                       (elmo-time-expire (nth 3 plugged-info)
 627                                         elmo-auto-change-plugged))
 628                  t
 629                (nth 2 plugged-info)))))))
 630
 631 (defun elmo-set-plugged (plugged &optional server port stream-type time
 632                                  alist label-exp add)
 633   (let ((alist (or alist elmo-plugged-alist))
 634         label plugged-info)
 635     (cond ((and (not port) (not server))
 636            (setq elmo-plugged plugged)
 637            ;; set plugged all element of elmo-plugged-alist.
 638            (while alist
 639              (setcdr (cdar alist) (list plugged time))
 640              (setq alist (cdr alist))))
 641           ((not port)
 642            ;; set plugged all port of server
 643            (while alist
 644              (when (string= server (caaar alist))
 645                (setcdr (cdar alist) (list plugged time)))
 646              (setq alist (cdr alist))))
 647           (t
 648            ;; set plugged one port of server
 649            (setq plugged-info (assoc (list server port stream-type) alist))
 650            (setq label (if label-exp
 651                            (eval label-exp)
 652                          (nth 1 plugged-info)))
 653            (if plugged-info
 654                ;; if add is non-nil, don't reset plug state.
 655                (unless add
 656                  (setcdr plugged-info (list label plugged time)))
 657              (setq alist
 658                    (setq elmo-plugged-alist
 659                          (nconc
 660                           elmo-plugged-alist
 661                           (list
 662                            (list (list server port stream-type)
 663                                  label plugged time))))))))
 664     alist))
 665
 666 (defun elmo-delete-plugged (&optional server port alist)
 667   (let* ((alist (or alist elmo-plugged-alist))
 668          (alist2 alist))
 669     (cond ((and (not port) (not server))
 670            (setq alist nil))
 671           ((not port)
 672            ;; delete plugged all port of server
 673            (while alist2
 674              (when (string= server (caaar alist2))
 675                (setq alist (delete (car alist2) alist)))
 676              (setq alist2 (cdr alist2))))
 677           (t
 678            ;; delete plugged one port of server
 679            (setq alist
 680                  (delete (assoc (cons server port) alist) alist))))
 681     alist))
 682
 683 (defun elmo-disk-usage (path)
 684   "Get disk usage (bytes) in PATH."
 685   (let ((file-attr
 686          (condition-case () (file-attributes path) (error nil))))
 687     (if file-attr
 688         (if (nth 0 file-attr) ; directory
 689             (let ((files (condition-case ()
 690                              (directory-files path t "^[^\\.]")
 691                            (error nil)))
 692                   (result 0.0))
 693               ;; (result (nth 7 file-attr))) ... directory size
 694               (while files
 695                 (setq result (+ result (or (elmo-disk-usage (car files)) 0)))
 696                 (setq files (cdr files)))
 697               result)
 698           (float (nth 7 file-attr)))
 699       0)))
 700
 701 (defun elmo-get-last-accessed-time (path &optional dir)
 702   "Return the last accessed time of PATH."
 703   (let ((last-accessed (nth 4 (file-attributes (or (and dir
 704                                                         (expand-file-name
 705                                                          path dir))
 706                                                    path)))))
 707     (if last-accessed
 708         (setq last-accessed (+ (* (nth 0 last-accessed)
 709                                   (float 65536)) (nth 1 last-accessed)))
 710       0)))
 711
 712 (defun elmo-get-last-modification-time (path &optional dir)
 713   "Return the last accessed time of PATH."
 714   (let ((last-modified (nth 5 (file-attributes (or (and dir
 715                                                         (expand-file-name
 716                                                          path dir))
 717                                                    path)))))
 718     (setq last-modified (+ (* (nth 0 last-modified)
 719                               (float 65536)) (nth 1 last-modified)))))
 720
 721 (defun elmo-make-directory (path &optional mode)
 722   "Create directory recursively."
 723   (let ((parent (directory-file-name (file-name-directory path))))
 724     (if (null (file-directory-p parent))
 725         (elmo-make-directory parent))
 726     (make-directory path)
 727     (set-file-modes path (or mode
 728                              (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700
 729
 730 (defun elmo-delete-directory (path &optional no-hierarchy)
 731   "Delete directory recursively."
 732   (if (stringp path) ; nil is not permitted.
 733   (let ((dirent (directory-files path))
 734         relpath abspath hierarchy)
 735     (while dirent
 736       (setq relpath (car dirent)
 737             dirent (cdr dirent)
 738             abspath (expand-file-name relpath path))
 739       (when (not (string-match "^\\.\\.?$" relpath))
 740         (if (eq (nth 0 (file-attributes abspath)) t)
 741             (if no-hierarchy
 742                 (setq hierarchy t)
 743               (elmo-delete-directory abspath no-hierarchy))
 744           (delete-file abspath))))
 745     (unless hierarchy
 746       (delete-directory path)))))
 747
 748 (defun elmo-delete-match-files (path regexp &optional remove-if-empty)
 749   "Delete directory files specified by PATH.
 750 If optional REMOVE-IF-EMPTY is non-nil, delete directory itself if
 751 the directory becomes empty after deletion."
 752   (when (stringp path) ; nil is not permitted.
 753     (dolist (file (directory-files path t regexp))
 754       (delete-file file))
 755     (if remove-if-empty
 756         (ignore-errors
 757           (delete-directory path) ; should be removed if empty.
 758           ))))
 759
 760 (defun elmo-list-filter (l1 l2)
 761   "Rerurn a list from L2 in which each element is a member of L1."
 762   (elmo-delete-if (lambda (x) (not (memq x l1))) l2))
 763
 764 (defsubst elmo-list-delete-if-smaller (list number)
 765   (let ((ret-val (copy-sequence list)))
 766     (while list
 767       (if (< (car list) number)
 768           (setq ret-val (delq (car list) ret-val)))
 769       (setq list (cdr list)))
 770     ret-val))
 771
 772 (defun elmo-list-diff (list1 list2 &optional mes)
 773   (if mes
 774       (message "%s" mes))
 775   (let ((clist1 (copy-sequence list1))
 776         (clist2 (copy-sequence list2)))
 777     (while list2
 778       (setq clist1 (delq (car list2) clist1))
 779       (setq list2 (cdr list2)))
 780     (while list1
 781       (setq clist2 (delq (car list1) clist2))
 782       (setq list1 (cdr list1)))
 783     (if mes
 784         (message "%sdone" mes))
 785     (list clist1 clist2)))
 786
 787 (defun elmo-list-bigger-diff (list1 list2 &optional mes)
 788   "Returns a list (- +). + is bigger than max of LIST1, in LIST2."
 789   (if (null list2)
 790       (cons list1  nil)
 791     (let* ((l1 list1)
 792            (l2 list2)
 793            (max-of-l2 (or (nth (max 0 (1- (length l2))) l2) 0))
 794            diff1 num i percent
 795            )
 796       (setq i 0)
 797       (setq num (+ (length l1)))
 798       (while l1
 799         (if (memq (car l1) l2)
 800             (if (eq (car l1) (car l2))
 801                 (setq l2 (cdr l2))
 802               (delq (car l1) l2))
 803           (if (> (car l1) max-of-l2)
 804               (setq diff1 (nconc diff1 (list (car l1))))))
 805         (if mes
 806             (progn
 807               (setq i (+ i 1))
 808               (setq percent (/ (* i 100) num))
 809               (if (eq (% percent 5) 0)
 810                   (elmo-display-progress
 811                    'elmo-list-bigger-diff "%s%d%%" percent mes))))
 812         (setq l1 (cdr l1)))
 813       (cons diff1 (list l2)))))
 814
 815 (defmacro elmo-filter-condition-p (filter)
 816   `(or (vectorp ,filter) (consp ,filter)))
 817
 818 (defmacro elmo-filter-type (filter)
 819   (` (aref (, filter) 0)))
 820
 821 (defmacro elmo-filter-key (filter)
 822   (` (aref (, filter) 1)))
 823
 824 (defmacro elmo-filter-value (filter)
 825   (` (aref (, filter) 2)))
 826
 827 (defsubst elmo-buffer-field-primitive-condition-match (condition
 828                                                        number
 829                                                        number-list)
 830   (let (result)
 831     (goto-char (point-min))
 832     (cond
 833      ((string= (elmo-filter-key condition) "last")
 834       (setq result (<= (length (memq number number-list))
 835                        (string-to-int (elmo-filter-value condition)))))
 836      ((string= (elmo-filter-key condition) "first")
 837       (setq result (< (- (length number-list)
 838                          (length (memq number number-list)))
 839                       (string-to-int (elmo-filter-value condition)))))
 840      ((string= (elmo-filter-key condition) "since")
 841       (let ((field-date (elmo-date-make-sortable-string
 842                          (timezone-fix-time
 843                           (std11-field-body "date")
 844                           (current-time-zone) nil)))
 845             (specified-date (elmo-date-make-sortable-string
 846                              (elmo-date-get-datevec
 847                               (elmo-filter-value condition)))))
 848         (setq result
 849               (or (string= field-date specified-date)
 850                   (string< specified-date field-date)))))
 851      ((string= (elmo-filter-key condition) "before")
 852       (setq result
 853             (string<
 854              (elmo-date-make-sortable-string
 855               (timezone-fix-time
 856                (std11-field-body "date")
 857                (current-time-zone) nil))
 858              (elmo-date-make-sortable-string
 859               (elmo-date-get-datevec
 860                (elmo-filter-value condition))))))
 861      ((string= (elmo-filter-key condition) "body")
 862       (and (re-search-forward "^$" nil t)          ; goto body
 863            (setq result (search-forward (elmo-filter-value condition)
 864                                         nil t))))
 865      (t
 866       (let ((fval (std11-field-body (elmo-filter-key condition))))
 867         (if (eq (length fval) 0) (setq fval nil))
 868         (if fval (setq fval (eword-decode-string fval)))
 869         (setq result (and fval (string-match
 870                                 (elmo-filter-value condition) fval))))))
 871     (if (eq (elmo-filter-type condition) 'unmatch)
 872         (setq result (not result)))
 873     result))
 874
 875 (defun elmo-condition-in-msgdb-p-internal (condition fields)
 876   (cond
 877    ((vectorp condition)
 878     (if (not (member (elmo-filter-key condition) fields))
 879         (throw 'found t)))
 880    ((or (eq (car condition) 'and)
 881         (eq (car condition) 'or))
 882     (elmo-condition-in-msgdb-p-internal (nth 1 condition) fields)
 883     (elmo-condition-in-msgdb-p-internal (nth 2 condition) fields))))
 884
 885 (defun elmo-condition-in-msgdb-p (condition)
 886   (not (catch 'found
 887          (elmo-condition-in-msgdb-p-internal condition
 888                                              (append
 889                                               elmo-msgdb-extra-fields
 890                                               '("last" "first" "from"
 891                                                 "subject" "to" "cc" "since"
 892                                                 "before"))))))
 893
 894 (defun elmo-buffer-field-condition-match (condition number number-list)
 895   (cond
 896    ((vectorp condition)
 897     (elmo-buffer-field-primitive-condition-match
 898      condition number number-list))
 899    ((eq (car condition) 'and)
 900     (and (elmo-buffer-field-condition-match
 901           (nth 1 condition) number number-list)
 902          (elmo-buffer-field-condition-match
 903           (nth 2 condition) number number-list)))
 904    ((eq (car condition) 'or)
 905     (or (elmo-buffer-field-condition-match
 906          (nth 1 condition) number number-list)
 907         (elmo-buffer-field-condition-match
 908          (nth 2 condition) number number-list)))))
 909
 910 (defsubst elmo-file-field-primitive-condition-match (file
 911                                                      condition
 912                                                      number
 913                                                      number-list)
 914   (let (result)
 915     (goto-char (point-min))
 916     (cond
 917      ((string= (elmo-filter-key condition) "last")
 918       (setq result (<= (length (memq number number-list))
 919                        (string-to-int (elmo-filter-value condition))))
 920       (if (eq (elmo-filter-type condition) 'unmatch)
 921           (setq result (not result))))
 922      ((string= (elmo-filter-key condition) "first")
 923       (setq result (< (- (length number-list)
 924                          (length (memq number number-list)))
 925                       (string-to-int (elmo-filter-value condition))))
 926       (if (eq (elmo-filter-type condition) 'unmatch)
 927           (setq result (not result))))
 928      (t
 929       (elmo-set-work-buf
 930        (as-binary-input-file (insert-file-contents file))
 931        (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 932        ;; Should consider charset?
 933        (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
 934        (setq result
 935              (elmo-buffer-field-primitive-condition-match
 936               condition number number-list)))))
 937     result))
 938
 939 (defun elmo-file-field-condition-match (file condition number number-list)
 940   (cond
 941    ((vectorp condition)
 942     (elmo-file-field-primitive-condition-match
 943      file condition number number-list))
 944    ((eq (car condition) 'and)
 945     (and (elmo-file-field-condition-match
 946           file (nth 1 condition) number number-list)
 947          (elmo-file-field-condition-match
 948           file (nth 2 condition) number number-list)))
 949    ((eq (car condition) 'or)
 950     (or (elmo-file-field-condition-match
 951          file (nth 1 condition) number number-list)
 952         (elmo-file-field-condition-match
 953          file (nth 2 condition) number number-list)))))
 954
 955 (defmacro elmo-get-hash-val (string hashtable)
 956   `(symbol-value (intern-soft ,string ,hashtable)))
 957
 958 (defmacro elmo-set-hash-val (string value hashtable)
 959   `(set (intern ,string ,hashtable) ,value))
 960
 961 (defmacro elmo-clear-hash-val (string hashtable)
 962   (static-if (fboundp 'unintern)
 963       (list 'unintern string hashtable)
 964     (list 'makunbound (list 'intern string hashtable))))
 965
 966 (defmacro elmo-unintern (string)
 967   "`unintern' symbol named STRING,  When can use `unintern'.
 968 Emacs 19.28 or earlier does not have `unintern'."
 969   (static-if (fboundp 'unintern)
 970       (list 'unintern string)))
 971
 972 (defun elmo-make-hash (&optional hashsize)
 973   "Make a new hash table which have HASHSIZE size."
 974   (make-vector
 975    (if hashsize
 976        (max
 977         ;; Prime numbers as lengths tend to result in good
 978         ;; hashing; lengths one less than a power of two are
 979         ;; also good.
 980         (min
 981          (let ((i 1))
 982            (while (< (- i 1) hashsize)
 983              (setq i (* 2 i)))
 984            (- i 1))
 985          elmo-hash-maximum-size)
 986         elmo-hash-minimum-size)
 987      elmo-hash-minimum-size)
 988    0))
 989
 990 (defsubst elmo-mime-string (string)
 991   "Normalize MIME encoded STRING."
 992   (and string
 993        (elmo-set-work-buf
 994         (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 995         (setq string
 996               (encode-mime-charset-string
 997                (eword-decode-and-unfold-unstructured-field-body
 998                 string)
 999                elmo-mime-charset))
1000         (elmo-set-buffer-multibyte nil)
1001         string)))
1002
1003 (defsubst elmo-collect-field (beg end downcase-field-name)
1004   (save-excursion
1005     (save-restriction
1006       (narrow-to-region beg end)
1007       (goto-char (point-min))
1008       (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1009             dest name body)
1010         (while (re-search-forward regexp nil t)
1011           (setq name (buffer-substring-no-properties
1012                       (match-beginning 1)(1- (match-end 1))))
1013           (if downcase-field-name
1014               (setq name (downcase name)))
1015           (setq body (buffer-substring-no-properties
1016                       (match-end 0) (std11-field-end)))
1017           (or (assoc name dest)
1018               (setq dest (cons (cons name body) dest))))
1019         dest))))
1020
1021 (defsubst elmo-collect-field-from-string (string downcase-field-name)
1022   (with-temp-buffer
1023     (insert string)
1024     (goto-char (point-min))
1025     (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1026           dest name body)
1027       (while (re-search-forward regexp nil t)
1028         (setq name (buffer-substring-no-properties
1029                     (match-beginning 1)(1- (match-end 1))))
1030         (if downcase-field-name
1031             (setq name (downcase name)))
1032         (setq body (buffer-substring-no-properties
1033                     (match-end 0) (std11-field-end)))
1034         (or (assoc name dest)
1035             (setq dest (cons (cons name body) dest))))
1036       dest)))
1037
1038 (defun elmo-safe-filename (folder)
1039   (elmo-replace-in-string
1040    (elmo-replace-in-string
1041     (elmo-replace-in-string folder "/" " ")
1042     ":" "__")
1043    "|" "_or_"))
1044
1045 (defvar elmo-filename-replace-chars nil)
1046
1047 (defsubst elmo-replace-string-as-filename (msgid)
1048   "Replace string as filename."
1049   (setq msgid (elmo-replace-in-string msgid " " "  "))
1050   (if (null elmo-filename-replace-chars)
1051       (setq elmo-filename-replace-chars
1052             (regexp-quote (mapconcat
1053                            'car elmo-filename-replace-string-alist ""))))
1054   (while (string-match (concat "[" elmo-filename-replace-chars "]")
1055                        msgid)
1056     (setq msgid (concat
1057                  (substring msgid 0 (match-beginning 0))
1058                  (cdr (assoc
1059                        (substring msgid
1060                                   (match-beginning 0) (match-end 0))
1061                        elmo-filename-replace-string-alist))
1062                  (substring msgid (match-end 0)))))
1063   msgid)
1064
1065 (defsubst elmo-recover-string-from-filename (filename)
1066   "Recover string from FILENAME."
1067   (let (tmp result)
1068     (while (string-match " " filename)
1069       (setq tmp (substring filename
1070                            (match-beginning 0)
1071                            (+ (match-end 0) 1)))
1072       (if (string= tmp "  ")
1073           (setq tmp " ")
1074         (setq tmp (car (rassoc tmp
1075                                elmo-filename-replace-string-alist))))
1076       (setq result
1077             (concat result
1078                     (substring filename 0 (match-beginning 0))
1079                     tmp))
1080       (setq filename (substring filename (+ (match-end 0) 1))))
1081     (concat result filename)))
1082
1083 (defsubst elmo-copy-file (src dst &optional ok-if-already-exists)
1084   (condition-case err
1085       (elmo-add-name-to-file src dst ok-if-already-exists)
1086     (error (copy-file src dst ok-if-already-exists t))))
1087
1088 (defsubst elmo-buffer-exists-p (buffer)
1089   (if (bufferp buffer)
1090       (buffer-live-p buffer)
1091     (get-buffer buffer)))
1092
1093 (defsubst elmo-kill-buffer (buffer)
1094   (when (elmo-buffer-exists-p buffer)
1095     (kill-buffer buffer)))
1096
1097 (defun elmo-delete-if (pred lst)
1098   "Return new list contain items which don't satisfy PRED in LST."
1099   (let (result)
1100     (while lst
1101       (unless (funcall pred (car lst))
1102         (setq result (nconc result (list (car lst)))))
1103       (setq lst (cdr lst)))
1104     result))
1105
1106 (defun elmo-list-delete (list1 list2 &optional delete-function)
1107   "Delete by side effect any occurrences equal to elements of LIST1 from LIST2.
1108 Return the modified LIST2.  Deletion is done with `delete'.
1109 Write `(setq foo (elmo-list-delete bar foo))' to be sure of changing
1110 the value of `foo'.
1111 If optional DELETE-FUNCTION is speficied, it is used as delete procedure."
1112   (setq delete-function (or delete-function 'delete))
1113   (while list1
1114     (setq list2 (funcall delete-function (car list1) list2))
1115     (setq list1 (cdr list1)))
1116   list2)
1117
1118 (defun elmo-list-member (list1 list2)
1119   "If any element of LIST1 is member of LIST2, return t."
1120   (catch 'done
1121     (while list1
1122       (if (member (car list1) list2)
1123           (throw 'done t))
1124       (setq list1 (cdr list1)))))
1125
1126 (defun elmo-count-matches (regexp beg end)
1127   (let ((count 0))
1128     (save-excursion
1129       (goto-char beg)
1130       (while (re-search-forward regexp end t)
1131         (setq count (1+ count)))
1132       count)))
1133
1134 (if (fboundp 'display-error)
1135     (defalias 'elmo-display-error 'display-error)
1136   (defun elmo-display-error (error-object stream)
1137     "A tiny function to display ERROR-OBJECT to the STREAM."
1138     (let ((first t)
1139           (errobj error-object)
1140           err-mes)
1141       (while errobj
1142         (setq err-mes (concat err-mes (format
1143                                        (if (stringp (car errobj))
1144                                            "%s"
1145                                          "%S")
1146                                        (car errobj))))
1147         (setq errobj (cdr errobj))
1148         (if errobj (setq err-mes (concat err-mes (if first ": " ", "))))
1149         (setq first nil))
1150       (princ err-mes stream))))
1151
1152 (if (fboundp 'define-error)
1153     (defalias 'elmo-define-error 'define-error)
1154   (defun elmo-define-error (error doc &optional parents)
1155     (or parents
1156         (setq parents 'error))
1157     (let ((conds (get parents 'error-conditions)))
1158       (or conds
1159           (error "Not an error symbol: %s" error))
1160       (setplist error
1161                 (list 'error-message doc
1162                       'error-conditions (cons error conds))))))
1163
1164 (cond ((fboundp 'progress-feedback-with-label)
1165        (defalias 'elmo-display-progress 'progress-feedback-with-label))
1166       ((fboundp 'lprogress-display)
1167        (defalias 'elmo-display-progress 'lprogress-display))
1168       (t
1169        (defun elmo-display-progress (label format &optional value &rest args)
1170          "Print a progress message."
1171          (if (and (null format) (null args))
1172              (message nil)
1173            (apply (function message) (concat format " %d%%")
1174                   (nconc args (list value)))))))
1175
1176 (defvar elmo-progress-counter-alist nil)
1177
1178 (defmacro elmo-progress-counter-value (counter)
1179   (` (aref (cdr (, counter)) 0)))
1180
1181 (defmacro elmo-progress-counter-all-value (counter)
1182   (` (aref (cdr (, counter)) 1)))
1183
1184 (defmacro elmo-progress-counter-format (counter)
1185   (` (aref (cdr (, counter)) 2)))
1186
1187 (defmacro elmo-progress-counter-set-value (counter value)
1188   (` (aset (cdr (, counter)) 0 (, value))))
1189
1190 (defun elmo-progress-set (label all-value &optional format)
1191   (unless (assq label elmo-progress-counter-alist)
1192     (setq elmo-progress-counter-alist
1193           (cons (cons label (vector 0 all-value (or format "")))
1194                 elmo-progress-counter-alist))))
1195
1196 (defun elmo-progress-clear (label)
1197   (let ((counter (assq label elmo-progress-counter-alist)))
1198     (when counter
1199       (elmo-display-progress label
1200                              (elmo-progress-counter-format counter)
1201                              100)
1202       (setq elmo-progress-counter-alist
1203             (delq counter elmo-progress-counter-alist)))))
1204
1205 (defun elmo-progress-notify (label &optional value op &rest args)
1206   (let ((counter (assq label elmo-progress-counter-alist)))
1207     (when counter
1208       (let* ((value (or value 1))
1209              (cur-value (elmo-progress-counter-value counter))
1210              (all-value (elmo-progress-counter-all-value counter))
1211              (new-value (if (eq op 'set) value (+ cur-value value)))
1212              (cur-rate (/ (* cur-value 100) all-value))
1213              (new-rate (/ (* new-value 100) all-value)))
1214         (elmo-progress-counter-set-value counter new-value)
1215         (unless (= cur-rate new-rate)
1216           (apply 'elmo-display-progress
1217                  label
1218                  (elmo-progress-counter-format counter)
1219                  new-rate
1220                  args))
1221         (when (>= new-rate 100)
1222           (elmo-progress-clear label))))))
1223
1224 (put 'elmo-with-progress-display 'lisp-indent-function '2)
1225 (def-edebug-spec elmo-with-progress-display
1226   (form (symbolp form &optional form) &rest form))
1227
1228 (defmacro elmo-with-progress-display (condition spec &rest body)
1229   "Evaluate BODY with progress gauge if CONDITION is non-nil.
1230 SPEC is a list as followed (LABEL MAX-VALUE [FORMAT])."
1231   (let ((label (car spec))
1232         (max-value (cadr spec))
1233         (fmt (caddr spec)))
1234     `(unwind-protect
1235          (progn
1236            (when ,condition
1237              (elmo-progress-set (quote ,label) ,max-value ,fmt))
1238            ,@body)
1239        (elmo-progress-clear (quote ,label)))))
1240
1241 (defun elmo-time-expire (before-time diff-time)
1242   (let* ((current (current-time))
1243          (rest (when (< (nth 1 current) (nth 1 before-time))
1244                  (expt 2 16)))
1245          diff)
1246     (setq diff
1247           (list (- (+ (car current) (if rest -1 0)) (car before-time))
1248                 (- (+ (or rest 0) (nth 1 current)) (nth 1 before-time))))
1249     (and (eq (car diff) 0)
1250          (< diff-time (nth 1 diff)))))
1251
1252 (if (fboundp 'std11-fetch-field)
1253     (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
1254   (defalias 'elmo-field-body 'std11-field-body))
1255
1256 (defun elmo-address-quote-specials (word)
1257   "Make quoted string of WORD if needed."
1258   (let ((lal (std11-lexical-analyze word)))
1259     (if (or (assq 'specials lal)
1260             (assq 'domain-literal lal))
1261         (prin1-to-string word)
1262       word)))
1263
1264 (defmacro elmo-string (string)
1265   "STRING without text property."
1266   (` (let ((obj (copy-sequence (, string))))
1267        (and obj (set-text-properties 0 (length obj) nil obj))
1268        obj)))
1269
1270 (defun elmo-flatten (list-of-list)
1271   "Flatten LIST-OF-LIST."
1272   (unless (null list-of-list)
1273     (append (if (and (car list-of-list)
1274                      (listp (car list-of-list)))
1275                 (car list-of-list)
1276               (list (car list-of-list)))
1277             (elmo-flatten (cdr list-of-list)))))
1278
1279 (defun elmo-y-or-n-p (prompt &optional auto default)
1280   "Same as `y-or-n-p'.
1281 But if optional argument AUTO is non-nil, DEFAULT is returned."
1282   (if auto
1283       default
1284     (y-or-n-p prompt)))
1285
1286 (defun elmo-string-member (string slist)
1287   (catch 'found
1288     (while slist
1289       (if (and (stringp (car slist))
1290                (string= string (car slist)))
1291           (throw 'found t))
1292       (setq slist (cdr slist)))))
1293
1294 (cond ((fboundp 'member-ignore-case)
1295        (defalias 'elmo-string-member-ignore-case 'member-ignore-case))
1296       ((fboundp 'compare-strings)
1297        (defun elmo-string-member-ignore-case (elt list)
1298          "Like `member', but ignores differences in case and text representation.
1299 ELT must be a string.  Upper-case and lower-case letters are treated as equal.
1300 Unibyte strings are converted to multibyte for comparison."
1301          (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t))))
1302            (setq list (cdr list)))
1303          list))
1304       (t
1305        (defun elmo-string-member-ignore-case (elt list)
1306          "Like `member', but ignores differences in case and text representation.
1307 ELT must be a string.  Upper-case and lower-case letters are treated as equal."
1308          (let ((str (downcase elt)))
1309            (while (and list (not (string= str (downcase (car list)))))
1310              (setq list (cdr list)))
1311            list))))
1312
1313 (defun elmo-string-match-member (str list &optional case-ignore)
1314   (let ((case-fold-search case-ignore))
1315     (catch 'member
1316       (while list
1317         (if (string-match (car list) str)
1318             (throw 'member (car list)))
1319         (setq list (cdr list))))))
1320
1321 (defun elmo-string-matched-member (str list &optional case-ignore)
1322   (let ((case-fold-search case-ignore))
1323     (catch 'member
1324       (while list
1325         (if (string-match str (car list))
1326             (throw 'member (car list)))
1327         (setq list (cdr list))))))
1328
1329 (defsubst elmo-string-delete-match (string pos)
1330   (concat (substring string
1331                      0 (match-beginning pos))
1332           (substring string
1333                      (match-end pos)
1334                      (length string))))
1335
1336 (defun elmo-string-match-assoc (key alist &optional case-ignore)
1337   (let ((case-fold-search case-ignore)
1338         a)
1339     (catch 'loop
1340       (while alist
1341         (setq a (car alist))
1342         (if (and (consp a)
1343                  (stringp (car a))
1344                  (string-match key (car a)))
1345             (throw 'loop a))
1346         (setq alist (cdr alist))))))
1347
1348 (defun elmo-string-matched-assoc (key alist &optional case-ignore)
1349   (let ((case-fold-search case-ignore)
1350         a)
1351     (catch 'loop
1352       (while alist
1353         (setq a (car alist))
1354         (if (and (consp a)
1355                  (stringp (car a))
1356                  (string-match (car a) key))
1357             (throw 'loop a))
1358         (setq alist (cdr alist))))))
1359
1360 (defun elmo-string-assoc (key alist)
1361   (let (a)
1362     (catch 'loop
1363       (while alist
1364         (setq a (car alist))
1365         (if (and (consp a)
1366                  (stringp (car a))
1367                  (string= key (car a)))
1368             (throw 'loop a))
1369         (setq alist (cdr alist))))))
1370
1371 (defun elmo-string-assoc-all (key alist)
1372   (let (matches)
1373     (while alist
1374       (if (string= key (car (car alist)))
1375           (setq matches
1376                 (cons (car alist)
1377                       matches)))
1378       (setq alist (cdr alist)))
1379     matches))
1380
1381 (defun elmo-string-rassoc (key alist)
1382   (let (a)
1383     (catch 'loop
1384       (while alist
1385         (setq a (car alist))
1386         (if (and (consp a)
1387                  (stringp (cdr a))
1388                  (string= key (cdr a)))
1389             (throw 'loop a))
1390         (setq alist (cdr alist))))))
1391
1392 (defun elmo-string-rassoc-all (key alist)
1393   (let (matches)
1394     (while alist
1395       (if (string= key (cdr (car alist)))
1396           (setq matches
1397                 (cons (car alist)
1398                       matches)))
1399       (setq alist (cdr alist)))
1400     matches))
1401
1402 (defun elmo-expand-newtext (newtext original)
1403   (let ((len (length newtext))
1404         (pos 0)
1405         c expanded beg N did-expand)
1406     (while (< pos len)
1407       (setq beg pos)
1408       (while (and (< pos len)
1409                   (not (= (aref newtext pos) ?\\)))
1410         (setq pos (1+ pos)))
1411       (unless (= beg pos)
1412         (push (substring newtext beg pos) expanded))
1413       (when (< pos len)
1414         ;; We hit a \; expand it.
1415         (setq did-expand t
1416               pos (1+ pos)
1417               c (aref newtext pos))
1418         (if (not (or (= c ?\&)
1419                      (and (>= c ?1)
1420                           (<= c ?9))))
1421             ;; \ followed by some character we don't expand.
1422             (push (char-to-string c) expanded)
1423           ;; \& or \N
1424           (if (= c ?\&)
1425               (setq N 0)
1426             (setq N (- c ?0)))
1427           (when (match-beginning N)
1428             (push (substring original (match-beginning N) (match-end N))
1429                   expanded))))
1430       (setq pos (1+ pos)))
1431     (if did-expand
1432         (apply (function concat) (nreverse expanded))
1433       newtext)))
1434
1435 ;;; Folder parser utils.
1436 (defun elmo-parse-token (string &optional seps)
1437   "Parse atom from STRING using SEPS as a string of separator char list."
1438   (let ((len (length string))
1439         (seps (and seps (string-to-char-list seps)))
1440         (i 0)
1441         (sep nil)
1442         content c in)
1443     (if (eq len 0)
1444         (cons "" "")
1445       (while (and (< i len) (or in (null sep)))
1446         (setq c (aref string i))
1447         (cond
1448          ((and in (eq c ?\\))
1449           (setq i (1+ i)
1450                 content (cons (aref string i) content)
1451                 i (1+ i)))
1452          ((eq c ?\")
1453           (setq in (not in)
1454                 i (1+ i)))
1455          (in (setq content (cons c content)
1456                    i (1+ i)))
1457          ((memq c seps)
1458           (setq sep c))
1459          (t (setq content (cons c content)
1460                   i (1+ i)))))
1461       (if in (error "Parse error in quoted"))
1462       (cons (if (null content) "" (char-list-to-string (nreverse content)))
1463             (substring string i)))))
1464
1465 (defun elmo-parse-prefixed-element (prefix string &optional seps)
1466   (if (and (not (eq (length string) 0))
1467            (eq (aref string 0) prefix))
1468       (elmo-parse-token (substring string 1) seps)
1469     (cons "" string)))
1470
1471 ;;; Number set defined by OKAZAKI Tetsurou <okazaki@be.to>
1472 ;;
1473 ;; number          ::= [0-9]+
1474 ;; beg             ::= number
1475 ;; end             ::= number
1476 ;; number-range    ::= "(" beg " . " end ")"      ;; cons cell
1477 ;; number-set-elem ::= number / number-range
1478 ;; number-set      ::= "(" *number-set-elem ")"   ;; list
1479
1480 (defun elmo-number-set-member (number number-set)
1481   "Return non-nil if NUMBER is an element of NUMBER-SET.
1482 The value is actually the tail of NUMBER-RANGE whose car contains NUMBER."
1483   (or (memq number number-set)
1484       (let (found)
1485         (while (and number-set (not found))
1486           (if (and (consp (car number-set))
1487                    (and (<= (car (car number-set)) number)
1488                         (<= number (cdr (car number-set)))))
1489               (setq found t)
1490             (setq number-set (cdr number-set))))
1491         number-set)))
1492
1493 (defun elmo-number-set-append-list (number-set list)
1494   "Append LIST of numbers to the NUMBER-SET.
1495 NUMBER-SET is altered."
1496   (let ((appended number-set))
1497     (while list
1498       (setq appended (elmo-number-set-append appended (car list)))
1499       (setq list (cdr list)))
1500     appended))
1501
1502 (defun elmo-number-set-append (number-set number)
1503   "Append NUMBER to the NUMBER-SET.
1504 NUMBER-SET is altered."
1505   (let ((number-set-1 number-set)
1506         found elem)
1507     (while (and number-set (not found))
1508       (setq elem (car number-set))
1509       (cond
1510        ((and (consp elem)
1511              (eq (+ 1 (cdr elem)) number))
1512         (setcdr elem number)
1513         (setq found t))
1514        ((and (integerp elem)
1515              (eq (+ 1 elem) number))
1516         (setcar number-set (cons elem number))
1517         (setq found t))
1518        ((or (and (integerp elem) (eq elem number))
1519             (and (consp elem)
1520                  (<= (car elem) number)
1521                  (<= number (cdr elem))))
1522         (setq found t)))
1523       (setq number-set (cdr number-set)))
1524     (if (not found)
1525         (setq number-set-1 (nconc number-set-1 (list number))))
1526     number-set-1))
1527
1528 (defun elmo-number-set-to-number-list (number-set)
1529   "Return a number list which corresponds to NUMBER-SET."
1530   (let (number-list elem i)
1531     (while number-set
1532       (setq elem (car number-set))
1533       (cond
1534        ((consp elem)
1535         (setq i (car elem))
1536         (while (<= i (cdr elem))
1537           (setq number-list (cons i number-list))
1538           (incf i)))
1539        ((integerp elem)
1540         (setq number-list (cons elem number-list))))
1541       (setq number-set (cdr number-set)))
1542     (nreverse number-list)))
1543
1544 (defcustom elmo-list-subdirectories-ignore-regexp "^\\(\\.\\.?\\|[0-9]+\\)$"
1545   "*Regexp to filter subfolders."
1546   :type 'regexp
1547   :group 'elmo)
1548
1549 (defun elmo-list-subdirectories-1 (basedir curdir one-level)
1550   (let ((root (zerop (length curdir)))
1551         (w32-get-true-file-link-count t) ; for Meadow
1552         attr dirs dir)
1553     (catch 'done
1554       (dolist (file (directory-files (setq dir (expand-file-name curdir basedir))))
1555         (when (and (not (string-match
1556                          elmo-list-subdirectories-ignore-regexp
1557                          file))
1558                    (car (setq attr (file-attributes
1559                                     (expand-file-name file dir)))))
1560           (when (eq one-level 'check) (throw 'done t))
1561           (let ((relpath
1562                  (concat curdir (and (not root) elmo-path-sep) file))
1563                 subdirs)
1564             (setq dirs (nconc dirs
1565                               (if (if elmo-have-link-count (< 2 (nth 1 attr))
1566                                     (setq subdirs
1567                                           (elmo-list-subdirectories-1
1568                                            basedir
1569                                            relpath
1570                                            (if one-level 'check))))
1571                                   (if one-level
1572                                       (list (list relpath))
1573                                     (cons relpath
1574                                           (or subdirs
1575                                               (elmo-list-subdirectories-1
1576                                                basedir
1577                                                relpath
1578                                                nil))))
1579                                 (list relpath)))))))
1580       dirs)))
1581
1582 (defun elmo-list-subdirectories (directory file one-level)
1583   (let ((subdirs (elmo-list-subdirectories-1 directory file one-level)))
1584     (if (zerop (length file))
1585         subdirs
1586       (cons file subdirs))))
1587
1588 (defun elmo-mapcar-list-of-list (func list-of-list)
1589   (mapcar
1590    (lambda (x)
1591      (cond ((listp x) (elmo-mapcar-list-of-list func x))
1592            (t (funcall func x))))
1593    list-of-list))
1594
1595 (defun elmo-parse (string regexp &optional matchn)
1596   (or matchn (setq matchn 1))
1597   (let (list)
1598     (store-match-data nil)
1599     (while (string-match regexp string (match-end 0))
1600       (setq list (cons (substring string (match-beginning matchn)
1601                                   (match-end matchn)) list)))
1602     (nreverse list)))
1603
1604 ;;; File cache.
1605 (defmacro elmo-make-file-cache (path status)
1606   "PATH is the cache file name.
1607 STATUS is one of 'section, 'entire or nil.
1608  nil means no cache exists.
1609 'section means partial section cache exists.
1610 'entire means entire cache exists.
1611 If the cache is partial file-cache, TYPE is 'partial."
1612   (` (cons (, path) (, status))))
1613
1614 (defmacro elmo-file-cache-path (file-cache)
1615   "Returns the file path of the FILE-CACHE."
1616   (` (car (, file-cache))))
1617
1618 (defmacro elmo-file-cache-status (file-cache)
1619   "Returns the status of the FILE-CACHE."
1620   (` (cdr (, file-cache))))
1621
1622 (defsubst elmo-cache-to-msgid (filename)
1623   (concat "<" (elmo-recover-string-from-filename filename) ">"))
1624
1625 (defsubst elmo-cache-get-path-subr (msgid)
1626   (let ((chars '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?A ?B ?C ?D ?E ?F))
1627         (clist (string-to-char-list msgid))
1628         (sum 0))
1629     (while clist
1630       (setq sum (+ sum (car clist)))
1631       (setq clist (cdr clist)))
1632     (format "%c%c"
1633             (nth (% (/ sum 16) 2) chars)
1634             (nth (% sum 16) chars))))
1635
1636 ;;;
1637 (defun elmo-file-cache-get-path (msgid &optional section)
1638   "Get cache path for MSGID.
1639 If optional argument SECTION is specified, partial cache path is returned."
1640   (if (setq msgid (elmo-msgid-to-cache msgid))
1641       (expand-file-name
1642        (if section
1643            (format "%s/%s/%s/%s"
1644                    elmo-cache-directory
1645                    (elmo-cache-get-path-subr msgid)
1646                    msgid
1647                    section)
1648          (format "%s/%s/%s"
1649                  elmo-cache-directory
1650                  (elmo-cache-get-path-subr msgid)
1651                  msgid)))))
1652
1653 (defmacro elmo-file-cache-expand-path (path section)
1654   "Return file name for the file-cache corresponds to the section.
1655 PATH is the file-cache path.
1656 SECTION is the section string."
1657   (` (expand-file-name (or (, section) "") (, path))))
1658
1659 (defun elmo-file-cache-delete (path)
1660   "Delete a cache on PATH."
1661   (when (file-exists-p path)
1662     (if (file-directory-p path)
1663         (progn
1664           (dolist (file (directory-files path t "^[^\\.]"))
1665             (delete-file file))
1666           (delete-directory path))
1667       (delete-file path))
1668     t))
1669
1670 (defun elmo-file-cache-exists-p (msgid)
1671   "Returns 'section or 'entire if a cache which corresponds to MSGID exists."
1672   (elmo-file-cache-status (elmo-file-cache-get msgid)))
1673
1674 (defun elmo-file-cache-save (cache-path section)
1675   "Save current buffer as cache on PATH.
1676 Return t if cache is saved successfully."
1677   (condition-case nil
1678       (let ((path (if section (expand-file-name section cache-path)
1679                     cache-path))
1680             files dir)
1681         (if (and (null section)
1682                  (file-directory-p path))
1683             (progn
1684               (setq files (directory-files path t "^[^\\.]"))
1685               (while files
1686                 (delete-file (car files))
1687                 (setq files (cdr files)))
1688               (delete-directory path))
1689           (if (and section
1690                    (not (file-directory-p cache-path)))
1691               (delete-file cache-path)))
1692         (when path
1693           (setq dir (directory-file-name (file-name-directory path)))
1694           (if (not (file-exists-p dir))
1695               (elmo-make-directory dir))
1696           (write-region-as-binary (point-min) (point-max)
1697                                   path nil 'no-msg)
1698           t))
1699     ;; ignore error
1700     (error)))
1701
1702 (defun elmo-file-cache-load (cache-path section)
1703   "Load cache on PATH into the current buffer.
1704 Return t if cache is loaded successfully."
1705   (condition-case nil
1706       (let (cache-file)
1707         (when (and cache-path
1708                    (if (elmo-cache-path-section-p cache-path)
1709                        section
1710                      (null section))
1711                    (setq cache-file (elmo-file-cache-expand-path
1712                                      cache-path
1713                                      section))
1714                    (file-exists-p cache-file))
1715           (insert-file-contents-as-binary cache-file)
1716           t))
1717     ;; igore error
1718     (error)))
1719
1720 (defun elmo-cache-path-section-p (path)
1721   "Return non-nil when PATH is `section' cache path."
1722   (file-directory-p path))
1723
1724 (defun elmo-file-cache-get (msgid &optional section)
1725   "Returns the current file-cache object associated with MSGID.
1726 MSGID is the message-id of the message.
1727 If optional argument SECTION is specified, get partial file-cache object
1728 associated with SECTION."
1729   (if msgid
1730       (let ((path (elmo-cache-get-path msgid)))
1731         (if (and path (file-exists-p path))
1732             (if (elmo-cache-path-section-p path)
1733                 (if section
1734                     (if (file-exists-p (setq path (expand-file-name
1735                                                    section path)))
1736                         (cons path 'section))
1737                   ;; section is not specified but sectional.
1738                   (cons path 'section))
1739               ;; not directory.
1740               (unless section
1741                 (cons path 'entire)))
1742           ;; no cache.
1743           (cons path nil)))))
1744
1745 ;;;
1746 ;; Expire cache.
1747
1748 (defun elmo-cache-expire ()
1749   (interactive)
1750   (let* ((completion-ignore-case t)
1751          (method (completing-read (format "Expire by (%s): "
1752                                           elmo-cache-expire-default-method)
1753                                   '(("size" . "size")
1754                                     ("age" . "age")))))
1755     (if (string= method "")
1756         (setq method elmo-cache-expire-default-method))
1757     (funcall (intern (concat "elmo-cache-expire-by-" method)))))
1758
1759 (defun elmo-read-float-value-from-minibuffer (prompt &optional initial)
1760   (let ((str (read-from-minibuffer prompt initial)))
1761     (cond
1762      ((string-match "[0-9]*\\.[0-9]+" str)
1763       (string-to-number str))
1764      ((string-match "[0-9]+" str)
1765       (string-to-number (concat str ".0")))
1766      (t (error "%s is not number" str)))))
1767
1768 (defun elmo-cache-expire-by-size (&optional kbytes)
1769   "Expire cache file by size.
1770 If KBYTES is kilo bytes (This value must be float)."
1771   (interactive)
1772   (let ((size (or kbytes
1773                   (and (interactive-p)
1774                        (elmo-read-float-value-from-minibuffer
1775                         "Enter cache disk size (Kbytes): "
1776                         (number-to-string
1777                          (if (integerp elmo-cache-expire-default-size)
1778                              (float elmo-cache-expire-default-size)
1779                            elmo-cache-expire-default-size))))
1780                   (if (integerp elmo-cache-expire-default-size)
1781                       (float elmo-cache-expire-default-size))))
1782         (count 0)
1783         (Kbytes 1024)
1784         total beginning)
1785     (message "Checking disk usage...")
1786     (setq total (/ (elmo-disk-usage
1787                     elmo-cache-directory) Kbytes))
1788     (setq beginning total)
1789     (message "Checking disk usage...done")
1790     (let ((cfl (elmo-cache-get-sorted-cache-file-list))
1791           (deleted 0)
1792           oldest
1793           cur-size cur-file)
1794       (while (and (<= size total)
1795                   (setq oldest (elmo-cache-get-oldest-cache-file-entity cfl)))
1796         (setq cur-file (expand-file-name (car (cdr oldest)) (car oldest)))
1797         (setq cur-size (/ (elmo-disk-usage cur-file) Kbytes))
1798         (when (elmo-file-cache-delete cur-file)
1799           (setq count (+ count 1))
1800           (message "%d cache(s) are expired." count))
1801         (setq deleted (+ deleted cur-size))
1802         (setq total (- total cur-size)))
1803       (message "%d cache(s) are expired from disk (%d Kbytes/%d Kbytes)."
1804                count deleted beginning))))
1805
1806 (defun elmo-cache-make-file-entity (filename path)
1807   (cons filename (elmo-get-last-accessed-time filename path)))
1808
1809 (defun elmo-cache-get-oldest-cache-file-entity (cache-file-list)
1810   (let ((cfl cache-file-list)
1811         flist firsts oldest-entity wonlist)
1812     (while cfl
1813       (setq flist (cdr (car cfl)))
1814       (setq firsts (append firsts (list
1815                                    (cons (car (car cfl))
1816                                          (car flist)))))
1817       (setq cfl (cdr cfl)))
1818 ;;; (prin1 firsts)
1819     (while firsts
1820       (if (and (not oldest-entity)
1821                (cdr (cdr (car firsts))))
1822           (setq oldest-entity (car firsts)))
1823       (if (and (cdr (cdr (car firsts)))
1824                (cdr (cdr oldest-entity))
1825                (> (cdr (cdr oldest-entity)) (cdr (cdr (car firsts)))))
1826           (setq oldest-entity (car firsts)))
1827       (setq firsts (cdr firsts)))
1828     (setq wonlist (assoc (car oldest-entity) cache-file-list))
1829     (and wonlist
1830          (setcdr wonlist (delete (car (cdr wonlist)) (cdr wonlist))))
1831     oldest-entity))
1832
1833 (defun elmo-cache-get-sorted-cache-file-list ()
1834   (let ((dirs (directory-files
1835                elmo-cache-directory
1836                t "^[^\\.]"))
1837         (i 0) num
1838         elist
1839         ret-val)
1840     (setq num (length dirs))
1841     (message "Collecting cache info...")
1842     (while dirs
1843       (setq elist (mapcar (lambda (x)
1844                             (elmo-cache-make-file-entity x (car dirs)))
1845                           (directory-files (car dirs) nil "^[^\\.]")))
1846       (setq ret-val (append ret-val
1847                             (list (cons
1848                                    (car dirs)
1849                                    (sort
1850                                     elist
1851                                     (lambda (x y)
1852                                       (< (cdr x)
1853                                          (cdr y))))))))
1854       (when (> num elmo-display-progress-threshold)
1855         (setq i (+ i 1))
1856         (elmo-display-progress
1857          'elmo-cache-get-sorted-cache-file-list "Collecting cache info..."
1858          (/ (* i 100) num)))
1859       (setq dirs (cdr dirs)))
1860     (message "Collecting cache info...done")
1861     ret-val))
1862
1863 (defun elmo-cache-expire-by-age (&optional days)
1864   (let ((age (or (and days (int-to-string days))
1865                  (and (interactive-p)
1866                       (read-from-minibuffer
1867                        (format "Enter days (%s): "
1868                                elmo-cache-expire-default-age)))
1869                  (int-to-string elmo-cache-expire-default-age)))
1870         (dirs (directory-files
1871                elmo-cache-directory
1872                t "^[^\\.]"))
1873         (count 0)
1874         curtime)
1875     (if (string= age "")
1876         (setq age elmo-cache-expire-default-age)
1877       (setq age (string-to-int age)))
1878     (setq curtime (current-time))
1879     (setq curtime (+ (* (nth 0 curtime)
1880                         (float 65536)) (nth 1 curtime)))
1881     (while dirs
1882       (let ((files (directory-files (car dirs) t "^[^\\.]"))
1883             (limit-age (* age 86400)))
1884         (while files
1885           (when (> (- curtime (elmo-get-last-accessed-time (car files)))
1886                    limit-age)
1887             (when (elmo-file-cache-delete (car files))
1888               (setq count (+ 1 count))
1889               (message "%d cache file(s) are expired." count)))
1890           (setq files (cdr files))))
1891       (setq dirs (cdr dirs)))))
1892
1893 ;;;
1894 ;; msgid to path.
1895 (defun elmo-msgid-to-cache (msgid)
1896   (save-match-data
1897     (when (and msgid
1898                (string-match "<\\(.+\\)>$" msgid))
1899       (elmo-replace-string-as-filename (elmo-match-string 1 msgid)))))
1900
1901 (defun elmo-cache-get-path (msgid &optional folder number)
1902   "Get path for cache file associated with MSGID, FOLDER, and NUMBER."
1903   (if (setq msgid (elmo-msgid-to-cache msgid))
1904       (expand-file-name
1905        (expand-file-name
1906         (if folder
1907             (format "%s/%s/%s@%s"
1908                     (elmo-cache-get-path-subr msgid)
1909                     msgid
1910                     (or number "")
1911                     (elmo-safe-filename folder))
1912           (format "%s/%s"
1913                   (elmo-cache-get-path-subr msgid)
1914                   msgid))
1915         elmo-cache-directory))))
1916
1917 ;;;
1918 ;; Warnings.
1919
1920 (static-if (fboundp 'display-warning)
1921     (defmacro elmo-warning (&rest args)
1922       "Display a warning with `elmo' group."
1923       `(display-warning 'elmo (format ,@args)))
1924   (defconst elmo-warning-buffer-name "*elmo warning*")
1925   (defun elmo-warning (&rest args)
1926     "Display a warning. ARGS are passed to `format'."
1927     (with-current-buffer (get-buffer-create elmo-warning-buffer-name)
1928       (goto-char (point-max))
1929       (funcall 'insert (apply 'format (append args '("\n"))))
1930       (ignore-errors (recenter 1))
1931       (display-buffer elmo-warning-buffer-name))))
1932
1933 (defvar elmo-obsolete-variable-alist nil)
1934
1935 (defcustom elmo-obsolete-variable-show-warnings t
1936   "Show warning window if obsolete variable is treated."
1937   :type 'boolean
1938   :group 'elmo)
1939
1940 (defun elmo-define-obsolete-variable (obsolete var)
1941   "Define obsolete variable.
1942 OBSOLETE is a symbol for obsolete variable.
1943 VAR is a symbol for new variable.
1944 Definition is stored in `elmo-obsolete-variable-alist'."
1945   (let ((pair (assq var elmo-obsolete-variable-alist)))
1946     (if pair
1947         (setcdr pair obsolete)
1948       (setq elmo-obsolete-variable-alist
1949             (cons (cons var obsolete)
1950                   elmo-obsolete-variable-alist)))))
1951
1952 (defun elmo-resque-obsolete-variable (obsolete var)
1953   "Resque obsolete variable OBSOLETE as VAR.
1954 If `elmo-obsolete-variable-show-warnings' is non-nil, show warning message."
1955   (when (boundp obsolete)
1956     (static-if (and (fboundp 'defvaralias)
1957                     (subrp (symbol-function 'defvaralias)))
1958         (defvaralias var obsolete)
1959       (set var (symbol-value obsolete)))
1960     (if elmo-obsolete-variable-show-warnings
1961         (elmo-warning "%s is obsolete. Use %s instead."
1962                       (symbol-name obsolete)
1963                       (symbol-name var)))))
1964
1965 (defun elmo-resque-obsolete-variables (&optional alist)
1966   "Resque obsolete variables in ALIST.
1967 ALIST is a list of cons cell of
1968 \(OBSOLETE-VARIABLE-SYMBOL . NEW-VARIABLE-SYMBOL\).
1969 If ALIST is nil, `elmo-obsolete-variable-alist' is used."
1970   (dolist (pair elmo-obsolete-variable-alist)
1971     (elmo-resque-obsolete-variable (cdr pair)
1972                                    (car pair))))
1973
1974 (defsubst elmo-msgdb-get-last-message-id (string)
1975   (if string
1976       (save-match-data
1977         (let (beg)
1978           (elmo-set-work-buf
1979            (insert string)
1980            (goto-char (point-max))
1981            (when (search-backward "<" nil t)
1982              (setq beg (point))
1983              (if (search-forward ">" nil t)
1984                  (elmo-replace-in-string
1985                   (buffer-substring beg (point)) "\n[ \t]*" ""))))))))
1986
1987 (defun elmo-msgdb-get-message-id-from-buffer ()
1988   (let ((msgid (elmo-field-body "message-id")))
1989     (if msgid
1990         (if (string-match "<\\(.+\\)>$" msgid)
1991             msgid
1992           (concat "<" msgid ">")) ; Invaild message-id.
1993       ;; no message-id, so put dummy msgid.
1994       (concat "<" (timezone-make-date-sortable
1995                    (elmo-field-body "date"))
1996               (nth 1 (eword-extract-address-components
1997                       (or (elmo-field-body "from") "nobody"))) ">"))))
1998
1999 (defsubst elmo-msgdb-insert-file-header (file)
2000   "Insert the header of the article."
2001   (let ((beg 0)
2002         insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
2003         insert-file-contents-post-hook
2004         format-alist)
2005     (when (file-exists-p file)
2006       ;; Read until header separator is found.
2007       (while (and (eq elmo-msgdb-file-header-chop-length
2008                       (nth 1
2009                            (insert-file-contents-as-binary
2010                             file nil beg
2011                             (incf beg elmo-msgdb-file-header-chop-length))))
2012                   (prog1 (not (search-forward "\n\n" nil t))
2013                     (goto-char (point-max))))))))
2014
2015 ;;
2016 ;; overview handling
2017 ;;
2018 (defun elmo-multiple-field-body (name &optional boundary)
2019   (save-excursion
2020     (save-restriction
2021       (std11-narrow-to-header boundary)
2022       (goto-char (point-min))
2023       (let ((case-fold-search t)
2024             (field-body nil))
2025         (while (re-search-forward (concat "^" name ":[ \t]*") nil t)
2026           (setq field-body
2027                 (nconc field-body
2028                        (list (buffer-substring-no-properties
2029                               (match-end 0) (std11-field-end))))))
2030         field-body))))
2031
2032 ;;; Queue.
2033 (defvar elmo-dop-queue-filename "queue"
2034   "*Disconnected operation queue is saved in this file.")
2035
2036 (defun elmo-dop-queue-load ()
2037   (setq elmo-dop-queue
2038         (elmo-object-load
2039          (expand-file-name elmo-dop-queue-filename
2040                            elmo-msgdb-directory))))
2041
2042 (defun elmo-dop-queue-save ()
2043   (elmo-object-save
2044    (expand-file-name elmo-dop-queue-filename
2045                      elmo-msgdb-directory)
2046    elmo-dop-queue))
2047
2048 (if (and (fboundp 'regexp-opt)
2049          (not (featurep 'xemacs)))
2050     (defalias 'elmo-regexp-opt 'regexp-opt)
2051   (defun elmo-regexp-opt (strings &optional paren)
2052     "Return a regexp to match a string in STRINGS.
2053 Each string should be unique in STRINGS and should not contain any regexps,
2054 quoted or not.  If optional PAREN is non-nil, ensure that the returned regexp
2055 is enclosed by at least one regexp grouping construct."
2056     (let ((open-paren (if paren "\\(" "")) (close-paren (if paren "\\)" "")))
2057       (concat open-paren (mapconcat 'regexp-quote strings "\\|")
2058               close-paren))))
2059
2060 (require 'product)
2061 (product-provide (provide 'elmo-util) (require 'elmo-version))
2062
2063 ;;; elmo-util.el ends here