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