elmo/elmo-util.el

   1 ;;; elmo-util.el -- Utilities for Elmo.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4
   5 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   6 ;; Keywords: mail, net news
   7
   8 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24 ;;
  25
  26 ;;; Commentary:
  27 ;;
  28
  29 ;;; Code:
  30 ;;
  31
  32 (require 'elmo-vars)
  33 (require 'elmo-date)
  34 (eval-when-compile (require 'cl))
  35 (require 'std11)
  36 (require 'eword-decode)
  37 (require 'utf7)
  38
  39 (defmacro elmo-set-buffer-multibyte (flag)
  40   "Set the multibyte flag of the current buffer to FLAG."
  41   (cond ((boundp 'MULE)
  42          (list 'setq 'mc-flag flag))
  43         ((featurep 'xemacs)
  44          flag)
  45         ((and (boundp 'emacs-major-version) (>= emacs-major-version 20))
  46          (list 'set-buffer-multibyte flag))
  47         (t
  48          flag)))
  49
  50 (defvar elmo-work-buf-name " *elmo work*")
  51 (defvar elmo-temp-buf-name " *elmo temp*")
  52
  53 (or (boundp 'default-enable-multibyte-characters)
  54     (defvar default-enable-multibyte-characters (featurep 'mule)
  55       "The mock variable except for Emacs 20."))
  56
  57 (defun elmo-base64-encode-string (string &optional no-line-break))
  58 (defun elmo-base64-decode-string (string))
  59
  60 ;; base64 encoding/decoding
  61 (require 'mel)
  62 (fset 'elmo-base64-encode-string
  63       (mel-find-function 'mime-encode-string "base64"))
  64 (fset 'elmo-base64-decode-string
  65       (mel-find-function 'mime-decode-string "base64"))
  66
  67 ;; Any Emacsen may have add-name-to-file(), because loadup.el requires it. :-p
  68 ;; Check make-symbolic-link() instead.  -- 981002 by Fuji
  69 (if (fboundp 'make-symbolic-link)  ;; xxx
  70     (defalias 'elmo-add-name-to-file 'add-name-to-file)
  71   (defun elmo-add-name-to-file
  72     (filename newname &optional ok-if-already-exists)
  73     (copy-file filename newname ok-if-already-exists t)))
  74
  75 (defsubst elmo-call-func (folder func-name &rest args)
  76   (let* ((spec (if (stringp folder)
  77                    (elmo-folder-get-spec folder)
  78                  folder))
  79          (type (symbol-name (car spec)))
  80          (backend-str (concat "elmo-" type))
  81          (backend-sym (intern backend-str)))
  82     (unless (featurep backend-sym)
  83       (require backend-sym))
  84     (apply (intern (format "%s-%s" backend-str func-name))
  85            spec
  86            args)))
  87
  88 ;; Nemacs's `read' is different.
  89 (static-if (fboundp 'nemacs-version)
  90     (defun elmo-read (obj)
  91       (prog1 (read obj)
  92         (if (bufferp obj)
  93             (or (bobp) (forward-char -1)))))
  94   (defalias 'elmo-read 'read))
  95
  96 (defmacro elmo-set-work-buf (&rest body)
  97   "Execute BODY on work buffer.  Work buffer remains."
  98   (` (save-excursion
  99        (set-buffer (get-buffer-create elmo-work-buf-name))
 100        (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 101        (erase-buffer)
 102        (,@ body))))
 103
 104 (defmacro elmo-match-substring (pos string from)
 105   "Substring of POSth matched string of STRING."
 106   (` (substring (, string)
 107                 (+ (match-beginning (, pos)) (, from))
 108                 (match-end (, pos)))))
 109
 110 (defmacro elmo-match-string (pos string)
 111   "Substring POSth matched STRING."
 112   (` (substring (, string) (match-beginning (, pos)) (match-end (, pos)))))
 113
 114 (defmacro elmo-match-buffer (pos)
 115   "Substring POSth matched from the current buffer."
 116   (` (buffer-substring-no-properties
 117       (match-beginning (, pos)) (match-end (, pos)))))
 118
 119 (defmacro elmo-bind-directory (dir &rest body)
 120   "Set current directory DIR and execute BODY."
 121   (` (let ((default-directory (file-name-as-directory (, dir))))
 122        (,@ body))))
 123
 124 (defmacro elmo-folder-get-type (folder)
 125   "Get type of FOLDER."
 126   (` (and (stringp (, folder))
 127           (cdr (assoc (string-to-char (, folder)) elmo-spec-alist)))))
 128
 129 (defun elmo-object-load (filename &optional mime-charset no-err)
 130   "Load OBJECT from the file specified by FILENAME.
 131 File content is decoded with MIME-CHARSET."
 132     (if (not (file-readable-p filename))
 133         nil
 134       (elmo-set-work-buf
 135        (as-binary-input-file
 136         (insert-file-contents filename))
 137        (when mime-charset
 138          (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 139          (decode-mime-charset-region (point-min) (point-max) mime-charset))
 140        (condition-case nil
 141            (read (current-buffer))
 142          (error (unless no-err
 143                   (message "Warning: Loading object from %s failed."
 144                            filename)
 145                   (elmo-object-save filename nil))
 146                 nil)))))
 147
 148 (defsubst elmo-save-buffer (filename &optional mime-charset)
 149   "Save current buffer to the file specified by FILENAME.
 150 Directory of the file is created if it doesn't exist.
 151 File content is encoded with MIME-CHARSET."
 152   (let ((dir (directory-file-name (file-name-directory filename))))
 153     (if (file-directory-p dir)
 154         () ; ok.
 155       (unless (file-exists-p dir)
 156         (elmo-make-directory dir)))
 157     (if (file-writable-p filename)
 158         (progn
 159           (when mime-charset
 160 ;;;         (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 161             (encode-mime-charset-region (point-min) (point-max) mime-charset))
 162           (as-binary-output-file
 163            (write-region (point-min) (point-max) filename nil 'no-msg)))
 164       (message (format "%s is not writable." filename)))))
 165
 166 (defun elmo-object-save (filename object &optional mime-charset)
 167   "Save OBJECT to the file specified by FILENAME.
 168 Directory of the file is created if it doesn't exist.
 169 File content is encoded with MIME-CHARSET."
 170   (elmo-set-work-buf
 171    (prin1 object (current-buffer))
 172 ;;;(princ "\n" (current-buffer))
 173    (elmo-save-buffer filename mime-charset)))
 174
 175 (defsubst elmo-imap4-decode-folder-string (string)
 176   (if elmo-imap4-use-modified-utf7
 177       (utf7-decode-string string 'imap)
 178     string))
 179
 180 (defsubst elmo-imap4-encode-folder-string (string)
 181   (if elmo-imap4-use-modified-utf7
 182       (utf7-encode-string string 'imap)
 183     string))
 184
 185 (defun elmo-get-network-stream-type (stream-type stream-type-alist)
 186   (catch 'found
 187     (while stream-type-alist
 188       (if (eq (nth 1 (car stream-type-alist)) stream-type)
 189           (throw 'found (car stream-type-alist)))
 190       (setq stream-type-alist (cdr stream-type-alist)))))
 191
 192 (defun elmo-network-get-spec (folder server port stream-type stream-type-alist)
 193   (setq stream-type (elmo-get-network-stream-type
 194                      stream-type stream-type-alist))
 195   (when (string-match "\\(@[^@:/!]+\\)?\\(:[0-9]+\\)?\\(!.*\\)?$" folder)
 196     (if (match-beginning 1)
 197         (setq server (elmo-match-substring 1 folder 1)))
 198     (if (match-beginning 2)
 199         (setq port (string-to-int (elmo-match-substring 2 folder 1))))
 200     (if (match-beginning 3)
 201         (setq stream-type (assoc (elmo-match-string 3 folder)
 202                                  stream-type-alist)))
 203     (setq folder (substring folder 0 (match-beginning 0))))
 204   (cons folder (list server port stream-type)))
 205
 206 (defun elmo-imap4-get-spec (folder)
 207   (let ((default-user        elmo-default-imap4-user)
 208         (default-server      elmo-default-imap4-server)
 209         (default-port        elmo-default-imap4-port)
 210         (default-stream-type elmo-default-imap4-stream-type)
 211         (stream-type-alist elmo-network-stream-type-alist)
 212         spec mailbox user auth)
 213     (when (string-match "\\(.*\\)@\\(.*\\)" default-server)
 214       ;; case: default-imap4-server is specified like
 215       ;; "hoge%imap.server@gateway".
 216       (setq default-user (elmo-match-string 1 default-server))
 217       (setq default-server (elmo-match-string 2 default-server)))
 218     (if elmo-imap4-stream-type-alist
 219         (setq stream-type-alist
 220               (append elmo-imap4-stream-type-alist stream-type-alist)))
 221     (setq spec (elmo-network-get-spec
 222                 folder default-server default-port default-stream-type
 223                 stream-type-alist))
 224     (setq folder (car spec))
 225     (when (string-match
 226            "^\\(%\\)\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?"
 227            folder)
 228       (progn
 229         (setq mailbox (if (match-beginning 2)
 230                           (elmo-match-string 2 folder)
 231                         elmo-default-imap4-mailbox))
 232         (setq user (if (match-beginning 3)
 233                        (elmo-match-substring 3 folder 1)
 234                      default-user))
 235         (setq auth (if (match-beginning 4)
 236                        (intern (elmo-match-substring 4 folder 1))
 237                      elmo-default-imap4-authenticate-type))
 238         (append (list 'imap4
 239                       (elmo-imap4-encode-folder-string mailbox)
 240                       user auth)
 241                 (cdr spec))))))
 242
 243 (defsubst elmo-imap4-spec-mailbox (spec)
 244   (nth 1 spec))
 245
 246 (defsubst elmo-imap4-spec-username (spec)
 247   (nth 2 spec))
 248
 249 (defsubst elmo-imap4-spec-auth (spec)
 250   (nth 3 spec))
 251
 252 (defsubst elmo-imap4-spec-hostname (spec)
 253   (nth 4 spec))
 254
 255 (defsubst elmo-imap4-spec-port (spec)
 256   (nth 5 spec))
 257
 258 (defsubst elmo-imap4-spec-stream-type (spec)
 259   (nth 6 spec))
 260
 261 (defalias 'elmo-imap4-spec-folder 'elmo-imap4-spec-mailbox)
 262 (make-obsolete 'elmo-imap4-spec-folder 'elmo-imap4-spec-mailbox)
 263
 264 (defsubst elmo-imap4-connection-get-process (conn)
 265   (nth 1 conn))
 266
 267 (defsubst elmo-imap4-connection-get-buffer (conn)
 268   (nth 0 conn))
 269
 270 (defsubst elmo-imap4-connection-get-cwf (conn)
 271   (nth 2 conn))
 272
 273 (defun elmo-nntp-get-spec (folder)
 274   (let ((stream-type-alist elmo-network-stream-type-alist)
 275         spec group user)
 276     (if elmo-nntp-stream-type-alist
 277         (setq stream-type-alist
 278               (append elmo-nntp-stream-type-alist stream-type-alist)))
 279     (setq spec (elmo-network-get-spec folder
 280                                       elmo-default-nntp-server
 281                                       elmo-default-nntp-port
 282                                       elmo-default-nntp-stream-type
 283                                       stream-type-alist))
 284     (setq folder (car spec))
 285     (when (string-match
 286            "^\\(-\\)\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?"
 287            folder)
 288       (setq group
 289             (if (match-beginning 2)
 290                 (elmo-match-string 2 folder)))
 291       (setq user
 292             (if (match-beginning 3)
 293                 (elmo-match-substring 3 folder 1)
 294               elmo-default-nntp-user))
 295       (append (list 'nntp group user)
 296               (cdr spec)))))
 297
 298 (defsubst elmo-nntp-spec-group (spec)
 299   (nth 1 spec))
 300
 301 (defsubst elmo-nntp-spec-username (spec)
 302   (nth 2 spec))
 303
 304 ;; future use?
 305 ;; (defsubst elmo-nntp-spec-auth (spec))
 306
 307 (defsubst elmo-nntp-spec-hostname (spec)
 308   (nth 3 spec))
 309
 310 (defsubst elmo-nntp-spec-port (spec)
 311   (nth 4 spec))
 312
 313 (defsubst elmo-nntp-spec-stream-type (spec)
 314   (nth 5 spec))
 315
 316 (defun elmo-localdir-get-spec (folder)
 317   (let (fld-name path)
 318     (when (string-match
 319            "^\\(\\+\\)\\(.*\\)$"
 320            folder)
 321       (if (eq (length (setq fld-name
 322                             (elmo-match-string 2 folder))) 0)
 323           (setq fld-name "")
 324         )
 325       (if (file-name-absolute-p fld-name)
 326           (setq path (expand-file-name fld-name))
 327 ;;;     (setq path (expand-file-name fld-name
 328 ;;;                                  elmo-localdir-folder-path))
 329         (setq path fld-name))
 330       (list (if (elmo-folder-maildir-p folder)
 331                 'maildir
 332               'localdir) path))))
 333
 334 (defun elmo-maildir-get-spec (folder)
 335   (let (fld-name path)
 336     (when (string-match
 337            "^\\(\\.\\)\\(.*\\)$"
 338            folder)
 339       (if (eq (length (setq fld-name
 340                             (elmo-match-string 2 folder))) 0)
 341           (setq fld-name ""))
 342       (if (file-name-absolute-p fld-name)
 343           (setq path (expand-file-name fld-name))
 344         (setq path fld-name))
 345       (list 'maildir path))))
 346
 347 (defun elmo-folder-maildir-p (folder)
 348   (catch 'found
 349     (let ((li elmo-maildir-list))
 350       (while li
 351         (if (string-match (car li) folder)
 352             (throw 'found t))
 353         (setq li (cdr li))))))
 354
 355 (defun elmo-localnews-get-spec (folder)
 356   (let (fld-name)
 357     (when (string-match
 358          "^\\(=\\)\\(.*\\)$"
 359          folder)
 360       (if (eq (length (setq fld-name
 361                             (elmo-match-string 2 folder))) 0)
 362           (setq fld-name "")
 363         )
 364       (list 'localnews
 365             (elmo-replace-in-string fld-name "\\." "/")))))
 366
 367 (defun elmo-cache-get-spec (folder)
 368   (let (fld-name)
 369     (when (string-match
 370          "^\\(!\\)\\(.*\\)$"
 371          folder)
 372       (if (eq (length (setq fld-name
 373                             (elmo-match-string 2 folder))) 0)
 374           (setq fld-name "")
 375         )
 376       (list 'cache
 377             (elmo-replace-in-string fld-name "\\." "/")))))
 378
 379 ;; Archive interface by OKUNISHI Fujikazu <fuji0924@mbox.kyoto-inet.or.jp>
 380 (defun elmo-archive-get-spec (folder)
 381   (require 'elmo-archive)
 382   (let (fld-name type prefix)
 383     (when (string-match
 384            "^\\(\\$\\)\\([^;]*\\);?\\([^;]*\\);?\\([^;]*\\)$"
 385            folder)
 386       ;; Drive letter is OK!
 387       (if (eq (length (setq fld-name
 388                             (elmo-match-string 2 folder))) 0)
 389           (setq fld-name "")
 390         )
 391       (if (eq (length (setq type
 392                             (elmo-match-string 3 folder))) 0)
 393           (setq type (symbol-name elmo-archive-default-type)))
 394       (if (eq (length (setq prefix
 395                             (elmo-match-string 4 folder))) 0)
 396           (setq prefix ""))
 397       (list 'archive fld-name (intern-soft type) prefix))))
 398
 399 (defun elmo-pop3-get-spec (folder)
 400   (let ((stream-type-alist elmo-network-stream-type-alist)
 401         spec user auth)
 402     (if elmo-pop3-stream-type-alist
 403         (setq stream-type-alist
 404               (append elmo-pop3-stream-type-alist stream-type-alist)))
 405     (setq spec (elmo-network-get-spec folder
 406                                       elmo-default-pop3-server
 407                                       elmo-default-pop3-port
 408                                       elmo-default-pop3-stream-type
 409                                       stream-type-alist))
 410     (setq folder (car spec))
 411     (when (string-match
 412            "^\\(&\\)\\([^:/!]*\\)\\(/[^/:@!]+\\)?"
 413            folder)
 414       (setq user (if (match-beginning 2)
 415                      (elmo-match-string 2 folder)))
 416       (if (eq (length user) 0)
 417           (setq user elmo-default-pop3-user))
 418       (setq auth (if (match-beginning 3)
 419                      (intern (elmo-match-substring 3 folder 1))
 420                    elmo-default-pop3-authenticate-type))
 421       (append (list 'pop3 user auth)
 422               (cdr spec)))))
 423
 424 (defsubst elmo-pop3-spec-username (spec)
 425   (nth 1 spec))
 426
 427 (defsubst elmo-pop3-spec-auth (spec)
 428   (nth 2 spec))
 429
 430 (defsubst elmo-pop3-spec-hostname (spec)
 431   (nth 3 spec))
 432
 433 (defsubst elmo-pop3-spec-port (spec)
 434   (nth 4 spec))
 435
 436 (defsubst elmo-pop3-spec-stream-type (spec)
 437   (nth 5 spec))
 438
 439 (defun elmo-internal-get-spec (folder)
 440   (if (string-match "\\('\\)\\([^/]*\\)/?\\(.*\\)$" folder)
 441       (let* ((item (downcase (elmo-match-string 2 folder)))
 442              (sym (and (> (length item) 0) (intern item))))
 443         (cond ((or (null sym)
 444                    (eq sym 'mark))
 445                (list 'internal sym (elmo-match-string 3 folder)))
 446               ((eq sym 'cache)
 447                (list 'cache (elmo-match-string 3 folder)))
 448               (t (error "Invalid internal folder spec"))))))
 449
 450 (defun elmo-multi-get-spec (folder)
 451   (save-match-data
 452     (when (string-match
 453            "^\\(\\*\\)\\(.*\\)$"
 454            folder)
 455       (append (list 'multi)
 456               (split-string
 457                (elmo-match-string 2 folder)
 458                ",")))))
 459
 460 (defun elmo-filter-get-spec (folder)
 461   (when (string-match "^\\(/\\)\\(.*\\)$" folder)
 462     (let ((folder (elmo-match-string 2 folder))
 463           pair)
 464       (setq pair (elmo-parse-search-condition folder))
 465       (if (string-match "^ */\\(.*\\)$" (cdr pair))
 466           (list 'filter (car pair) (elmo-match-string 1 (cdr pair)))
 467         (error "Folder syntax error `%s'" folder)))))
 468
 469 (defun elmo-pipe-get-spec (folder)
 470   (when (string-match "^\\(|\\)\\([^|]*\\)|\\(.*\\)$" folder)
 471     (list 'pipe
 472           (elmo-match-string 2 folder)
 473           (elmo-match-string 3 folder))))
 474
 475 (defun elmo-folder-get-spec (folder)
 476   "Return spec of FOLDER."
 477   (let ((type (elmo-folder-get-type folder)))
 478     (if type
 479         (save-match-data
 480           (funcall (intern (concat "elmo-" (symbol-name type) "-get-spec"))
 481                    folder))
 482       (error "%s is not supported folder type" folder))))
 483
 484 ;;; Search Condition
 485
 486 (defconst elmo-condition-atom-regexp "[^/ \")|&]*")
 487
 488 (defun elmo-read-search-condition (default)
 489   "Read search condition string interactively."
 490   (elmo-read-search-condition-internal "Search by" default))
 491
 492 (defun elmo-read-search-condition-internal (prompt default)
 493   (let* ((completion-ignore-case t)
 494          (field (completing-read
 495                  (format "%s (%s): " prompt default)
 496                  (mapcar 'list
 497                          (append '("AND" "OR"
 498                                    "Last" "First"
 499                                    "From" "Subject" "To" "Cc" "Body"
 500                                    "Since" "Before" "ToCc"
 501                                    "!From" "!Subject" "!To" "!Cc" "!Body"
 502                                    "!Since" "!Before" "!ToCc")
 503                                  elmo-msgdb-extra-fields))))
 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   "Replace 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 (+ (* 64 7) (* 8 0) 0))))) ; chmod 0700
1054
1055 (defun elmo-delete-directory (path &optional no-hierarchy)
1056   "Delete directory recursively."
1057   (let ((dirent (directory-files path))
1058         relpath abspath hierarchy)
1059     (while dirent
1060       (setq relpath (car dirent)
1061             dirent (cdr dirent)
1062             abspath (expand-file-name relpath path))
1063       (when (not (string-match "^\\.\\.?$" relpath))
1064         (if (eq (nth 0 (file-attributes abspath)) t)
1065             (if no-hierarchy
1066                 (setq hierarchy t)
1067               (elmo-delete-directory abspath no-hierarchy))
1068           (delete-file abspath))))
1069     (unless hierarchy
1070       (delete-directory path))))
1071
1072 (defun elmo-list-filter (l1 l2)
1073   "L1 is filter."
1074   (if (eq l1 t)
1075       ;; t means filter all.
1076       nil
1077     (if l1
1078         (elmo-delete-if (lambda (x) (not (memq x l1))) l2)
1079       ;; filter is nil
1080       l2)))
1081
1082 (defun elmo-folder-local-p (folder)
1083   "Return whether FOLDER is a local folder or not."
1084   (let ((type (elmo-folder-get-type folder)))
1085     (memq type '(localdir localnews archive maildir internal cache))))
1086
1087 (defun elmo-folder-writable-p (folder)
1088   (let ((type (elmo-folder-get-type folder)))
1089     (memq type '(imap4 localdir archive))))
1090
1091 (defun elmo-multi-get-intlist-list (numlist &optional as-is)
1092   (let ((numbers (sort numlist '<))
1093         (cur-number 0)
1094         one-list int-list-list)
1095     (while numbers
1096       (setq cur-number (+ cur-number 1))
1097       (setq one-list nil)
1098       (while (and numbers
1099                   (eq 0
1100                       (/ (- (car numbers)
1101                             (* elmo-multi-divide-number cur-number))
1102                          elmo-multi-divide-number)))
1103         (setq one-list (nconc
1104                         one-list
1105                         (list
1106                          (if as-is
1107                              (car numbers)
1108                            (% (car numbers)
1109                               (* elmo-multi-divide-number cur-number))))))
1110         (setq numbers (cdr numbers)))
1111       (setq int-list-list (nconc int-list-list (list one-list))))
1112     int-list-list))
1113
1114 (defsubst elmo-list-delete-if-smaller (list number)
1115   (let ((ret-val (copy-sequence list)))
1116     (while list
1117       (if (< (car list) number)
1118           (setq ret-val (delq (car list) ret-val)))
1119       (setq list (cdr list)))
1120     ret-val))
1121
1122 (defun elmo-list-diff (list1 list2 &optional mes)
1123   (if mes
1124       (message mes))
1125   (let ((clist1 (copy-sequence list1))
1126         (clist2 (copy-sequence list2)))
1127     (while list2
1128       (setq clist1 (delq (car list2) clist1))
1129       (setq list2 (cdr list2)))
1130     (while list1
1131       (setq clist2 (delq (car list1) clist2))
1132       (setq list1 (cdr list1)))
1133     (if mes
1134         (message (concat mes "done.")))
1135     (list clist1 clist2)))
1136
1137 (defun elmo-list-bigger-diff (list1 list2 &optional mes)
1138   "Returns a list (- +). + is bigger than max of LIST1, in LIST2."
1139   (if (null list2)
1140       (cons list1  nil)
1141     (let* ((l1 list1)
1142            (l2 list2)
1143            (max-of-l2 (or (nth (max 0 (1- (length l2))) l2) 0))
1144            diff1 num i percent
1145            )
1146       (setq i 0)
1147       (setq num (+ (length l1)))
1148       (while l1
1149         (if (memq (car l1) l2)
1150             (if (eq (car l1) (car l2))
1151                 (setq l2 (cdr l2))
1152               (delq (car l1) l2))
1153           (if (> (car l1) max-of-l2)
1154               (setq diff1 (nconc diff1 (list (car l1))))))
1155         (if mes
1156             (progn
1157               (setq i (+ i 1))
1158               (setq percent (/ (* i 100) num))
1159               (if (eq (% percent 5) 0)
1160                   (elmo-display-progress
1161                    'elmo-list-bigger-diff "%s%d%%" percent mes))))
1162         (setq l1 (cdr l1)))
1163       (cons diff1 (list l2)))))
1164
1165 (defun elmo-multi-list-bigger-diff (list1 list2 &optional mes)
1166   (let ((list1-list (elmo-multi-get-intlist-list list1 t))
1167         (list2-list (elmo-multi-get-intlist-list list2 t))
1168         result
1169         dels news)
1170     (while (or list1-list list2-list)
1171       (setq result (elmo-list-bigger-diff (car list1-list) (car list2-list)
1172                                           mes))
1173       (setq dels (append dels (car result)))
1174       (setq news (append news (cadr result)))
1175       (setq list1-list (cdr list1-list))
1176       (setq list2-list (cdr list2-list)))
1177     (cons dels (list news))))
1178
1179 (defvar elmo-imap4-name-space-regexp-list nil)
1180 (defun elmo-imap4-identical-name-space-p (fld1 fld2)
1181   ;; only on UW?
1182   (if (or (eq (string-to-char fld1) ?#)
1183           (eq (string-to-char fld2) ?#))
1184       (string= (car (split-string fld1 "/"))
1185                (car (split-string fld2 "/")))
1186     t))
1187
1188 (defun elmo-folder-identical-system-p (folder1 folder2)
1189   "FOLDER1 and FOLDER2 should be real folder (not virtual)."
1190   (cond ((eq (elmo-folder-get-type folder1) 'imap4)
1191          (let ((spec1 (elmo-folder-get-spec folder1))
1192                (spec2 (elmo-folder-get-spec folder2)))
1193            (and
1194 ;;; No use.
1195 ;;;         (elmo-imap4-identical-name-space-p
1196 ;;;          (nth 1 spec1) (nth 1 spec2))
1197             (string= (elmo-imap4-spec-hostname spec1)
1198                      (elmo-imap4-spec-hostname spec2)) ; hostname
1199             (string= (elmo-imap4-spec-username spec1)
1200                      (elmo-imap4-spec-username spec2))))) ; username
1201         (t
1202          (elmo-folder-direct-copy-p folder1 folder2))))
1203
1204 (defconst elmo-folder-direct-copy-alist
1205   '((localdir  . (localdir localnews archive))
1206     (maildir   . (maildir  localdir localnews archive))
1207     (localnews . (localdir localnews archive))
1208     (archive   . (localdir localnews archive))
1209     (cache     . (localdir localnews archive))))
1210
1211 (defun elmo-folder-direct-copy-p (src-folder dst-folder)
1212   (let ((src-type (car (elmo-folder-get-spec src-folder)))
1213         (dst-type (car (elmo-folder-get-spec dst-folder)))
1214         dst-copy-type)
1215     (and (setq dst-copy-type
1216                (cdr (assq src-type elmo-folder-direct-copy-alist)))
1217          (memq dst-type dst-copy-type))))
1218
1219 (defmacro elmo-filter-type (filter)
1220   (` (aref (, filter) 0)))
1221
1222 (defmacro elmo-filter-key (filter)
1223   (` (aref (, filter) 1)))
1224
1225 (defmacro elmo-filter-value (filter)
1226   (` (aref (, filter) 2)))
1227
1228 (defsubst elmo-buffer-field-primitive-condition-match (condition
1229                                                        number
1230                                                        number-list)
1231   (let (result)
1232     (goto-char (point-min))
1233     (cond
1234      ((string= (elmo-filter-key condition) "last")
1235       (setq result (<= (length (memq number number-list))
1236                        (string-to-int (elmo-filter-value condition)))))
1237      ((string= (elmo-filter-key condition) "first")
1238       (setq result (< (- (length number-list)
1239                          (length (memq number number-list)))
1240                       (string-to-int (elmo-filter-value condition)))))
1241      ((string= (elmo-filter-key condition) "since")
1242       (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
1243         (setq result
1244               (string<
1245                (timezone-make-sortable-date (aref date 0)
1246                                             (aref date 1)
1247                                             (aref date 2)
1248                                             (timezone-make-time-string
1249                                              (aref date 3)
1250                                              (aref date 4)
1251                                              (aref date 5)))
1252                (timezone-make-date-sortable (std11-field-body "date"))))))
1253      ((string= (elmo-filter-key condition) "before")
1254       (let ((date (elmo-date-get-datevec (elmo-filter-value condition))))
1255         (setq result
1256               (string<
1257                (timezone-make-date-sortable (std11-field-body "date"))
1258                (timezone-make-sortable-date (aref date 0)
1259                                             (aref date 1)
1260                                             (aref date 2)
1261                                             (timezone-make-time-string
1262                                              (aref date 3)
1263                                              (aref date 4)
1264                                              (aref date 5)))))))
1265      ((string= (elmo-filter-key condition) "body")
1266       (and (re-search-forward "^$" nil t)          ; goto body
1267            (setq result (search-forward (elmo-filter-value condition)
1268                                         nil t))))
1269      (t
1270       (let ((fval (std11-field-body (elmo-filter-key condition))))
1271         (if (eq (length fval) 0) (setq fval nil))
1272         (if fval (setq fval (eword-decode-string fval)))
1273         (setq result (and fval (string-match
1274                                 (elmo-filter-value condition) fval))))))
1275     (if (eq (elmo-filter-type condition) 'unmatch)
1276         (setq result (not result)))
1277     result))
1278
1279 (defun elmo-condition-find-key-internal (condition key)
1280   (cond
1281    ((vectorp condition)
1282     (if (string= (elmo-filter-key condition) key)
1283         (throw 'found t)))
1284    ((or (eq (car condition) 'and)
1285         (eq (car condition) 'or))
1286     (elmo-condition-find-key-internal (nth 1 condition) key)
1287     (elmo-condition-find-key-internal (nth 2 condition) key))))
1288
1289 (defun elmo-condition-find-key (condition key)
1290   (catch 'found
1291     (elmo-condition-find-key-internal condition key)))
1292
1293 (defun elmo-buffer-field-condition-match (condition number number-list)
1294   (cond
1295    ((vectorp condition)
1296     (elmo-buffer-field-primitive-condition-match
1297      condition number number-list))
1298    ((eq (car condition) 'and)
1299     (and (elmo-buffer-field-condition-match
1300           (nth 1 condition) number number-list)
1301          (elmo-buffer-field-condition-match
1302           (nth 2 condition) number number-list)))
1303    ((eq (car condition) 'or)
1304     (or (elmo-buffer-field-condition-match
1305          (nth 1 condition) number number-list)
1306         (elmo-buffer-field-condition-match
1307          (nth 2 condition) number number-list)))))
1308
1309 (defsubst elmo-file-field-condition-match (file condition number number-list)
1310   (elmo-set-work-buf
1311    (as-binary-input-file (insert-file-contents file))
1312    (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1313    ;; Should consider charset?
1314    (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
1315    (elmo-buffer-field-condition-match condition number number-list)))
1316
1317 (defmacro elmo-get-hash-val (string hashtable)
1318   (let ((sym (list 'intern-soft string hashtable)))
1319     (list 'if (list 'boundp sym)
1320        (list 'symbol-value sym))))
1321
1322 (defmacro elmo-set-hash-val (string value hashtable)
1323   (list 'set (list 'intern string hashtable) value))
1324
1325 (defmacro elmo-clear-hash-val (string hashtable)
1326   (static-if (fboundp 'unintern)
1327       (list 'unintern string hashtable)
1328     (list 'makunbound (list 'intern string hashtable))))
1329
1330 (defmacro elmo-unintern (string)
1331   "`unintern' symbol named STRING,  When can use `unintern'.
1332 Emacs 19.28 or earlier does not have `unintern'."
1333   (static-if (fboundp 'unintern)
1334       (list 'unintern string)))
1335
1336 ;; Make a hash table (default and minimum size is 1024).
1337 (defun elmo-make-hash (&optional hashsize)
1338   (make-vector
1339    (if hashsize (max (min (elmo-create-hash-size hashsize)
1340                           elmo-hash-maximum-size) 1024) 1024) 0))
1341
1342 (defsubst elmo-mime-string (string)
1343   "Normalize MIME encoded STRING."
1344     (and string
1345          (let (str)
1346            (elmo-set-work-buf
1347             (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1348             (setq str (eword-decode-string
1349                        (decode-mime-charset-string string elmo-mime-charset)))
1350             (setq str (encode-mime-charset-string str elmo-mime-charset))
1351             (elmo-set-buffer-multibyte nil)
1352             str))))
1353
1354 (defsubst elmo-collect-field (beg end downcase-field-name)
1355   (save-excursion
1356     (save-restriction
1357       (narrow-to-region beg end)
1358       (goto-char (point-min))
1359       (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1360             dest name body)
1361         (while (re-search-forward regexp nil t)
1362           (setq name (buffer-substring-no-properties
1363                       (match-beginning 1)(1- (match-end 1))))
1364           (if downcase-field-name
1365               (setq name (downcase name)))
1366           (setq body (buffer-substring-no-properties
1367                       (match-end 0) (std11-field-end)))
1368           (or (assoc name dest)
1369               (setq dest (cons (cons name body) dest))))
1370         dest))))
1371
1372 (defsubst elmo-collect-field-from-string (string downcase-field-name)
1373   (with-temp-buffer
1374     (insert string)
1375     (goto-char (point-min))
1376     (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1377           dest name body)
1378       (while (re-search-forward regexp nil t)
1379         (setq name (buffer-substring-no-properties
1380                     (match-beginning 1)(1- (match-end 1))))
1381         (if downcase-field-name
1382             (setq name (downcase name)))
1383         (setq body (buffer-substring-no-properties
1384                     (match-end 0) (std11-field-end)))
1385         (or (assoc name dest)
1386             (setq dest (cons (cons name body) dest))))
1387       dest)))
1388
1389 (defun elmo-create-hash-size (min)
1390   (let ((i 1))
1391     (while (< i min)
1392       (setq i (* 2 i)))
1393     i))
1394
1395 (defun elmo-safe-filename (folder)
1396   (elmo-replace-in-string
1397    (elmo-replace-in-string
1398     (elmo-replace-in-string folder "/" " ")
1399     ":" "__")
1400    "|" "_or_"))
1401
1402 (defvar elmo-msgid-replace-chars nil)
1403
1404 (defsubst elmo-replace-msgid-as-filename (msgid)
1405   "Replace Message-ID string (MSGID) as filename."
1406   (setq msgid (elmo-replace-in-string msgid " " "  "))
1407   (if (null elmo-msgid-replace-chars)
1408       (setq elmo-msgid-replace-chars
1409             (regexp-quote (mapconcat
1410                            'car elmo-msgid-replace-string-alist ""))))
1411   (while (string-match (concat "[" elmo-msgid-replace-chars "]")
1412                        msgid)
1413     (setq msgid (concat
1414                  (substring msgid 0 (match-beginning 0))
1415                  (cdr (assoc
1416                        (substring msgid
1417                                   (match-beginning 0) (match-end 0))
1418                        elmo-msgid-replace-string-alist))
1419                  (substring msgid (match-end 0)))))
1420   msgid)
1421
1422 (defsubst elmo-recover-msgid-from-filename (filename)
1423   "Recover Message-ID from FILENAME."
1424   (let (tmp result)
1425     (while (string-match " " filename)
1426       (setq tmp (substring filename
1427                            (match-beginning 0)
1428                            (+ (match-end 0) 1)))
1429       (if (string= tmp "  ")
1430           (setq tmp " ")
1431         (setq tmp (car (rassoc tmp
1432                                elmo-msgid-replace-string-alist))))
1433       (setq result
1434             (concat result
1435                     (substring filename 0 (match-beginning 0))
1436                     tmp))
1437       (setq filename (substring filename (+ (match-end 0) 1))))
1438     (concat result filename)))
1439
1440 (defsubst elmo-copy-file (src dst)
1441   (condition-case err
1442       (elmo-add-name-to-file src dst t)
1443     (error (copy-file src dst t)
1444            (error "Copy file failed"))))
1445
1446 (defsubst elmo-buffer-exists-p (buffer)
1447   (if (bufferp buffer)
1448       (buffer-live-p buffer)
1449     (get-buffer buffer)))
1450
1451 (defsubst elmo-kill-buffer (buffer)
1452   (when (elmo-buffer-exists-p buffer)
1453     (kill-buffer buffer)))
1454
1455 (defun elmo-delete-if (pred lst)
1456   "Return new list contain items which don't satisfy PRED in LST."
1457   (let (result)
1458     (while lst
1459       (unless (funcall pred (car lst))
1460         (setq result (nconc result (list (car lst)))))
1461       (setq lst (cdr lst)))
1462     result))
1463
1464 (defun elmo-list-delete (list1 list2)
1465   "Delete by side effect any occurrences equal to elements of LIST1 from LIST2.
1466 Return the modified LIST2.  Deletion is done with `delete'.
1467 Write `(setq foo (elmo-list-delete bar foo))' to be sure of changing
1468 the value of `foo'."
1469   (while list1
1470     (setq list2 (delete (car list1) list2))
1471     (setq list1 (cdr list1)))
1472   list2)
1473
1474 (defun elmo-list-member (list1 list2)
1475   "If any element of LIST1 is member of LIST2, return t."
1476   (catch 'done
1477     (while list1
1478       (if (member (car list1) list2)
1479           (throw 'done t))
1480       (setq list1 (cdr list1)))))
1481
1482 (defun elmo-count-matches (regexp beg end)
1483   (let ((count 0))
1484     (save-excursion
1485       (goto-char beg)
1486       (while (re-search-forward regexp end t)
1487         (setq count (1+ count)))
1488       count)))
1489
1490 (if (fboundp 'display-error)
1491     (defalias 'elmo-display-error 'display-error)
1492   (defun elmo-display-error (error-object stream)
1493     "A tiny function to display ERROR-OBJECT to the STREAM."
1494     (let ((first t)
1495           (errobj error-object)
1496           err-mes)
1497       (while errobj
1498         (setq err-mes (concat err-mes (format
1499                                        (if (stringp (car errobj))
1500                                            "%s"
1501                                          (if (boundp 'nemacs-version)
1502                                              "%s"
1503                                            "%S")) (car errobj))))
1504         (setq errobj (cdr errobj))
1505         (if errobj (setq err-mes (concat err-mes (if first ": " ", "))))
1506         (setq first nil))
1507       (princ err-mes stream))))
1508
1509 (if (fboundp 'define-error)
1510     (defalias 'elmo-define-error 'define-error)
1511   (defun elmo-define-error (error doc &optional parents)
1512     (or parents
1513         (setq parents 'error))
1514     (let ((conds (get parents 'error-conditions)))
1515       (or conds
1516           (error "Not an error symbol: %s" error))
1517       (setplist error
1518                 (list 'error-message doc
1519                       'error-conditions (cons error conds))))))
1520
1521 (cond ((fboundp 'lprogress-display)
1522        (defalias 'elmo-display-progress 'lprogress-display))
1523       ((fboundp 'progress-feedback-with-label)
1524        (defalias 'elmo-display-progress 'progress-feedback-with-label))
1525       (t
1526        (defun elmo-display-progress (label format &optional value &rest args)
1527          "Print a progress message."
1528          (if (and (null format) (null args))
1529              (message nil)
1530            (apply (function message) (concat format " %d%%")
1531                   (nconc args (list value)))))))
1532
1533 (defun elmo-time-expire (before-time diff-time)
1534   (let* ((current (current-time))
1535          (rest (when (< (nth 1 current) (nth 1 before-time))
1536                  (expt 2 16)))
1537          diff)
1538     (setq diff
1539           (list (- (+ (car current) (if rest -1 0)) (car before-time))
1540                 (- (+ (or rest 0) (nth 1 current)) (nth 1 before-time))))
1541     (and (eq (car diff) 0)
1542          (< diff-time (nth 1 diff)))))
1543
1544 (if (fboundp 'std11-fetch-field)
1545     (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
1546   (defalias 'elmo-field-body 'std11-field-body))
1547
1548 (defmacro elmo-string (string)
1549   "STRING without text property."
1550   (` (let ((obj (copy-sequence (, string))))
1551        (set-text-properties 0 (length obj) nil obj)
1552        obj)))
1553
1554 (defun elmo-y-or-n-p (prompt &optional auto default)
1555   "Same as `y-or-n-p'.
1556 But if optional argument AUTO is non-nil, DEFAULT is returned."
1557   (if auto
1558       default
1559     (y-or-n-p prompt)))
1560
1561 (defun elmo-string-member (string slist)
1562   "Return t if STRING is a member of the SLIST."
1563   (catch 'found
1564     (while slist
1565       (if (and (stringp (car slist))
1566                (string= string (car slist)))
1567           (throw 'found t))
1568       (setq slist (cdr slist)))))
1569
1570 (defun elmo-string-match-member (str list &optional case-ignore)
1571   (let ((case-fold-search case-ignore))
1572     (catch 'member
1573       (while list
1574         (if (string-match (car list) str)
1575             (throw 'member (car list)))
1576         (setq list (cdr list))))))
1577
1578 (defun elmo-string-matched-member (str list &optional case-ignore)
1579   (let ((case-fold-search case-ignore))
1580     (catch 'member
1581       (while list
1582         (if (string-match str (car list))
1583             (throw 'member (car list)))
1584         (setq list (cdr list))))))
1585
1586 (defsubst elmo-string-delete-match (string pos)
1587   (concat (substring string
1588                      0 (match-beginning pos))
1589           (substring string
1590                      (match-end pos)
1591                      (length string))))
1592
1593 (defun elmo-string-match-assoc (key alist &optional case-ignore)
1594   (let ((case-fold-search case-ignore)
1595         a)
1596     (catch 'loop
1597       (while alist
1598         (setq a (car alist))
1599         (if (and (consp a)
1600                  (stringp (car a))
1601                  (string-match key (car a)))
1602             (throw 'loop a))
1603         (setq alist (cdr alist))))))
1604
1605 (defun elmo-string-matched-assoc (key alist &optional case-ignore)
1606   (let ((case-fold-search case-ignore)
1607         a)
1608     (catch 'loop
1609       (while alist
1610         (setq a (car alist))
1611         (if (and (consp a)
1612                  (stringp (car a))
1613                  (string-match (car a) key))
1614             (throw 'loop a))
1615         (setq alist (cdr alist))))))
1616
1617 (defun elmo-string-assoc (key alist)
1618   (let (a)
1619     (catch 'loop
1620       (while alist
1621         (setq a (car alist))
1622         (if (and (consp a)
1623                  (stringp (car a))
1624                  (string= key (car a)))
1625             (throw 'loop a))
1626         (setq alist (cdr alist))))))
1627
1628 (defun elmo-string-rassoc (key alist)
1629   (let (a)
1630     (catch 'loop
1631       (while alist
1632         (setq a (car alist))
1633         (if (and (consp a)
1634                  (stringp (cdr a))
1635                  (string= key (cdr a)))
1636             (throw 'loop a))
1637         (setq alist (cdr alist))))))
1638
1639 ;;; Number set defined by OKAZAKI Tetsurou <okazaki@be.to>
1640 ;;
1641 ;; number          ::= [0-9]+
1642 ;; beg             ::= number
1643 ;; end             ::= number
1644 ;; number-range    ::= "(" beg " . " end ")"      ;; cons cell
1645 ;; number-set-elem ::= number / number-range
1646 ;; number-set      ::= "(" *number-set-elem ")"   ;; list
1647
1648 (defun elmo-number-set-member (number number-set)
1649   "Return non-nil if NUMBER is an element of NUMBER-SET.
1650 The value is actually the tail of NUMBER-RANGE whose car contains NUMBER."
1651   (or (memq number number-set)
1652       (let (found)
1653         (while (and number-set (not found))
1654           (if (and (consp (car number-set))
1655                    (and (<= (car (car number-set)) number)
1656                         (<= number (cdr (car number-set)))))
1657               (setq found t)
1658             (setq number-set (cdr number-set))))
1659         number-set)))
1660
1661 (defun elmo-number-set-append-list (number-set list)
1662   "Append LIST of numbers to the NUMBER-SET.
1663 NUMBER-SET is altered."
1664   (let ((appended number-set))
1665     (while list
1666       (setq appended (elmo-number-set-append appended (car list)))
1667       (setq list (cdr list)))
1668     appended))
1669
1670 (defun elmo-number-set-append (number-set number)
1671   "Append NUMBER to the NUMBER-SET.
1672 NUMBER-SET is altered."
1673   (let ((number-set-1 number-set)
1674         found elem)
1675     (while (and number-set (not found))
1676       (setq elem (car number-set))
1677       (cond
1678        ((and (consp elem)
1679              (eq (+ 1 (cdr elem)) number))
1680         (setcdr elem number)
1681         (setq found t))
1682        ((and (integerp elem)
1683              (eq (+ 1 elem) number))
1684         (setcar number-set (cons elem number))
1685         (setq found t))
1686        ((or (and (integerp elem) (eq elem number))
1687             (and (consp elem)
1688                  (<= (car elem) number)
1689                  (<= number (cdr elem))))
1690         (setq found t)))
1691       (setq number-set (cdr number-set)))
1692     (if (not found)
1693         (setq number-set-1 (nconc number-set-1 (list number))))
1694     number-set-1))
1695
1696 (require 'product)
1697 (product-provide (provide 'elmo-util) (require 'elmo-version))
1698
1699 ;;; elmo-util.el ends here