elmo/elmo-util.el

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