elmo/elmo-util.el

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