elmo/elmo-util.el

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