elmo/elmo-util.el

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