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