elmo/elmo-util.el

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