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   (save-match-data
 450     (when (string-match
 451            "^\\(/\\)\\(.*\\)$"
 452            folder)
 453       (let ((spec (elmo-match-string 2 folder))
 454             filter)
 455         (when (string-match "\\([^/]+\\)/" spec)
 456           (setq filter (elmo-match-string 1 spec))
 457           (setq spec (substring spec (match-end 0))))
 458         (cond
 459          ((string-match "^\\(last\\|first\\):\\(.*\\)$" filter) ; partial
 460           (setq filter (vector 'partial
 461                                (elmo-match-string 1 filter)
 462                                (elmo-match-string 2 filter))))
 463          (t
 464           (setq filter (elmo-parse-search-condition filter))))
 465         (list 'filter filter spec)))))
 466
 467 (defun elmo-pipe-get-spec (folder)
 468   (when (string-match "^\\(|\\)\\([^|]*\\)|\\(.*\\)$" folder)
 469     (list 'pipe
 470           (elmo-match-string 2 folder)
 471           (elmo-match-string 3 folder))))
 472
 473 (defun elmo-folder-get-spec (folder)
 474   "return spec of folder"
 475   (let ((type (elmo-folder-get-type folder)))
 476     (if type
 477         (funcall (intern (concat "elmo-" (symbol-name type) "-get-spec"))
 478                  folder)
 479       (error "%s is not supported folder type" folder))))
 480
 481 (defun elmo-parse-search-condition (condition)
 482   (let ((terms (split-string condition "|")) ; split by OR
 483         term ret-val)
 484     (while terms
 485       (setq term (car terms))
 486       (cond
 487        ((string-match "^\\([a-zA-Z\\-]+\\)=\\(.*\\)$" term)
 488         (if (save-match-data
 489               (string-match "tocc" (elmo-match-string 1 term))) ;; syntax sugar
 490             (setq ret-val (nconc
 491                            ret-val
 492                            (list (vector 'match "to"
 493                                          (elmo-match-string 2 term))
 494                                  (vector 'match "cc"
 495                                          (elmo-match-string 2 term)))))
 496           (setq ret-val (cons (vector 'match
 497                                       (elmo-match-string 1 term)
 498                                       (elmo-match-string 2 term))
 499                               ret-val))))
 500        ((string-match "^\\([a-zA-Z\\-]+\\)!=\\(.*\\)$" term)
 501         (if (save-match-data
 502               (string-match "tocc" (elmo-match-string 1 term))) ;; syntax sugar
 503             (setq ret-val (nconc
 504                            ret-val
 505                            (list (vector 'unmatch "to"
 506                                          (elmo-match-string 2 term))
 507                                  (vector 'unmatch "cc"
 508                                          (elmo-match-string 2 term)))))
 509           (setq ret-val (cons (vector 'unmatch
 510                                       (elmo-match-string 1 term)
 511                                       (elmo-match-string 2 term))
 512                               ret-val))))
 513        ((string-match "^\\(since\\|before\\):\\(.*\\)$" term)
 514         (setq ret-val (cons (vector 'date
 515                                     (elmo-match-string 1 term)
 516                                     (elmo-match-string 2 term))
 517                             ret-val))))
 518       (setq terms (cdr terms)))
 519     ret-val))
 520
 521 (defun elmo-multi-get-real-folder-number (folder number)
 522   (let* ((spec (elmo-folder-get-spec folder))
 523          (flds (cdr spec))
 524          (num number)
 525          (fld (nth (- (/ num elmo-multi-divide-number) 1) flds)))
 526     (cons fld (% num elmo-multi-divide-number))))
 527
 528 (defsubst elmo-buffer-replace (regexp &optional newtext)
 529   (goto-char (point-min))
 530   (while (re-search-forward regexp nil t)
 531     (replace-match (or newtext ""))))
 532
 533 (defsubst elmo-delete-char (char string &optional unibyte)
 534   (save-match-data
 535     (elmo-set-work-buf
 536      (let ((coding-system-for-read 'no-conversion)
 537            (coding-system-for-write 'no-conversion))
 538        (if unibyte (elmo-set-buffer-multibyte nil))
 539        (insert string)
 540        (goto-char (point-min))
 541        (while (search-forward (char-to-string char) nil t)
 542          (replace-match ""))
 543        (buffer-string)))))
 544
 545 (defsubst elmo-delete-cr-get-content-type ()
 546   (save-excursion
 547     (goto-char (point-min))
 548     (while (search-forward "\r\n" nil t)
 549       (replace-match "\n"))
 550     (goto-char (point-min))
 551     (or (std11-field-body "content-type")
 552         t)))
 553
 554 (defun elmo-delete-cr (string)
 555   (save-match-data
 556     (elmo-set-work-buf
 557      (insert string)
 558      (goto-char (point-min))
 559      (while (search-forward "\r\n" nil t)
 560        (replace-match "\n"))
 561      (buffer-string))))
 562
 563 (defun elmo-uniq-list (lst)
 564   "Distractively uniqfy elements of LST."
 565   (let ((tmp lst))
 566     (while tmp (setq tmp (setcdr tmp (and (cdr tmp) (delete (car tmp) (cdr tmp)))))))
 567   lst)
 568
 569 (defun elmo-string-partial-p (string)
 570   (and (stringp string) (string-match "message/partial" string)))
 571
 572 (defun elmo-get-file-string (filename &optional remove-final-newline)
 573   (elmo-set-work-buf
 574    (let (insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 575          insert-file-contents-post-hook)
 576      (when (file-exists-p filename)
 577        (if filename
 578            (as-binary-input-file (insert-file-contents filename)))
 579        (when (and remove-final-newline
 580                   (> (buffer-size) 0)
 581                   (= (char-after (1- (point-max))) ?\n))
 582          (goto-char (point-max))
 583          (delete-backward-char 1))
 584        (buffer-string)))))
 585
 586 (defun elmo-save-string (string filename)
 587   (if string
 588       (elmo-set-work-buf
 589        (as-binary-output-file
 590         (insert string)
 591         (write-region (point-min) (point-max)
 592                       filename nil 'no-msg))
 593        )))
 594
 595 (defun elmo-max-of-list (nlist)
 596   (let ((l nlist)
 597         (max-num 0))
 598     (while l
 599       (if (< max-num (car l))
 600           (setq max-num (car l)))
 601       (setq l (cdr l)))
 602     max-num))
 603
 604 (defun elmo-concat-path (path filename)
 605   (if (not (string= path ""))
 606       (if (string= elmo-path-sep (substring path (- (length path) 1)))
 607           (concat path filename)
 608         (concat path elmo-path-sep filename))
 609     filename))
 610
 611 (defvar elmo-passwd-alist nil)
 612
 613 (defun elmo-passwd-alist-load ()
 614   (save-excursion
 615     (let ((filename (expand-file-name elmo-passwd-alist-file-name
 616                                       elmo-msgdb-dir))
 617           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))
 618           insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 619           insert-file-contents-post-hook
 620           ret-val)
 621       (if (not (file-readable-p filename))
 622           ()
 623         (set-buffer tmp-buffer)
 624         (insert-file-contents filename)
 625         (setq ret-val
 626               (condition-case nil
 627                   (read (current-buffer))
 628                 (error nil nil))))
 629       (kill-buffer tmp-buffer)
 630       ret-val)))
 631
 632 (defun elmo-passwd-alist-clear ()
 633   "Clear password cache."
 634   (interactive)
 635   (setq elmo-passwd-alist nil))
 636
 637 (defun elmo-passwd-alist-save ()
 638   "Save password into file."
 639   (interactive)
 640   (save-excursion
 641     (let ((filename (expand-file-name elmo-passwd-alist-file-name
 642                                       elmo-msgdb-dir))
 643           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*")))
 644       (set-buffer tmp-buffer)
 645       (erase-buffer)
 646       (prin1 elmo-passwd-alist tmp-buffer)
 647       (princ "\n" tmp-buffer)
 648 ;      (if (and (file-exists-p filename)
 649 ;             (not (equal 384 (file-modes filename))))
 650 ;        (error "%s is not safe.chmod 600 %s!" filename filename))
 651       (if (file-writable-p filename)
 652          (progn
 653            (write-region (point-min) (point-max)
 654                          filename nil 'no-msg)
 655            (set-file-modes filename 384))
 656         (message (format "%s is not writable." filename)))
 657       (kill-buffer tmp-buffer))))
 658
 659 (defun elmo-get-passwd (key)
 660   "Get password from password pool."
 661   (let (pair pass)
 662     (if (not elmo-passwd-alist)
 663         (setq elmo-passwd-alist (elmo-passwd-alist-load)))
 664     (setq pair (assoc key elmo-passwd-alist))
 665     (if pair
 666         (elmo-base64-decode-string (cdr pair))
 667       (setq pass (elmo-read-passwd (format "Password for %s: "
 668                                            key) t))
 669       (setq elmo-passwd-alist
 670             (append elmo-passwd-alist
 671                     (list (cons key
 672                                 (elmo-base64-encode-string pass)))))
 673       (if elmo-passwd-life-time
 674           (run-with-timer elmo-passwd-life-time nil
 675                           (` (lambda () (elmo-remove-passwd (, key))))))
 676       pass)))
 677
 678 (defun elmo-remove-passwd (key)
 679   "Remove password from password pool (for failure)."
 680   (let (pass-cons)
 681     (if (setq pass-cons (assoc key elmo-passwd-alist))
 682         (progn
 683           (unwind-protect
 684               (fillarray (cdr pass-cons) 0))
 685           (setq elmo-passwd-alist
 686                 (delete pass-cons elmo-passwd-alist))))))
 687
 688 (defmacro elmo-read-char-exclusive ()
 689   (cond ((featurep 'xemacs)
 690          '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?)
 691                                (left . ?\C-h))))
 692                 event key)
 693             (while (not
 694                     (and
 695                      (key-press-event-p (setq event (next-command-event)))
 696                      (setq key (or (event-to-character event)
 697                                    (cdr (assq (event-key event) table)))))))
 698             key))
 699         ((fboundp 'read-char-exclusive)
 700          '(read-char-exclusive))
 701         (t
 702          '(read-char))))
 703
 704 (defun elmo-read-passwd (prompt &optional stars)
 705   "Read a single line of text from user without echoing, and return it."
 706   (let ((ans "")
 707         (c 0)
 708         (echo-keystrokes 0)
 709         (cursor-in-echo-area t)
 710         (log-message-max-size 0)
 711         message-log-max done msg truncate)
 712     (while (not done)
 713       (if (or (not stars) (string= "" ans))
 714           (setq msg prompt)
 715         (setq msg (concat prompt (make-string (length ans) ?.)))
 716         (setq truncate
 717               (1+ (- (length msg) (window-width (minibuffer-window)))))
 718         (and (> truncate 0)
 719              (setq msg (concat "$" (substring msg (1+ truncate))))))
 720       (message "%s" msg)
 721       (setq c (elmo-read-char-exclusive))
 722       (cond ((= c ?\C-g)
 723              (setq quit-flag t
 724                    done t))
 725             ((or (= c ?\r) (= c ?\n) (= c ?\e))
 726              (setq done t))
 727             ((= c ?\C-u)
 728              (setq ans ""))
 729             ((and (/= c ?\b) (/= c ?\177))
 730              (setq ans (concat ans (char-to-string c))))
 731             ((> (length ans) 0)
 732              (setq ans (substring ans 0 -1)))))
 733     (if quit-flag
 734         (prog1
 735             (setq quit-flag nil)
 736           (message "Quit")
 737           (beep t))
 738       (message "")
 739       ans)))
 740
 741 ;; from subr.el
 742 (defun elmo-replace-in-string (str regexp newtext &optional literal)
 743   "Replaces all matches in STR for REGEXP with NEWTEXT string,
 744  and returns the new string.
 745 Optional LITERAL non-nil means do a literal replacement.
 746 Otherwise treat \\ in NEWTEXT string as special:
 747   \\& means substitute original matched text,
 748   \\N means substitute match for \(...\) number N,
 749   \\\\ means insert one \\."
 750   (let ((rtn-str "")
 751         (start 0)
 752         (special)
 753         match prev-start)
 754     (while (setq match (string-match regexp str start))
 755       (setq prev-start start
 756             start (match-end 0)
 757             rtn-str
 758             (concat
 759               rtn-str
 760               (substring str prev-start match)
 761               (cond (literal newtext)
 762                     (t (mapconcat
 763                         (function
 764                          (lambda (c)
 765                            (if special
 766                                (progn
 767                                  (setq special nil)
 768                                  (cond ((eq c ?\\) "\\")
 769                                        ((eq c ?&)
 770                                         (elmo-match-string 0 str))
 771                                        ((and (>= c ?0) (<= c ?9))
 772                                         (if (> c (+ ?0 (length
 773                                                         (match-data))))
 774                                         ; Invalid match num
 775                                             (error "Invalid match num: %c" c)
 776                                           (setq c (- c ?0))
 777                                           (elmo-match-string c str)))
 778                                        (t (char-to-string c))))
 779                              (if (eq c ?\\) (progn (setq special t) nil)
 780                                (char-to-string c)))))
 781                         newtext ""))))))
 782     (concat rtn-str (substring str start))))
 783
 784 (defun elmo-string-to-list (string)
 785   (elmo-set-work-buf
 786    (insert string)
 787    (goto-char (point-min))
 788    (insert "(")
 789    (goto-char (point-max))
 790    (insert ")")
 791    (goto-char (point-min))
 792    (read (current-buffer))))
 793
 794 (defun elmo-plug-on-by-servers (alist &optional servers)
 795   (let ((server-list (or servers elmo-plug-on-servers)))
 796     (catch 'plugged
 797       (while server-list
 798         (if (elmo-plugged-p (car server-list))
 799             (throw 'plugged t))
 800         (setq server-list (cdr server-list))))))
 801
 802 (defun elmo-plug-on-by-exclude-servers (alist &optional servers)
 803   (let ((server-list (or servers elmo-plug-on-exclude-servers))
 804         server other-servers)
 805     (while alist
 806       (when (and (not (member (setq server (caaar alist)) server-list))
 807                  (not (member server other-servers)))
 808         (push server other-servers))
 809       (setq alist (cdr alist)))
 810     (elmo-plug-on-by-servers alist other-servers)))
 811
 812 (defun elmo-plugged-p (&optional server port alist label-exp)
 813   (let ((alist (or alist elmo-plugged-alist))
 814         plugged-info)
 815     (cond ((and (not port) (not server))
 816            (cond ((eq elmo-plugged-condition 'one)
 817                   (catch 'plugged
 818                     (while alist
 819                       (if (nth 2 (car alist))
 820                           (throw 'plugged t))
 821                       (setq alist (cdr alist)))))
 822                  ((eq elmo-plugged-condition 'all)
 823                   (catch 'plugged
 824                     (while alist
 825                       (if (not (nth 2 (car alist)))
 826                           (throw 'plugged nil))
 827                       (setq alist (cdr alist)))
 828                     t))
 829                  ((functionp elmo-plugged-condition)
 830                   (funcall elmo-plugged-condition alist))
 831                  (t ;; independent
 832                   elmo-plugged)))
 833           ((not port) ;; server
 834            (catch 'plugged
 835              (while alist
 836                (when (string= server (caaar alist))
 837                  (if (nth 2 (car alist))
 838                      (throw 'plugged t)))
 839                (setq alist (cdr alist)))))
 840           (t
 841            (setq plugged-info (assoc (cons server port) alist))
 842            (if (not plugged-info)
 843                ;; add elmo-plugged-alist automatically
 844                (progn
 845                  (elmo-set-plugged elmo-plugged server port nil nil label-exp)
 846                  elmo-plugged)
 847              (if (and elmo-auto-change-plugged
 848                       (> elmo-auto-change-plugged 0)
 849                       (nth 3 plugged-info)  ;; time
 850                       (elmo-time-expire (nth 3 plugged-info)
 851                                         elmo-auto-change-plugged))
 852                  t
 853                (nth 2 plugged-info)))))))
 854
 855 (defun elmo-set-plugged (plugged &optional server port time
 856                                  alist label-exp add)
 857   (let ((alist (or alist elmo-plugged-alist))
 858         label plugged-info)
 859     (cond ((and (not port) (not server))
 860            (setq elmo-plugged plugged)
 861            ;; set plugged all element of elmo-plugged-alist.
 862            (while alist
 863              (setcdr (cdar alist) (list plugged time))
 864              (setq alist (cdr alist))))
 865           ((not port)
 866            ;; set plugged all port of server
 867            (while alist
 868              (when (string= server (caaar alist))
 869                (setcdr (cdar alist) (list plugged time)))
 870              (setq alist (cdr alist))))
 871           (t
 872            ;; set plugged one port of server
 873            (setq plugged-info (assoc (cons server port) alist))
 874            (setq label (if label-exp
 875                            (eval label-exp)
 876                          (nth 1 plugged-info)))
 877            (if plugged-info
 878                ;; if add is non-nil, don't reset plug state.
 879                (unless add
 880                  (setcdr plugged-info (list label plugged time)))
 881              (setq alist
 882                    (setq elmo-plugged-alist
 883                          (nconc elmo-plugged-alist
 884                                 (list
 885                                  (list (cons server port) label plugged time))))))))
 886     alist))
 887
 888 (defun elmo-delete-plugged (&optional server port alist)
 889   (let* ((alist (or alist elmo-plugged-alist))
 890          (alist2 alist))
 891     (cond ((and (not port) (not server))
 892            (setq alist nil))
 893           ((not port)
 894            ;; delete plugged all port of server
 895            (while alist2
 896              (when (string= server (caaar alist2))
 897                (setq alist (delete (car alist2) alist)))
 898              (setq alist2 (cdr alist2))))
 899           (t
 900            ;; delete plugged one port of server
 901            (setq alist
 902                  (delete (assoc (cons server port) alist) alist))))
 903     alist))
 904
 905 (defun elmo-disk-usage (path)
 906   "Get disk usage (bytes) in PATH."
 907   (let ((file-attr
 908          (condition-case () (file-attributes path) (error nil))))
 909     (if file-attr
 910         (if (nth 0 file-attr) ; directory
 911             (let ((files (condition-case ()
 912                              (directory-files path t "^[^\\.]")
 913                            (error nil)))
 914                   (result 0.0))
 915               ;; (result (nth 7 file-attr))) ... directory size
 916               (while files
 917                 (setq result (+ result (or (elmo-disk-usage (car files)) 0)))
 918                 (setq files (cdr files)))
 919               result)
 920           (float (nth 7 file-attr))))))
 921
 922 (defun elmo-get-last-accessed-time (path &optional dir)
 923   "Returns last accessed time."
 924   (let ((last-accessed (nth 4 (file-attributes (or (and dir
 925                                                         (expand-file-name
 926                                                          path dir))
 927                                                    path)))))
 928     (if last-accessed
 929         (setq last-accessed (+ (* (nth 0 last-accessed)
 930                                   (float 65536)) (nth 1 last-accessed)))
 931       0)))
 932
 933 (defun elmo-get-last-modification-time (path &optional dir)
 934   "Returns last accessed time."
 935   (let ((last-modified (nth 5 (file-attributes (or (and dir
 936                                                         (expand-file-name
 937                                                          path dir))
 938                                                    path)))))
 939     (setq last-modified (+ (* (nth 0 last-modified)
 940                               (float 65536)) (nth 1 last-modified)))))
 941
 942 (defun elmo-make-directory (path)
 943   "create directory recursively."
 944   (let ((parent (directory-file-name (file-name-directory path))))
 945     (if (null (file-directory-p parent))
 946         (elmo-make-directory parent))
 947     (make-directory path)
 948     (if (string= path (expand-file-name elmo-msgdb-dir))
 949         (set-file-modes path 448) ; 700
 950       )))
 951
 952 (defun elmo-delete-directory (path &optional no-hierarchy)
 953   "delete directory recursively."
 954   (let ((dirent (directory-files path))
 955         relpath abspath hierarchy)
 956     (while dirent
 957       (setq relpath (car dirent)
 958             dirent (cdr dirent)
 959             abspath (expand-file-name relpath path))
 960       (when (not (string-match "^\\.\\.?$" relpath))
 961         (if (eq (nth 0 (file-attributes abspath)) t)
 962             (if no-hierarchy
 963                 (setq hierarchy t)
 964               (elmo-delete-directory abspath no-hierarchy))
 965           (delete-file abspath))))
 966     (unless hierarchy
 967       (delete-directory path))))
 968
 969 (defun elmo-list-filter (l1 l2)
 970   "L1 is filter."
 971   (if (eq l1 t)
 972       ;; t means filter all.
 973       nil
 974     (if l1
 975         (elmo-delete-if (lambda (x) (not (memq x l1))) l2)
 976       ;; filter is nil
 977       l2)))
 978
 979 (defun elmo-folder-local-p (folder)
 980   "Return whether FOLDER is a local folder or not."
 981   (let ((type (elmo-folder-get-type folder)))
 982     (memq type '(localdir localnews archive maildir internal cache))))
 983
 984 (defun elmo-folder-writable-p (folder)
 985   (let ((type (elmo-folder-get-type folder)))
 986     (memq type '(imap4 localdir archive))))
 987
 988 (defun elmo-multi-get-intlist-list (numlist &optional as-is)
 989   (let ((numbers (sort numlist '<))
 990         (cur-number 0)
 991         one-list int-list-list)
 992     (while numbers
 993       (setq cur-number (+ cur-number 1))
 994       (setq one-list nil)
 995       (while (and numbers
 996                   (eq 0
 997                       (/ (- (car numbers)
 998                             (* elmo-multi-divide-number cur-number))
 999                          elmo-multi-divide-number)))
1000         (setq one-list (nconc
1001                         one-list
1002                         (list
1003                          (if as-is
1004                              (car numbers)
1005                            (% (car numbers)
1006                               (* elmo-multi-divide-number cur-number))))))
1007         (setq numbers (cdr numbers)))
1008       (setq int-list-list (nconc int-list-list (list one-list))))
1009     int-list-list))
1010
1011 (defsubst elmo-list-delete-if-smaller (list number)
1012   (let ((ret-val (copy-sequence list)))
1013     (while list
1014       (if (< (car list) number)
1015           (setq ret-val (delq (car list) ret-val)))
1016       (setq list (cdr list)))
1017     ret-val))
1018
1019 (defun elmo-list-diff (list1 list2 &optional mes)
1020   (if mes
1021       (message mes))
1022   (let ((clist1 (copy-sequence list1))
1023         (clist2 (copy-sequence list2)))
1024     (while list2
1025       (setq clist1 (delq (car list2) clist1))
1026       (setq list2 (cdr list2)))
1027     (while list1
1028       (setq clist2 (delq (car list1) clist2))
1029       (setq list1 (cdr list1)))
1030     (if mes
1031         (message (concat mes "done.")))
1032     (list clist1 clist2)))
1033
1034 (defun elmo-list-bigger-diff (list1 list2 &optional mes)
1035   "Returns a list (- +). + is bigger than max of LIST1, in LIST2"
1036   (if (null list2)
1037       (cons list1  nil)
1038     (let* ((l1 list1)
1039            (l2 list2)
1040            (max-of-l2 (or (nth (max 0 (1- (length l2))) l2) 0))
1041            diff1 num i percent
1042            )
1043       (setq i 0)
1044       (setq num (+ (length l1)))
1045       (while l1
1046         (if (memq (car l1) l2)
1047             (if (eq (car l1) (car l2))
1048                 (setq l2 (cdr l2))
1049               (delq (car l1) l2))
1050           (if (> (car l1) max-of-l2)
1051               (setq diff1 (nconc diff1 (list (car l1))))))
1052         (if mes
1053             (progn
1054               (setq i (+ i 1))
1055               (setq percent (/ (* i 100) num))
1056               (if (eq (% percent 5) 0)
1057                   (elmo-display-progress
1058                    'elmo-list-bigger-diff "%s%d%%" percent mes))))
1059         (setq l1 (cdr l1)))
1060       (cons diff1 (list l2)))))
1061
1062 (defun elmo-multi-list-bigger-diff (list1 list2 &optional mes)
1063   (let ((list1-list (elmo-multi-get-intlist-list list1 t))
1064         (list2-list (elmo-multi-get-intlist-list list2 t))
1065         result
1066         dels news)
1067     (while (or list1-list list2-list)
1068       (setq result (elmo-list-bigger-diff (car list1-list) (car list2-list)
1069                                           mes))
1070       (setq dels (append dels (car result)))
1071       (setq news (append news (cadr result)))
1072       (setq list1-list (cdr list1-list))
1073       (setq list2-list (cdr list2-list)))
1074     (cons dels (list news))))
1075
1076 (defvar elmo-imap4-name-space-regexp-list nil)
1077 (defun elmo-imap4-identical-name-space-p (fld1 fld2)
1078   ;; only on UW?
1079   (if (or (eq (string-to-char fld1) ?#)
1080           (eq (string-to-char fld2) ?#))
1081       (string= (car (split-string fld1 "/"))
1082                (car (split-string fld2 "/")))
1083     t))
1084
1085 (defun elmo-folder-identical-system-p (folder1 folder2)
1086   "folder1 and folder2 should be real folder (not virtual)."
1087   (cond ((eq (elmo-folder-get-type folder1) 'imap4)
1088          (let ((spec1 (elmo-folder-get-spec folder1))
1089                (spec2 (elmo-folder-get-spec folder2)))
1090            (and ;(elmo-imap4-identical-name-space-p ;; No use.
1091                 ; (nth 1 spec1) (nth 1 spec2))
1092             (string= (elmo-imap4-spec-hostname spec1)
1093                      (elmo-imap4-spec-hostname spec2))    ; hostname
1094             (string= (elmo-imap4-spec-username spec1)
1095                      (elmo-imap4-spec-username spec2))))) ; username
1096         (t
1097          (elmo-folder-direct-copy-p folder1 folder2))))
1098
1099 (defconst elmo-folder-direct-copy-alist
1100   '((localdir  . (localdir localnews archive))
1101     (maildir   . (maildir  localdir localnews archive))
1102     (localnews . (localdir localnews archive))
1103     (archive   . (localdir localnews archive))
1104     (cache     . (localdir localnews archive))))
1105
1106 (defun elmo-folder-direct-copy-p (src-folder dst-folder)
1107   (let ((src-type (car (elmo-folder-get-spec src-folder)))
1108         (dst-type (car (elmo-folder-get-spec dst-folder)))
1109         dst-copy-type)
1110     (and (setq dst-copy-type
1111                (cdr (assq src-type elmo-folder-direct-copy-alist)))
1112          (memq dst-type dst-copy-type))))
1113
1114 (defmacro elmo-filter-type (filter)
1115   (` (aref (, filter) 0)))
1116
1117 (defmacro elmo-filter-key (filter)
1118   (` (aref (, filter) 1)))
1119
1120 (defmacro elmo-filter-value (filter)
1121   (` (aref (, filter) 2)))
1122
1123 (defsubst elmo-buffer-field-condition-match (condition)
1124   (let (term)
1125     (catch 'done
1126       (while condition
1127         (goto-char (point-min))
1128         (setq term (car condition))
1129         (cond
1130          ((and (eq (elmo-filter-type term) 'date)
1131                (string= (elmo-filter-key term) "since"))
1132           (let ((date (elmo-date-get-datevec (elmo-filter-value term))))
1133             (if (string<
1134                  (timezone-make-sortable-date (aref date 0)
1135                                               (aref date 1)
1136                                               (aref date 2)
1137                                               (timezone-make-time-string
1138                                                (aref date 3)
1139                                                (aref date 4)
1140                                                (aref date 5)))
1141                  (timezone-make-date-sortable (std11-field-body "date")))
1142                 (throw 'done t))))
1143          ((and (eq (elmo-filter-type term) 'date)
1144                (string= (elmo-filter-key term) "before"))
1145           (let ((date (elmo-date-get-datevec (elmo-filter-value term))))
1146             (if (string<
1147                  (timezone-make-date-sortable (std11-field-body "date"))
1148                  (timezone-make-sortable-date (aref date 0)
1149                                               (aref date 1)
1150                                               (aref date 2)
1151                                               (timezone-make-time-string
1152                                                (aref date 3)
1153                                                (aref date 4)
1154                                                (aref date 5))))
1155                 (throw 'done t))))
1156          ((eq (elmo-filter-type term) 'match)
1157           (if (string= "body" (elmo-filter-key term))
1158               (progn
1159                 (re-search-forward "^$" nil t)     ; goto body
1160                 (if (search-forward (elmo-filter-value term) nil t)
1161                     (throw 'done t)))
1162             (let ((fval (eword-decode-string
1163                          (or (std11-field-body (elmo-filter-key term)) ""))))
1164               (if (and fval (string-match (elmo-filter-value term)
1165                                           fval))
1166                   (throw 'done t)))))
1167          ((eq (elmo-filter-type term) 'unmatch)
1168           (if (string= "body" (elmo-filter-key term))
1169               (progn
1170                 (re-search-forward "^$" nil t)     ; goto body
1171                 (if (not (search-forward (elmo-filter-value term) nil t))
1172                     (throw 'done t)))
1173             (let ((fval (eword-decode-string
1174                          (or (std11-field-body (elmo-filter-key term)) ""))))
1175               (if fval
1176                   (if (not (string-match (elmo-filter-value term)
1177                                          fval))
1178                       (throw 'done t))
1179                 (throw 'done t)))))) ; OK?
1180         (setq condition (cdr condition)))
1181       (throw 'done nil))))
1182
1183 (defsubst elmo-file-field-condition-match (file condition)
1184   (elmo-set-work-buf
1185    (as-binary-input-file
1186     (insert-file-contents file))
1187    (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1188    (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
1189    (elmo-buffer-field-condition-match condition)))
1190
1191 (defun elmo-cross-device-link-error-p (err)
1192   (let ((errobj err)
1193         cur)
1194     (catch 'done
1195       (while errobj
1196         (if (and (stringp (setq cur (car errobj)))
1197                  (or (string-match "cross-device" cur)
1198                      (string-match "operation not supported" cur)))
1199             (throw 'done t))
1200         (setq errobj (cdr errobj)))
1201       nil)))
1202
1203 (defmacro elmo-get-hash-val (string hashtable)
1204   (let ((sym (list 'intern-soft string hashtable)))
1205     (list 'if (list 'boundp sym)
1206        (list 'symbol-value sym))))
1207
1208 (defmacro elmo-set-hash-val (string value hashtable)
1209   (list 'set (list 'intern string hashtable) value))
1210
1211 (defmacro elmo-clear-hash-val (string hashtable)
1212   (static-if (fboundp 'unintern)
1213       (list 'unintern string hashtable)
1214     (list 'makunbound (list 'intern string hashtable))))
1215
1216 ;; Make a hash table (default and minimum size is 1024).
1217 (defun elmo-make-hash (&optional hashsize)
1218   (make-vector
1219    (if hashsize (max (min (elmo-create-hash-size hashsize)
1220                           elmo-hash-maximum-size) 1024) 1024) 0))
1221
1222 (defsubst elmo-mime-string (string)
1223   "Normalize MIME encoded string."
1224     (and string
1225          (let (str)
1226            (elmo-set-work-buf
1227             (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1228             (setq str (eword-decode-string
1229                        (decode-mime-charset-string string elmo-mime-charset)))
1230             (setq str (encode-mime-charset-string str elmo-mime-charset))
1231             (elmo-set-buffer-multibyte nil)
1232             str))))
1233
1234 (defsubst elmo-collect-field (beg end downcase-field-name)
1235   (save-excursion
1236     (save-restriction
1237       (narrow-to-region beg end)
1238       (goto-char (point-min))
1239       (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1240             dest name body)
1241         (while (re-search-forward regexp nil t)
1242           (setq name (buffer-substring-no-properties
1243                       (match-beginning 1)(1- (match-end 1))))
1244           (if downcase-field-name
1245               (setq name (downcase name)))
1246           (setq body (buffer-substring-no-properties
1247                       (match-end 0) (std11-field-end)))
1248           (or (assoc name dest)
1249               (setq dest (cons (cons name body) dest))))
1250         dest))))
1251
1252 (defsubst elmo-collect-field-from-string (string downcase-field-name)
1253   (with-temp-buffer
1254     (insert string)
1255     (goto-char (point-min))
1256     (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1257           dest name body)
1258       (while (re-search-forward regexp nil t)
1259         (setq name (buffer-substring-no-properties
1260                     (match-beginning 1)(1- (match-end 1))))
1261         (if downcase-field-name
1262             (setq name (downcase name)))
1263         (setq body (buffer-substring-no-properties
1264                     (match-end 0) (std11-field-end)))
1265         (or (assoc name dest)
1266             (setq dest (cons (cons name body) dest))))
1267       dest)))
1268
1269 (defun elmo-create-hash-size (min)
1270   (let ((i 1))
1271     (while (< i min)
1272       (setq i (* 2 i)))
1273     i))
1274
1275 (defun elmo-safe-filename (folder)
1276   (elmo-replace-in-string
1277    (elmo-replace-in-string
1278     (elmo-replace-in-string folder "/" " ")
1279     ":" "__")
1280    "|" "_or_"))
1281
1282 (defvar elmo-msgid-replace-chars nil)
1283
1284 (defsubst elmo-replace-msgid-as-filename (msgid)
1285   "Replace message-id string as filename."
1286   (setq msgid (elmo-replace-in-string msgid " " "  "))
1287   (if (null elmo-msgid-replace-chars)
1288       (setq elmo-msgid-replace-chars
1289             (regexp-quote (mapconcat
1290                            'car elmo-msgid-replace-string-alist ""))))
1291   (while (string-match (concat "[" elmo-msgid-replace-chars "]")
1292                        msgid)
1293     (setq msgid (concat
1294                  (substring msgid 0 (match-beginning 0))
1295                  (cdr (assoc
1296                        (substring msgid
1297                                   (match-beginning 0) (match-end 0))
1298                        elmo-msgid-replace-string-alist))
1299                  (substring msgid (match-end 0)))))
1300   msgid)
1301
1302 (defsubst elmo-recover-msgid-from-filename (filename)
1303   "Recover Message-ID from filename."
1304   (let (tmp result)
1305     (while (string-match " " filename)
1306       (setq tmp (substring filename
1307                            (match-beginning 0)
1308                            (+ (match-end 0) 1)))
1309       (if (string= tmp "  ")
1310           (setq tmp " ")
1311         (setq tmp (car (rassoc tmp
1312                                elmo-msgid-replace-string-alist))))
1313       (setq result
1314             (concat result
1315                     (substring filename 0 (match-beginning 0))
1316                     tmp))
1317       (setq filename (substring filename (+ (match-end 0) 1))))
1318     (concat result filename)))
1319
1320 (defsubst elmo-copy-file (src dst)
1321   (condition-case err
1322       (elmo-add-name-to-file src dst t)
1323     (error (if (elmo-cross-device-link-error-p err)
1324                (copy-file src dst t)
1325              (error "copy file failed")))))
1326
1327 (defmacro elmo-buffer-exists-p (buffer)
1328   (` (when (, buffer)
1329        (funcall (if (stringp (, buffer)) 'get-buffer 'buffer-name)
1330                 (, buffer)))))
1331
1332 (defmacro elmo-kill-buffer (buffer)
1333   (` (when (elmo-buffer-exists-p (, buffer))
1334        (kill-buffer (, buffer)))))
1335
1336 (defun elmo-delete-if (pred lst)
1337   "Returns new list contains items which don't satisfy PRED in LST."
1338   (let (result)
1339     (while lst
1340       (unless (funcall pred (car lst))
1341         (setq result (nconc result (list (car lst)))))
1342       (setq lst (cdr lst)))
1343     result))
1344
1345 (defun elmo-list-delete (list1 list2)
1346   "Delete by side effect any occurrences equal to elements of LIST1 from LIST2.
1347 Return the modified LIST2.  Deletion is done with `delete'.
1348 Write `(setq foo (elmo-list-delete bar foo))' to be sure of changing
1349 the value of `foo'."
1350   (while list1
1351     (setq list2 (delete (car list1) list2))
1352     (setq list1 (cdr list1)))
1353   list2)
1354
1355 (defun elmo-list-member (list1 list2)
1356   "If any element of list1 is member of list2, returns t."
1357   (catch 'done
1358     (while list1
1359       (if (member (car list1) list2)
1360           (throw 'done t))
1361       (setq list1 (cdr list1)))))
1362
1363 (defun elmo-count-matches (regexp beg end)
1364   (let ((count 0))
1365     (save-excursion
1366       (goto-char beg)
1367       (while (re-search-forward regexp end t)
1368         (setq count (1+ count)))
1369       count)))
1370
1371 (if (fboundp 'display-error)
1372     (defalias 'elmo-display-error 'display-error)
1373   (defun elmo-display-error (error-object stream)
1374     "a tiny function to display error-object to the stream."
1375     (let ((first t)
1376           (errobj error-object)
1377           err-mes)
1378       (while errobj
1379         (setq err-mes (concat err-mes (format
1380                                        (if (stringp (car errobj))
1381                                            "%s"
1382                                          (if (boundp 'nemacs-version)
1383                                              "%s"
1384                                            "%S")) (car errobj))))
1385         (setq errobj (cdr errobj))
1386         (if errobj (setq err-mes (concat err-mes (if first ": " ", "))))
1387         (setq first nil))
1388       (princ err-mes stream))))
1389
1390 (if (fboundp 'define-error)
1391     (defalias 'elmo-define-error 'define-error)
1392   (defun elmo-define-error (error doc &optional parents)
1393     (or parents
1394         (setq parents 'error))
1395     (let ((conds (get parents 'error-conditions)))
1396       (or conds
1397           (error "Not an error symbol: %s" error))
1398       (setplist error
1399                 (list 'error-message doc
1400                       'error-conditions (cons error conds))))))
1401
1402 (cond ((fboundp 'lprogress-display)
1403        (defalias 'elmo-display-progress 'lprogress-display))
1404       ((fboundp 'progress-feedback-with-label)
1405        (defalias 'elmo-display-progress 'progress-feedback-with-label))
1406       (t
1407        (defun elmo-display-progress (label format &optional value &rest args)
1408          "Print a progress message."
1409          (if (and (null format) (null args))
1410              (message nil)
1411            (apply (function message) (concat format " %d%%")
1412                   (nconc args (list value)))))))
1413
1414 (defun elmo-time-expire (before-time diff-time)
1415   (let* ((current (current-time))
1416          (rest (when (< (nth 1 current) (nth 1 before-time))
1417                  (expt 2 16)))
1418          diff)
1419     (setq diff
1420           (list (- (+ (car current) (if rest -1 0)) (car before-time))
1421                 (- (+ (or rest 0) (nth 1 current)) (nth 1 before-time))))
1422     (and (eq (car diff) 0)
1423          (< diff-time (nth 1 diff)))))
1424
1425 (if (fboundp 'std11-fetch-field)
1426     (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
1427   (defalias 'elmo-field-body 'std11-field-body))
1428
1429 (defmacro elmo-string (string)
1430   "String without text property"
1431   (` (let ((obj (copy-sequence (, string))))
1432        (set-text-properties 0 (length obj) nil obj)
1433        obj)))
1434
1435 (defun elmo-y-or-n-p (prompt &optional auto default)
1436   "Same as `y-or-n-p'.
1437 But if optional argument AUTO is non-nil, DEFAULT is returned."
1438   (if auto
1439       default
1440     (y-or-n-p prompt)))
1441
1442 (defun elmo-string-member (string slist)
1443   "Returns t if STRING is a member of the SLIST."
1444   (catch 'found
1445     (while slist
1446       (if (and (stringp (car slist))
1447                (string= string (car slist)))
1448           (throw 'found t))
1449       (setq slist (cdr slist)))))
1450
1451 (defun elmo-string-match-member (str list &optional case-ignore)
1452   (let ((case-fold-search case-ignore))
1453     (catch 'member
1454       (while list
1455         (if (string-match (car list) str)
1456             (throw 'member (car list)))
1457         (setq list (cdr list))))))
1458
1459 (defsubst elmo-string-delete-match (string pos)
1460   (concat (substring string
1461                      0 (match-beginning pos))
1462           (substring string
1463                      (match-end pos)
1464                      (length string))))
1465
1466 (defun elmo-string-match-assoc (key alist &optional case-ignore)
1467   (let ((case-fold-search case-ignore)
1468         a)
1469     (catch 'loop
1470       (while alist
1471         (setq a (car alist))
1472         (if (and (consp a)
1473                  (stringp (car a))
1474                  (string-match key (car a)))
1475             (throw 'loop a))
1476         (setq alist (cdr alist))))))
1477
1478 (defun elmo-string-matched-assoc (key alist &optional case-ignore)
1479   (let ((case-fold-search case-ignore)
1480         a)
1481     (catch 'loop
1482       (while alist
1483         (setq a (car alist))
1484         (if (and (consp a)
1485                  (stringp (car a))
1486                  (string-match (car a) key))
1487             (throw 'loop a))
1488         (setq alist (cdr alist))))))
1489
1490 (defun elmo-string-assoc (key alist)
1491   (let (a)
1492     (catch 'loop
1493       (while alist
1494         (setq a (car alist))
1495         (if (and (consp a)
1496                  (stringp (car a))
1497                  (string= key (car a)))
1498             (throw 'loop a))
1499         (setq alist (cdr alist))))))
1500
1501 (defun elmo-string-rassoc (key alist)
1502   (let (a)
1503     (catch 'loop
1504       (while alist
1505         (setq a (car alist))
1506         (if (and (consp a)
1507                  (stringp (cdr a))
1508                  (string= key (cdr a)))
1509             (throw 'loop a))
1510         (setq alist (cdr alist))))))
1511
1512 (provide 'elmo-util)
1513
1514 ;;; elmo-util.el ends here