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