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