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