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