elmo/elmo-util.el

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