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-string-partial-p (string)
 686   (and (stringp string) (string-match "message/partial" string)))
 687
 688 (defun elmo-get-file-string (filename &optional remove-final-newline)
 689   (elmo-set-work-buf
 690    (let (insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 691          insert-file-contents-post-hook)
 692      (when (file-exists-p filename)
 693        (if filename
 694            (as-binary-input-file (insert-file-contents filename)))
 695        (when (and remove-final-newline
 696                   (> (buffer-size) 0)
 697                   (= (char-after (1- (point-max))) ?\n))
 698          (goto-char (point-max))
 699          (delete-backward-char 1))
 700        (buffer-string)))))
 701
 702 (defun elmo-save-string (string filename)
 703   (if string
 704       (elmo-set-work-buf
 705        (as-binary-output-file
 706         (insert string)
 707         (write-region (point-min) (point-max)
 708                       filename nil 'no-msg))
 709        )))
 710
 711 (defun elmo-max-of-list (nlist)
 712   (let ((l nlist)
 713         (max-num 0))
 714     (while l
 715       (if (< max-num (car l))
 716           (setq max-num (car l)))
 717       (setq l (cdr l)))
 718     max-num))
 719
 720 (defun elmo-concat-path (path filename)
 721   (if (not (string= path ""))
 722       (if (string= elmo-path-sep (substring path (- (length path) 1)))
 723           (concat path filename)
 724         (concat path elmo-path-sep filename))
 725     filename))
 726
 727 (defvar elmo-passwd-alist nil)
 728
 729 (defun elmo-passwd-alist-load ()
 730   (save-excursion
 731     (let ((filename (expand-file-name elmo-passwd-alist-file-name
 732                                       elmo-msgdb-dir))
 733           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))
 734           insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 735           insert-file-contents-post-hook
 736           ret-val)
 737       (if (not (file-readable-p filename))
 738           ()
 739         (set-buffer tmp-buffer)
 740         (insert-file-contents filename)
 741         (setq ret-val
 742               (condition-case nil
 743                   (read (current-buffer))
 744                 (error nil nil))))
 745       (kill-buffer tmp-buffer)
 746       ret-val)))
 747
 748 (defun elmo-passwd-alist-clear ()
 749   "Clear password cache."
 750   (interactive)
 751   (setq elmo-passwd-alist nil))
 752
 753 (defun elmo-passwd-alist-save ()
 754   "Save password into file."
 755   (interactive)
 756   (save-excursion
 757     (let ((filename (expand-file-name elmo-passwd-alist-file-name
 758                                       elmo-msgdb-dir))
 759           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*")))
 760       (set-buffer tmp-buffer)
 761       (erase-buffer)
 762       (prin1 elmo-passwd-alist tmp-buffer)
 763       (princ "\n" tmp-buffer)
 764 ;;;   (if (and (file-exists-p filename)
 765 ;;;            (not (equal 384 (file-modes filename))))
 766 ;;;       (error "%s is not safe.chmod 600 %s!" filename filename))
 767       (if (file-writable-p filename)
 768          (progn
 769            (write-region (point-min) (point-max)
 770                          filename nil 'no-msg)
 771            (set-file-modes filename 384))
 772         (message (format "%s is not writable." filename)))
 773       (kill-buffer tmp-buffer))))
 774
 775 (defun elmo-get-passwd (key)
 776   "Get password from password pool."
 777   (let (pair pass)
 778     (if (not elmo-passwd-alist)
 779         (setq elmo-passwd-alist (elmo-passwd-alist-load)))
 780     (setq pair (assoc key elmo-passwd-alist))
 781     (if pair
 782         (elmo-base64-decode-string (cdr pair))
 783       (setq pass (elmo-read-passwd (format "Password for %s: "
 784                                            key) t))
 785       (setq elmo-passwd-alist
 786             (append elmo-passwd-alist
 787                     (list (cons key
 788                                 (elmo-base64-encode-string pass)))))
 789       (if elmo-passwd-life-time
 790           (run-with-timer elmo-passwd-life-time nil
 791                           (` (lambda () (elmo-remove-passwd (, key))))))
 792       pass)))
 793
 794 (defun elmo-remove-passwd (key)
 795   "Remove password from password pool (for failure)."
 796   (let (pass-cons)
 797     (if (setq pass-cons (assoc key elmo-passwd-alist))
 798         (progn
 799           (unwind-protect
 800               (fillarray (cdr pass-cons) 0))
 801           (setq elmo-passwd-alist
 802                 (delete pass-cons elmo-passwd-alist))))))
 803
 804 (defmacro elmo-read-char-exclusive ()
 805   (cond ((featurep 'xemacs)
 806          '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?)
 807                                (left . ?\C-h))))
 808                 event key)
 809             (while (not
 810                     (and
 811                      (key-press-event-p (setq event (next-command-event)))
 812                      (setq key (or (event-to-character event)
 813                                    (cdr (assq (event-key event) table)))))))
 814             key))
 815         ((fboundp 'read-char-exclusive)
 816          '(read-char-exclusive))
 817         (t
 818          '(read-char))))
 819
 820 (defun elmo-read-passwd (prompt &optional stars)
 821   "Read a single line of text from user without echoing, and return it."
 822   (let ((ans "")
 823         (c 0)
 824         (echo-keystrokes 0)
 825         (cursor-in-echo-area t)
 826         (log-message-max-size 0)
 827         message-log-max done msg truncate)
 828     (while (not done)
 829       (if (or (not stars) (string= "" ans))
 830           (setq msg prompt)
 831         (setq msg (concat prompt (make-string (length ans) ?.)))
 832         (setq truncate
 833               (1+ (- (length msg) (window-width (minibuffer-window)))))
 834         (and (> truncate 0)
 835              (setq msg (concat "$" (substring msg (1+ truncate))))))
 836       (message "%s" msg)
 837       (setq c (elmo-read-char-exclusive))
 838       (cond ((= c ?\C-g)
 839              (setq quit-flag t
 840                    done t))
 841             ((or (= c ?\r) (= c ?\n) (= c ?\e))
 842              (setq done t))
 843             ((= c ?\C-u)
 844              (setq ans ""))
 845             ((and (/= c ?\b) (/= c ?\177))
 846              (setq ans (concat ans (char-to-string c))))
 847             ((> (length ans) 0)
 848              (setq ans (substring ans 0 -1)))))
 849     (if quit-flag
 850         (prog1
 851             (setq quit-flag nil)
 852           (message "Quit")
 853           (beep t))
 854       (message "")
 855       ans)))
 856
 857 ;; from subr.el
 858 (defun elmo-replace-in-string (str regexp newtext &optional literal)
 859   "Replace all matches in STR for REGEXP with NEWTEXT string.
 860 And returns the new string.
 861 Optional LITERAL non-nil means do a literal replacement.
 862 Otherwise treat \\ in NEWTEXT string as special:
 863   \\& means substitute original matched text,
 864   \\N means substitute match for \(...\) number N,
 865   \\\\ means insert one \\."
 866   (let ((rtn-str "")
 867         (start 0)
 868         (special)
 869         match prev-start)
 870     (while (setq match (string-match regexp str start))
 871       (setq prev-start start
 872             start (match-end 0)
 873             rtn-str
 874             (concat
 875              rtn-str
 876              (substring str prev-start match)
 877              (cond (literal newtext)
 878                    (t (mapconcat
 879                        (function
 880                         (lambda (c)
 881                           (if special
 882                               (progn
 883                                 (setq special nil)
 884                                 (cond ((eq c ?\\) "\\")
 885                                       ((eq c ?&)
 886                                        (elmo-match-string 0 str))
 887                                       ((and (>= c ?0) (<= c ?9))
 888                                        (if (> c (+ ?0 (length
 889                                                        (match-data))))
 890                                            ;; Invalid match num
 891                                            (error "Invalid match num: %c" c)
 892                                          (setq c (- c ?0))
 893                                          (elmo-match-string c str)))
 894                                       (t (char-to-string c))))
 895                             (if (eq c ?\\) (progn (setq special t) nil)
 896                               (char-to-string c)))))
 897                        newtext ""))))))
 898     (concat rtn-str (substring str start))))
 899
 900 (defun elmo-string-to-list (string)
 901   (elmo-set-work-buf
 902    (insert string)
 903    (goto-char (point-min))
 904    (insert "(")
 905    (goto-char (point-max))
 906    (insert ")")
 907    (goto-char (point-min))
 908    (read (current-buffer))))
 909
 910 (defun elmo-list-to-string (list)
 911   (let ((tlist list)
 912         str)
 913     (if (listp tlist)
 914         (progn
 915           (setq str "(")
 916           (while (car tlist)
 917             (setq str
 918                   (concat str
 919                           (if (symbolp (car tlist))
 920                               (symbol-name (car tlist))
 921                             (car tlist))))
 922             (if (cdr tlist)
 923                 (setq str
 924                       (concat str " ")))
 925             (setq tlist (cdr tlist)))
 926           (setq str
 927                 (concat str ")")))
 928       (setq str
 929             (if (symbolp tlist)
 930                 (symbol-name tlist)
 931               tlist)))
 932     str))
 933
 934
 935 (defun elmo-plug-on-by-servers (alist &optional servers)
 936   (let ((server-list (or servers elmo-plug-on-servers)))
 937     (catch 'plugged
 938       (while server-list
 939         (if (elmo-plugged-p (car server-list))
 940             (throw 'plugged t))
 941         (setq server-list (cdr server-list))))))
 942
 943 (defun elmo-plug-on-by-exclude-servers (alist &optional servers)
 944   (let ((server-list (or servers elmo-plug-on-exclude-servers))
 945         server other-servers)
 946     (while alist
 947       (when (and (not (member (setq server (caaar alist)) server-list))
 948                  (not (member server other-servers)))
 949         (push server other-servers))
 950       (setq alist (cdr alist)))
 951     (elmo-plug-on-by-servers alist other-servers)))
 952
 953 (defun elmo-plugged-p (&optional server port alist label-exp)
 954   (let ((alist (or alist elmo-plugged-alist))
 955         plugged-info)
 956     (cond ((and (not port) (not server))
 957            (cond ((eq elmo-plugged-condition 'one)
 958                   (catch 'plugged
 959                     (while alist
 960                       (if (nth 2 (car alist))
 961                           (throw 'plugged t))
 962                       (setq alist (cdr alist)))))
 963                  ((eq elmo-plugged-condition 'all)
 964                   (catch 'plugged
 965                     (while alist
 966                       (if (not (nth 2 (car alist)))
 967                           (throw 'plugged nil))
 968                       (setq alist (cdr alist)))
 969                     t))
 970                  ((functionp elmo-plugged-condition)
 971                   (funcall elmo-plugged-condition alist))
 972                  (t ;; independent
 973                   elmo-plugged)))
 974           ((not port) ;; server
 975            (catch 'plugged
 976              (while alist
 977                (when (string= server (caaar alist))
 978                  (if (nth 2 (car alist))
 979                      (throw 'plugged t)))
 980                (setq alist (cdr alist)))))
 981           (t
 982            (setq plugged-info (assoc (cons server port) alist))
 983            (if (not plugged-info)
 984                ;; add elmo-plugged-alist automatically
 985                (progn
 986                  (elmo-set-plugged elmo-plugged server port nil nil label-exp)
 987                  elmo-plugged)
 988              (if (and elmo-auto-change-plugged
 989                       (> elmo-auto-change-plugged 0)
 990                       (nth 3 plugged-info)  ;; time
 991                       (elmo-time-expire (nth 3 plugged-info)
 992                                         elmo-auto-change-plugged))
 993                  t
 994                (nth 2 plugged-info)))))))
 995
 996 (defun elmo-set-plugged (plugged &optional server port time
 997                                  alist label-exp add)
 998   (let ((alist (or alist elmo-plugged-alist))
 999         label plugged-info)
1000     (cond ((and (not port) (not server))
1001            (setq elmo-plugged plugged)
1002            ;; set plugged all element of elmo-plugged-alist.
1003            (while alist
1004              (setcdr (cdar alist) (list plugged time))
1005              (setq alist (cdr alist))))
1006           ((not port)
1007            ;; set plugged all port of server
1008            (while alist
1009              (when (string= server (caaar alist))
1010                (setcdr (cdar alist) (list plugged time)))
1011              (setq alist (cdr alist))))
1012           (t
1013            ;; set plugged one port of server
1014            (setq plugged-info (assoc (cons server port) alist))
1015            (setq label (if label-exp
1016                            (eval label-exp)
1017                          (nth 1 plugged-info)))
1018            (if plugged-info
1019                ;; if add is non-nil, don't reset plug state.
1020                (unless add
1021                  (setcdr plugged-info (list label plugged time)))
1022              (setq alist
1023                    (setq elmo-plugged-alist
1024                          (nconc elmo-plugged-alist
1025                                 (list
1026                                  (list (cons server port) label plugged time))))))))
1027     alist))
1028
1029 (defun elmo-delete-plugged (&optional server port alist)
1030   (let* ((alist (or alist elmo-plugged-alist))
1031          (alist2 alist))
1032     (cond ((and (not port) (not server))
1033            (setq alist nil))
1034           ((not port)
1035            ;; delete plugged all port of server
1036            (while alist2
1037              (when (string= server (caaar alist2))
1038                (setq alist (delete (car alist2) alist)))
1039              (setq alist2 (cdr alist2))))
1040           (t
1041            ;; delete plugged one port of server
1042            (setq alist
1043                  (delete (assoc (cons server port) alist) alist))))
1044     alist))
1045
1046 (defun elmo-disk-usage (path)
1047   "Get disk usage (bytes) in PATH."
1048   (let ((file-attr
1049          (condition-case () (file-attributes path) (error nil))))
1050     (if file-attr
1051         (if (nth 0 file-attr) ; directory
1052             (let ((files (condition-case ()
1053                              (directory-files path t "^[^\\.]")
1054                            (error nil)))
1055                   (result 0.0))
1056               ;; (result (nth 7 file-attr))) ... directory size
1057               (while files
1058                 (setq result (+ result (or (elmo-disk-usage (car files)) 0)))
1059                 (setq files (cdr files)))
1060               result)
1061           (float (nth 7 file-attr))))))
1062
1063 (defun elmo-get-last-accessed-time (path &optional dir)
1064   "Return the last accessed time of PATH."
1065   (let ((last-accessed (nth 4 (file-attributes (or (and dir
1066                                                         (expand-file-name
1067                                                          path dir))
1068                                                    path)))))
1069     (if last-accessed
1070         (setq last-accessed (+ (* (nth 0 last-accessed)
1071                                   (float 65536)) (nth 1 last-accessed)))
1072       0)))
1073
1074 (defun elmo-get-last-modification-time (path &optional dir)
1075   "Return the last accessed time of PATH."
1076   (let ((last-modified (nth 5 (file-attributes (or (and dir
1077                                                         (expand-file-name
1078                                                          path dir))
1079                                                    path)))))
1080     (setq last-modified (+ (* (nth 0 last-modified)
1081                               (float 65536)) (nth 1 last-modified)))))
1082
1083 (defun elmo-make-directory (path)
1084   "Create directory recursively."
1085   (let ((parent (directory-file-name (file-name-directory path))))
1086     (if (null (file-directory-p parent))
1087         (elmo-make-directory parent))
1088     (make-directory path)
1089     (if (string= path (expand-file-name elmo-msgdb-dir))
1090         (set-file-modes path (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700
1091
1092 (defun elmo-delete-directory (path &optional no-hierarchy)
1093   "Delete directory recursively."
1094   (let ((dirent (directory-files path))
1095         relpath abspath hierarchy)
1096     (while dirent
1097       (setq relpath (car dirent)
1098             dirent (cdr dirent)
1099             abspath (expand-file-name relpath path))
1100       (when (not (string-match "^\\.\\.?$" relpath))
1101         (if (eq (nth 0 (file-attributes abspath)) t)
1102             (if no-hierarchy
1103                 (setq hierarchy t)
1104               (elmo-delete-directory abspath no-hierarchy))
1105           (delete-file abspath))))
1106     (unless hierarchy
1107       (delete-directory path))))
1108
1109 (defun elmo-list-filter (l1 l2)
1110   "L1 is filter."
1111   (if (eq l1 t)
1112       ;; t means filter all.
1113       nil
1114     (if l1
1115         (elmo-delete-if (lambda (x) (not (memq x l1))) l2)
1116       ;; filter is nil
1117       l2)))
1118
1119 (defun elmo-folder-local-p (folder)
1120   "Return whether FOLDER is a local folder or not."
1121   (let ((spec (elmo-folder-get-spec folder)))
1122     (case (car spec)
1123       (filter (elmo-folder-local-p (nth 2 spec)))
1124       (pipe (elmo-folder-local-p (elmo-pipe-spec-dst spec)))
1125       (t (memq (car spec)
1126                '(localdir localnews archive maildir internal cache))))))
1127
1128 (defun elmo-folder-writable-p (folder)
1129   (let ((type (elmo-folder-get-type folder)))
1130     (memq type '(imap4 localdir archive))))
1131
1132 (defun elmo-multi-get-intlist-list (numlist &optional as-is)
1133   (let ((numbers (sort numlist '<))
1134         (cur-number 0)
1135         one-list int-list-list)
1136     (while numbers
1137       (setq cur-number (+ cur-number 1))
1138       (setq one-list nil)
1139       (while (and numbers
1140                   (eq 0
1141                       (/ (- (car numbers)
1142                             (* elmo-multi-divide-number cur-number))
1143                          elmo-multi-divide-number)))
1144         (setq one-list (nconc
1145                         one-list
1146                         (list
1147                          (if as-is
1148                              (car numbers)
1149                            (% (car numbers)
1150                               (* elmo-multi-divide-number cur-number))))))
1151         (setq numbers (cdr numbers)))
1152       (setq int-list-list (nconc int-list-list (list one-list))))
1153     int-list-list))
1154
1155 (defsubst elmo-list-delete-if-smaller (list number)
1156   (let ((ret-val (copy-sequence list)))
1157     (while list
1158       (if (< (car list) number)
1159           (setq ret-val (delq (car list) ret-val)))
1160       (setq list (cdr list)))
1161     ret-val))
1162
1163 (defun elmo-list-diff (list1 list2 &optional mes)
1164   (if mes
1165       (message mes))
1166   (let ((clist1 (copy-sequence list1))
1167         (clist2 (copy-sequence list2)))
1168     (while list2
1169       (setq clist1 (delq (car list2) clist1))
1170       (setq list2 (cdr list2)))
1171     (while list1
1172       (setq clist2 (delq (car list1) clist2))
1173       (setq list1 (cdr list1)))
1174     (if mes
1175         (message (concat mes "done.")))
1176     (list clist1 clist2)))
1177
1178 (defun elmo-list-bigger-diff (list1 list2 &optional mes)
1179   "Returns a list (- +). + is bigger than max of LIST1, in LIST2."
1180   (if (null list2)
1181       (cons list1  nil)
1182     (let* ((l1 list1)
1183            (l2 list2)
1184            (max-of-l2 (or (nth (max 0 (1- (length l2))) l2) 0))
1185            diff1 num i percent
1186            )
1187       (setq i 0)
1188       (setq num (+ (length l1)))
1189       (while l1
1190         (if (memq (car l1) l2)
1191             (if (eq (car l1) (car l2))
1192                 (setq l2 (cdr l2))
1193               (delq (car l1) l2))
1194           (if (> (car l1) max-of-l2)
1195               (setq diff1 (nconc diff1 (list (car l1))))))
1196         (if mes
1197             (progn
1198               (setq i (+ i 1))
1199               (setq percent (/ (* i 100) num))
1200               (if (eq (% percent 5) 0)
1201                   (elmo-display-progress
1202                    'elmo-list-bigger-diff "%s%d%%" percent mes))))
1203         (setq l1 (cdr l1)))
1204       (cons diff1 (list l2)))))
1205
1206 (defun elmo-multi-list-bigger-diff (list1 list2 &optional mes)
1207   (let ((list1-list (elmo-multi-get-intlist-list list1 t))
1208         (list2-list (elmo-multi-get-intlist-list list2 t))
1209         result
1210         dels news)
1211     (while (or list1-list list2-list)
1212       (setq result (elmo-list-bigger-diff (car list1-list) (car list2-list)
1213                                           mes))
1214       (setq dels (append dels (car result)))
1215       (setq news (append news (cadr result)))
1216       (setq list1-list (cdr list1-list))
1217       (setq list2-list (cdr list2-list)))
1218     (cons dels (list news))))
1219
1220 (defvar elmo-imap4-name-space-regexp-list nil)
1221 (defun elmo-imap4-identical-name-space-p (fld1 fld2)
1222   ;; only on UW?
1223   (if (or (eq (string-to-char fld1) ?#)
1224           (eq (string-to-char fld2) ?#))
1225       (string= (car (split-string fld1 "/"))
1226                (car (split-string fld2 "/")))
1227     t))
1228
1229 (defun elmo-folder-identical-system-p (folder1 folder2)
1230   "FOLDER1 and FOLDER2 should be real folder (not virtual)."
1231   (cond ((eq (elmo-folder-get-type folder1) 'imap4)
1232          (let ((spec1 (elmo-folder-get-spec folder1))
1233                (spec2 (elmo-folder-get-spec folder2)))
1234            (and
1235 ;;; No use.
1236 ;;;         (elmo-imap4-identical-name-space-p
1237 ;;;          (nth 1 spec1) (nth 1 spec2))
1238             (string= (elmo-imap4-spec-hostname spec1)
1239                      (elmo-imap4-spec-hostname spec2)) ; hostname
1240             (string= (elmo-imap4-spec-username spec1)
1241                      (elmo-imap4-spec-username spec2))))) ; username
1242         (t
1243          (elmo-folder-direct-copy-p folder1 folder2))))
1244
1245 (defun elmo-folder-get-store-type (folder)
1246   (let ((spec (elmo-folder-get-spec folder)))
1247     (case (car spec)
1248       (filter (elmo-folder-get-store-type (nth 2 spec)))
1249       (pipe (elmo-folder-get-store-type (elmo-pipe-spec-dst spec)))
1250       (multi (elmo-folder-get-store-type (nth 1 spec)))
1251       (t (car spec)))))
1252
1253 (defconst elmo-folder-direct-copy-alist
1254   '((localdir  . (localdir localnews archive))
1255     (maildir   . (maildir  localdir localnews archive))
1256     (localnews . (localdir localnews archive))
1257     (archive   . (localdir localnews archive))
1258     (cache     . (localdir localnews archive))))
1259
1260 (defun elmo-folder-direct-copy-p (src-folder dst-folder)
1261   (let ((src-type (elmo-folder-get-store-type src-folder))
1262         (dst-type (elmo-folder-get-store-type dst-folder))
1263         dst-copy-type)
1264     (and (setq dst-copy-type
1265                (cdr (assq src-type elmo-folder-direct-copy-alist)))
1266          (memq dst-type dst-copy-type))))
1267
1268 (defmacro elmo-filter-type (filter)
1269   (` (aref (, filter) 0)))
1270
1271 (defmacro elmo-filter-key (filter)
1272   (` (aref (, filter) 1)))
1273
1274 (defmacro elmo-filter-value (filter)
1275   (` (aref (, filter) 2)))
1276
1277 (defsubst elmo-buffer-field-primitive-condition-match (condition
1278                                                        number
1279                                                        number-list)
1280   (let (result)
1281     (goto-char (point-min))
1282     (cond
1283      ((string= (elmo-filter-key condition) "last")
1284       (setq result (<= (length (memq number number-list))
1285                        (string-to-int (elmo-filter-value condition)))))
1286      ((string= (elmo-filter-key condition) "first")
1287       (setq result (< (- (length number-list)
1288                          (length (memq number number-list)))
1289                       (string-to-int (elmo-filter-value condition)))))
1290      ((string= (elmo-filter-key condition) "since")
1291       (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
1292         (setq result
1293               (string<
1294                (timezone-make-sortable-date (aref date 0)
1295                                             (aref date 1)
1296                                             (aref date 2)
1297                                             (timezone-make-time-string
1298                                              (aref date 3)
1299                                              (aref date 4)
1300                                              (aref date 5)))
1301                (timezone-make-date-sortable (std11-field-body "date"))))))
1302      ((string= (elmo-filter-key condition) "before")
1303       (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
1304         (setq result
1305               (string<
1306                (timezone-make-date-sortable (std11-field-body "date"))
1307                (timezone-make-sortable-date (aref date 0)
1308                                             (aref date 1)
1309                                             (aref date 2)
1310                                             (timezone-make-time-string
1311                                              (aref date 3)
1312                                              (aref date 4)
1313                                              (aref date 5)))))))
1314      ((string= (elmo-filter-key condition) "body")
1315       (and (re-search-forward "^$" nil t)          ; goto body
1316            (setq result (search-forward (elmo-filter-value condition)
1317                                         nil t))))
1318      (t
1319       (let ((fval (std11-field-body (elmo-filter-key condition))))
1320         (if (eq (length fval) 0) (setq fval nil))
1321         (if fval (setq fval (eword-decode-string fval)))
1322         (setq result (and fval (string-match
1323                                 (elmo-filter-value condition) fval))))))
1324     (if (eq (elmo-filter-type condition) 'unmatch)
1325         (setq result (not result)))
1326     result))
1327
1328 (defun elmo-condition-find-key-internal (condition key)
1329   (cond
1330    ((vectorp condition)
1331     (if (string= (elmo-filter-key condition) key)
1332         (throw 'found t)))
1333    ((or (eq (car condition) 'and)
1334         (eq (car condition) 'or))
1335     (elmo-condition-find-key-internal (nth 1 condition) key)
1336     (elmo-condition-find-key-internal (nth 2 condition) key))))
1337
1338 (defun elmo-condition-find-key (condition key)
1339   (catch 'found
1340     (elmo-condition-find-key-internal condition key)))
1341
1342 (defun elmo-buffer-field-condition-match (condition number number-list)
1343   (cond
1344    ((vectorp condition)
1345     (elmo-buffer-field-primitive-condition-match
1346      condition number number-list))
1347    ((eq (car condition) 'and)
1348     (and (elmo-buffer-field-condition-match
1349           (nth 1 condition) number number-list)
1350          (elmo-buffer-field-condition-match
1351           (nth 2 condition) number number-list)))
1352    ((eq (car condition) 'or)
1353     (or (elmo-buffer-field-condition-match
1354          (nth 1 condition) number number-list)
1355         (elmo-buffer-field-condition-match
1356          (nth 2 condition) number number-list)))))
1357
1358 (defsubst elmo-file-field-condition-match (file condition number number-list)
1359   (elmo-set-work-buf
1360    (as-binary-input-file (insert-file-contents file))
1361    (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1362    ;; Should consider charset?
1363    (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
1364    (elmo-buffer-field-condition-match condition number number-list)))
1365
1366 (defmacro elmo-get-hash-val (string hashtable)
1367   (let ((sym (list 'intern-soft string hashtable)))
1368     (list 'if (list 'boundp sym)
1369        (list 'symbol-value sym))))
1370
1371 (defmacro elmo-set-hash-val (string value hashtable)
1372   (list 'set (list 'intern string hashtable) value))
1373
1374 (defmacro elmo-clear-hash-val (string hashtable)
1375   (static-if (fboundp 'unintern)
1376       (list 'unintern string hashtable)
1377     (list 'makunbound (list 'intern string hashtable))))
1378
1379 (defmacro elmo-unintern (string)
1380   "`unintern' symbol named STRING,  When can use `unintern'.
1381 Emacs 19.28 or earlier does not have `unintern'."
1382   (static-if (fboundp 'unintern)
1383       (list 'unintern string)))
1384
1385 ;; Make a hash table (default and minimum size is 1024).
1386 (defun elmo-make-hash (&optional hashsize)
1387   (make-vector
1388    (if hashsize (max (min (elmo-create-hash-size hashsize)
1389                           elmo-hash-maximum-size) 1024) 1024) 0))
1390
1391 (defsubst elmo-mime-string (string)
1392   "Normalize MIME encoded STRING."
1393     (and string
1394          (let (str)
1395            (elmo-set-work-buf
1396             (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1397             (setq str (eword-decode-string
1398                        (decode-mime-charset-string string elmo-mime-charset)))
1399             (setq str (encode-mime-charset-string str elmo-mime-charset))
1400             (elmo-set-buffer-multibyte nil)
1401             str))))
1402
1403 (defsubst elmo-collect-field (beg end downcase-field-name)
1404   (save-excursion
1405     (save-restriction
1406       (narrow-to-region beg end)
1407       (goto-char (point-min))
1408       (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1409             dest name body)
1410         (while (re-search-forward regexp nil t)
1411           (setq name (buffer-substring-no-properties
1412                       (match-beginning 1)(1- (match-end 1))))
1413           (if downcase-field-name
1414               (setq name (downcase name)))
1415           (setq body (buffer-substring-no-properties
1416                       (match-end 0) (std11-field-end)))
1417           (or (assoc name dest)
1418               (setq dest (cons (cons name body) dest))))
1419         dest))))
1420
1421 (defsubst elmo-collect-field-from-string (string downcase-field-name)
1422   (with-temp-buffer
1423     (insert string)
1424     (goto-char (point-min))
1425     (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1426           dest name body)
1427       (while (re-search-forward regexp nil t)
1428         (setq name (buffer-substring-no-properties
1429                     (match-beginning 1)(1- (match-end 1))))
1430         (if downcase-field-name
1431             (setq name (downcase name)))
1432         (setq body (buffer-substring-no-properties
1433                     (match-end 0) (std11-field-end)))
1434         (or (assoc name dest)
1435             (setq dest (cons (cons name body) dest))))
1436       dest)))
1437
1438 (defun elmo-create-hash-size (min)
1439   (let ((i 1))
1440     (while (< i min)
1441       (setq i (* 2 i)))
1442     i))
1443
1444 (defun elmo-safe-filename (folder)
1445   (elmo-replace-in-string
1446    (elmo-replace-in-string
1447     (elmo-replace-in-string folder "/" " ")
1448     ":" "__")
1449    "|" "_or_"))
1450
1451 (defvar elmo-msgid-replace-chars nil)
1452
1453 (defsubst elmo-replace-msgid-as-filename (msgid)
1454   "Replace Message-ID string (MSGID) as filename."
1455   (setq msgid (elmo-replace-in-string msgid " " "  "))
1456   (if (null elmo-msgid-replace-chars)
1457       (setq elmo-msgid-replace-chars
1458             (regexp-quote (mapconcat
1459                            'car elmo-msgid-replace-string-alist ""))))
1460   (while (string-match (concat "[" elmo-msgid-replace-chars "]")
1461                        msgid)
1462     (setq msgid (concat
1463                  (substring msgid 0 (match-beginning 0))
1464                  (cdr (assoc
1465                        (substring msgid
1466                                   (match-beginning 0) (match-end 0))
1467                        elmo-msgid-replace-string-alist))
1468                  (substring msgid (match-end 0)))))
1469   msgid)
1470
1471 (defsubst elmo-recover-msgid-from-filename (filename)
1472   "Recover Message-ID from FILENAME."
1473   (let (tmp result)
1474     (while (string-match " " filename)
1475       (setq tmp (substring filename
1476                            (match-beginning 0)
1477                            (+ (match-end 0) 1)))
1478       (if (string= tmp "  ")
1479           (setq tmp " ")
1480         (setq tmp (car (rassoc tmp
1481                                elmo-msgid-replace-string-alist))))
1482       (setq result
1483             (concat result
1484                     (substring filename 0 (match-beginning 0))
1485                     tmp))
1486       (setq filename (substring filename (+ (match-end 0) 1))))
1487     (concat result filename)))
1488
1489 (defsubst elmo-copy-file (src dst)
1490   (condition-case err
1491       (elmo-add-name-to-file src dst t)
1492     (error (copy-file src dst t))))
1493
1494 (defsubst elmo-buffer-exists-p (buffer)
1495   (if (bufferp buffer)
1496       (buffer-live-p buffer)
1497     (get-buffer buffer)))
1498
1499 (defsubst elmo-kill-buffer (buffer)
1500   (when (elmo-buffer-exists-p buffer)
1501     (kill-buffer buffer)))
1502
1503 (defun elmo-delete-if (pred lst)
1504   "Return new list contain items which don't satisfy PRED in LST."
1505   (let (result)
1506     (while lst
1507       (unless (funcall pred (car lst))
1508         (setq result (nconc result (list (car lst)))))
1509       (setq lst (cdr lst)))
1510     result))
1511
1512 (defun elmo-list-delete (list1 list2)
1513   "Delete by side effect any occurrences equal to elements of LIST1 from LIST2.
1514 Return the modified LIST2.  Deletion is done with `delete'.
1515 Write `(setq foo (elmo-list-delete bar foo))' to be sure of changing
1516 the value of `foo'."
1517   (while list1
1518     (setq list2 (delete (car list1) list2))
1519     (setq list1 (cdr list1)))
1520   list2)
1521
1522 (defun elmo-list-member (list1 list2)
1523   "If any element of LIST1 is member of LIST2, return t."
1524   (catch 'done
1525     (while list1
1526       (if (member (car list1) list2)
1527           (throw 'done t))
1528       (setq list1 (cdr list1)))))
1529
1530 (defun elmo-count-matches (regexp beg end)
1531   (let ((count 0))
1532     (save-excursion
1533       (goto-char beg)
1534       (while (re-search-forward regexp end t)
1535         (setq count (1+ count)))
1536       count)))
1537
1538 (if (fboundp 'display-error)
1539     (defalias 'elmo-display-error 'display-error)
1540   (defun elmo-display-error (error-object stream)
1541     "A tiny function to display ERROR-OBJECT to the STREAM."
1542     (let ((first t)
1543           (errobj error-object)
1544           err-mes)
1545       (while errobj
1546         (setq err-mes (concat err-mes (format
1547                                        (if (stringp (car errobj))
1548                                            "%s"
1549                                          (if (boundp 'nemacs-version)
1550                                              "%s"
1551                                            "%S")) (car errobj))))
1552         (setq errobj (cdr errobj))
1553         (if errobj (setq err-mes (concat err-mes (if first ": " ", "))))
1554         (setq first nil))
1555       (princ err-mes stream))))
1556
1557 (if (fboundp 'define-error)
1558     (defalias 'elmo-define-error 'define-error)
1559   (defun elmo-define-error (error doc &optional parents)
1560     (or parents
1561         (setq parents 'error))
1562     (let ((conds (get parents 'error-conditions)))
1563       (or conds
1564           (error "Not an error symbol: %s" error))
1565       (setplist error
1566                 (list 'error-message doc
1567                       'error-conditions (cons error conds))))))
1568
1569 (cond ((fboundp 'progress-feedback-with-label)
1570        (defalias 'elmo-display-progress 'progress-feedback-with-label))
1571       ((fboundp 'lprogress-display)
1572        (defalias 'elmo-display-progress 'lprogress-display))
1573       (t
1574        (defun elmo-display-progress (label format &optional value &rest args)
1575          "Print a progress message."
1576          (if (and (null format) (null args))
1577              (message nil)
1578            (apply (function message) (concat format " %d%%")
1579                   (nconc args (list value)))))))
1580
1581 (defun elmo-time-expire (before-time diff-time)
1582   (let* ((current (current-time))
1583          (rest (when (< (nth 1 current) (nth 1 before-time))
1584                  (expt 2 16)))
1585          diff)
1586     (setq diff
1587           (list (- (+ (car current) (if rest -1 0)) (car before-time))
1588                 (- (+ (or rest 0) (nth 1 current)) (nth 1 before-time))))
1589     (and (eq (car diff) 0)
1590          (< diff-time (nth 1 diff)))))
1591
1592 (if (fboundp 'std11-fetch-field)
1593     (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
1594   (defalias 'elmo-field-body 'std11-field-body))
1595
1596 (defmacro elmo-string (string)
1597   "STRING without text property."
1598   (` (let ((obj (copy-sequence (, string))))
1599        (set-text-properties 0 (length obj) nil obj)
1600        obj)))
1601
1602 (defun elmo-flatten (list-of-list)
1603   "Flatten LIST-OF-LIST."
1604   (unless (null list-of-list)
1605     (append (if (and (car list-of-list)
1606                      (listp (car list-of-list)))
1607                 (car list-of-list)
1608               (list (car list-of-list)))
1609             (elmo-flatten (cdr list-of-list)))))
1610
1611 (defun elmo-y-or-n-p (prompt &optional auto default)
1612   "Same as `y-or-n-p'.
1613 But if optional argument AUTO is non-nil, DEFAULT is returned."
1614   (if auto
1615       default
1616     (y-or-n-p prompt)))
1617
1618 (defun elmo-string-member (string slist)
1619   "Return t if STRING is a member of the SLIST."
1620   (catch 'found
1621     (while slist
1622       (if (and (stringp (car slist))
1623                (string= string (car slist)))
1624           (throw 'found t))
1625       (setq slist (cdr slist)))))
1626
1627 (defun elmo-string-match-member (str list &optional case-ignore)
1628   (let ((case-fold-search case-ignore))
1629     (catch 'member
1630       (while list
1631         (if (string-match (car list) str)
1632             (throw 'member (car list)))
1633         (setq list (cdr list))))))
1634
1635 (defun elmo-string-matched-member (str list &optional case-ignore)
1636   (let ((case-fold-search case-ignore))
1637     (catch 'member
1638       (while list
1639         (if (string-match str (car list))
1640             (throw 'member (car list)))
1641         (setq list (cdr list))))))
1642
1643 (defsubst elmo-string-delete-match (string pos)
1644   (concat (substring string
1645                      0 (match-beginning pos))
1646           (substring string
1647                      (match-end pos)
1648                      (length string))))
1649
1650 (defun elmo-string-match-assoc (key alist &optional case-ignore)
1651   (let ((case-fold-search case-ignore)
1652         a)
1653     (catch 'loop
1654       (while alist
1655         (setq a (car alist))
1656         (if (and (consp a)
1657                  (stringp (car a))
1658                  (string-match key (car a)))
1659             (throw 'loop a))
1660         (setq alist (cdr alist))))))
1661
1662 (defun elmo-string-matched-assoc (key alist &optional case-ignore)
1663   (let ((case-fold-search case-ignore)
1664         a)
1665     (catch 'loop
1666       (while alist
1667         (setq a (car alist))
1668         (if (and (consp a)
1669                  (stringp (car a))
1670                  (string-match (car a) key))
1671             (throw 'loop a))
1672         (setq alist (cdr alist))))))
1673
1674 (defun elmo-string-assoc (key alist)
1675   (let (a)
1676     (catch 'loop
1677       (while alist
1678         (setq a (car alist))
1679         (if (and (consp a)
1680                  (stringp (car a))
1681                  (string= key (car a)))
1682             (throw 'loop a))
1683         (setq alist (cdr alist))))))
1684
1685 (defun elmo-string-rassoc (key alist)
1686   (let (a)
1687     (catch 'loop
1688       (while alist
1689         (setq a (car alist))
1690         (if (and (consp a)
1691                  (stringp (cdr a))
1692                  (string= key (cdr a)))
1693             (throw 'loop a))
1694         (setq alist (cdr alist))))))
1695
1696 (defun elmo-string-rassoc-all (key alist)
1697   (let (matches)
1698     (while alist
1699       (if (string= key (cdr (car alist)))
1700           (setq matches
1701                 (cons (car alist)
1702                       matches)))
1703       (setq alist (cdr alist)))
1704     matches))
1705
1706 ;;; Number set defined by OKAZAKI Tetsurou <okazaki@be.to>
1707 ;;
1708 ;; number          ::= [0-9]+
1709 ;; beg             ::= number
1710 ;; end             ::= number
1711 ;; number-range    ::= "(" beg " . " end ")"      ;; cons cell
1712 ;; number-set-elem ::= number / number-range
1713 ;; number-set      ::= "(" *number-set-elem ")"   ;; list
1714
1715 (defun elmo-number-set-member (number number-set)
1716   "Return non-nil if NUMBER is an element of NUMBER-SET.
1717 The value is actually the tail of NUMBER-RANGE whose car contains NUMBER."
1718   (or (memq number number-set)
1719       (let (found)
1720         (while (and number-set (not found))
1721           (if (and (consp (car number-set))
1722                    (and (<= (car (car number-set)) number)
1723                         (<= number (cdr (car number-set)))))
1724               (setq found t)
1725             (setq number-set (cdr number-set))))
1726         number-set)))
1727
1728 (defun elmo-number-set-append-list (number-set list)
1729   "Append LIST of numbers to the NUMBER-SET.
1730 NUMBER-SET is altered."
1731   (let ((appended number-set))
1732     (while list
1733       (setq appended (elmo-number-set-append appended (car list)))
1734       (setq list (cdr list)))
1735     appended))
1736
1737 (defun elmo-number-set-append (number-set number)
1738   "Append NUMBER to the NUMBER-SET.
1739 NUMBER-SET is altered."
1740   (let ((number-set-1 number-set)
1741         found elem)
1742     (while (and number-set (not found))
1743       (setq elem (car number-set))
1744       (cond
1745        ((and (consp elem)
1746              (eq (+ 1 (cdr elem)) number))
1747         (setcdr elem number)
1748         (setq found t))
1749        ((and (integerp elem)
1750              (eq (+ 1 elem) number))
1751         (setcar number-set (cons elem number))
1752         (setq found t))
1753        ((or (and (integerp elem) (eq elem number))
1754             (and (consp elem)
1755                  (<= (car elem) number)
1756                  (<= number (cdr elem))))
1757         (setq found t)))
1758       (setq number-set (cdr number-set)))
1759     (if (not found)
1760         (setq number-set-1 (nconc number-set-1 (list number))))
1761     number-set-1))
1762
1763 (require 'product)
1764 (product-provide (provide 'elmo-util) (require 'elmo-version))
1765
1766 ;;; elmo-util.el ends here