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