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