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