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 ;; Time-stamp: <2000-03-29 09:42:41 teranisi>
   8
   9 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25 ;;
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31 ;;
  32
  33 (require 'elmo-vars)
  34 (require 'elmo-date)
  35 (eval-when-compile (require 'cl))
  36 (require 'std11)
  37 (require 'eword-decode)
  38 (require 'utf7)
  39
  40 (eval-when-compile
  41   (condition-case nil
  42       (progn
  43         (require 'ssl)
  44         (require 'starttls))
  45     (error))
  46   (defun-maybe starttls-negotiate (a))
  47   (defun-maybe starttls-open-stream (a b c d))
  48   (defun-maybe open-ssl-stream (a b c d)))
  49
  50 (defmacro elmo-set-buffer-multibyte (flag)
  51   "Set the multibyte flag of the current buffer to FLAG."
  52   (cond ((boundp 'MULE)
  53          (list 'setq 'mc-flag flag))
  54         ((featurep 'xemacs)
  55          flag)
  56         ((and (boundp 'emacs-major-version) (>= emacs-major-version 20))
  57          (list 'set-buffer-multibyte flag))
  58         (t
  59          flag)))
  60
  61 (defvar elmo-work-buf-name " *elmo work*")
  62 (defvar elmo-temp-buf-name " *elmo temp*")
  63
  64 (or (boundp 'default-enable-multibyte-characters)
  65     (defvar default-enable-multibyte-characters (featurep 'mule)
  66       "The mock variable except for Emacs 20."))
  67
  68 (defun elmo-base64-encode-string (string &optional no-line-break))
  69 (defun elmo-base64-decode-string (string))
  70
  71 ;; base64 encoding/decoding
  72 (require 'mel)
  73 (fset 'elmo-base64-encode-string
  74       (mel-find-function 'mime-encode-string "base64"))
  75 (fset 'elmo-base64-decode-string
  76       (mel-find-function 'mime-decode-string "base64"))
  77
  78 ;; Any Emacsen may have add-name-to-file(), because loadup.el requires it. :-p
  79 ;; Check make-symbolic-link() instead.  -- 981002 by Fuji
  80 (if (fboundp 'make-symbolic-link)  ;; xxx
  81     (defalias 'elmo-add-name-to-file 'add-name-to-file)
  82   (defun elmo-add-name-to-file
  83     (filename newname &optional ok-if-already-exists)
  84     (copy-file filename newname ok-if-already-exists t)))
  85
  86 (require 'broken)
  87 (broken-facility timezone-y2k
  88   "timezone.el does not clear Y2K."
  89   (or (not (featurep 'timezone))
  90       (string= (aref (timezone-parse-date "Sat, 1 Jan 00 07:00:00 JST") 0)
  91                "2000")))
  92
  93 (when-broken timezone-y2k
  94   (defun timezone-parse-date (date)
  95     "Parse DATE and return a vector [YEAR MONTH DAY TIME TIMEZONE].
  96 19 is prepended to year if necessary.  Timezone may be nil if nothing.
  97 Understands the following styles:
  98  (1) 14 Apr 89 03:20[:12] [GMT]
  99  (2) Fri, 17 Mar 89 4:01[:33] [GMT]
 100  (3) Mon Jan 16 16:12[:37] [GMT] 1989
 101  (4) 6 May 1992 1641-JST (Wednesday)
 102  (5) 22-AUG-1993 10:59:12.82
 103  (6) Thu, 11 Apr 16:17:12 91 [MET]
 104  (7) Mon, 6  Jul 16:47:20 T 1992 [MET]"
 105     (condition-case nil
 106         (progn
 107           ;; Get rid of any text properties.
 108           (and (stringp date)
 109                (or (text-properties-at 0 date)
 110                    (next-property-change 0 date))
 111                (setq date (copy-sequence date))
 112                (set-text-properties 0 (length date) nil date))
 113           (let ((date (or date ""))
 114                 (year nil)
 115                 (month nil)
 116                 (day nil)
 117                 (time nil)
 118                 (zone nil))                     ;This may be nil.
 119             (cond ((string-match
 120                     "\\([^ \t,]+\\),[ \t]+\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\(T[ \t]+\\|\\)\\([0-9]+\\)[ \t]*\\'" date)
 121                    ;; Styles: (6) and (7) without timezone
 122                    (setq year 6 month 3 day 2 time 4 zone nil))
 123                   ((string-match
 124                     "\\([^ \t,]+\\),[ \t]+\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\(T[ \t]+\\|\\)\\([0-9]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date)
 125                    ;; Styles: (6) and (7) with timezone and buggy timezone
 126                    (setq year 6 month 3 day 2 time 4 zone 7))
 127                   ((string-match
 128                     "\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]*\\'" date)
 129                    ;; Styles: (1) and (2) without timezone
 130                    (setq year 3 month 2 day 1 time 4 zone nil))
 131                   ((string-match
 132                     "\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date)
 133                    ;; Styles: (1) and (2) with timezone and buggy timezone
 134                    (setq year 3 month 2 day 1 time 4 zone 5))
 135                   ((string-match
 136                     "\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\([0-9]+\\)" date)
 137                    ;; Styles: (3) without timezone
 138                    (setq year 4 month 1 day 2 time 3 zone nil))
 139                   ((string-match
 140                     "\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9:]+\\)[ \t]+\\([-+a-zA-Z0-9]+\\)[ \t]+\\([0-9]+\\)" date)
 141                    ;; Styles: (3) with timezone
 142                    (setq year 5 month 1 day 2 time 3 zone 4))
 143                   ((string-match
 144                     "\\([0-9]+\\)[ \t]+\\([^ \t,]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]*\\([-+a-zA-Z0-9]+\\)" date)
 145                    ;; Styles: (4) with timezone
 146                    (setq year 3 month 2 day 1 time 4 zone 5))
 147                   ((string-match
 148                     "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)[ \t]+\\([0-9]+:[0-9]+:[0-9]+\\)\\.[0-9]+" date)
 149                    ;; Styles: (5) without timezone.
 150                    (setq year 3 month 2 day 1 time 4 zone nil))
 151                   )
 152             (if year
 153                 (progn
 154                   (setq year
 155                         (substring date (match-beginning year)
 156                                    (match-end year)))
 157                   (if (< (length year) 4)
 158                       (let ((yr (string-to-int year)))
 159                         (when (>= yr 100)
 160                           (setq yr (- yr 100)))
 161                         (setq year (format "%d%02d"
 162                                            (if (< yr 70)
 163                                                20
 164                                              19)
 165                                            yr))))
 166                   (let ((string (substring date
 167                                            (match-beginning month)
 168                                            (+ (match-beginning month) 3))))
 169                     (setq month
 170                           (int-to-string
 171                            (cdr (assoc (upcase string)
 172                                        timezone-months-assoc)))))
 173                   (setq day
 174                         (substring date (match-beginning day) (match-end day)))
 175                   (setq time
 176                         (substring date (match-beginning time)
 177                                    (match-end time)))))
 178             (if zone
 179                 (setq zone
 180                       (substring date (match-beginning zone)
 181                                  (match-end zone))))
 182             (if year
 183                 (vector year month day time zone)
 184               (vector "0" "0" "0" "0" nil))
 185             )
 186           )
 187       (t (signal 'invalid-date (list date))))))
 188
 189 (defsubst elmo-call-func (folder func-name &rest args)
 190   (let* ((spec (if (stringp folder)
 191                    (elmo-folder-get-spec folder)
 192                  folder))
 193          (type (symbol-name (car spec)))
 194          (backend-str (concat "elmo-" type))
 195          (backend-sym (intern backend-str)))
 196     (unless (featurep backend-sym)
 197       (require backend-sym))
 198     (apply (intern (format "%s-%s" backend-str func-name))
 199            spec
 200            args)))
 201
 202 (defmacro elmo-set-work-buf (&rest body)
 203   "Execute BODY on work buffer. Work buffer remains."
 204   (` (save-excursion
 205        (set-buffer (get-buffer-create elmo-work-buf-name))
 206        (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 207        (erase-buffer)
 208        (,@ body))))
 209
 210 (defmacro elmo-match-substring (pos string from)
 211   "Substring of POSth matched string of STRING. "
 212   (` (substring (, string)
 213                 (+ (match-beginning (, pos)) (, from))
 214                 (match-end (, pos)))))
 215
 216 (defmacro elmo-match-string (pos string)
 217   "Substring POSth matched string."
 218   (` (substring (, string) (match-beginning (, pos)) (match-end (, pos)))))
 219
 220 (defmacro elmo-match-buffer (pos)
 221   "Substring POSth matched from the current buffer."
 222   (` (buffer-substring-no-properties
 223       (match-beginning (, pos)) (match-end (, pos)))))
 224
 225 (defmacro elmo-bind-directory (dir &rest body)
 226   "Set current directory DIR and execute BODY."
 227   (` (let ((default-directory (file-name-as-directory (, dir))))
 228        (,@ body))))
 229
 230 (defmacro elmo-folder-get-type (folder)
 231   "Get type of FOLDER."
 232   (` (and (stringp (, folder))
 233           (cdr (assoc (string-to-char (, folder)) elmo-spec-alist)))))
 234
 235 (defun elmo-object-load (filename &optional mime-charset no-err)
 236   "Load OBJECT from the file specified by FILENAME.
 237 File content is decoded with MIME-CHARSET."
 238     (if (not (file-readable-p filename))
 239         nil
 240       (elmo-set-work-buf
 241        (as-binary-input-file
 242         (insert-file-contents filename))
 243        (when mime-charset
 244          (elmo-set-buffer-multibyte default-enable-multibyte-characters)
 245          (decode-mime-charset-region (point-min) (point-max) mime-charset))
 246        (condition-case nil
 247            (read (current-buffer))
 248          (error (unless no-err
 249                   (message "Warning: Loading object from %s failed."
 250                            filename)
 251                   (elmo-object-save filename nil))
 252                 nil)))))
 253
 254 (defsubst elmo-save-buffer (filename &optional mime-charset)
 255   "Save current buffer to the file specified by FILENAME.
 256 Directory of the file is created if it doesn't exist.
 257 File content is encoded with MIME-CHARSET."
 258   (let ((dir (directory-file-name (file-name-directory filename))))
 259     (if (file-directory-p dir)
 260         () ; ok.
 261       (unless (file-exists-p dir)
 262         (elmo-make-directory dir)))
 263     (if (file-writable-p filename)
 264         (progn
 265           (when mime-charset
 266             ;;(elmo-set-buffer-multibyte default-enable-multibyte-characters)
 267             (encode-mime-charset-region (point-min) (point-max) mime-charset))
 268           (as-binary-output-file
 269            (write-region (point-min) (point-max) filename nil 'no-msg)))
 270       (message (format "%s is not writable." filename)))))
 271
 272 (defun elmo-object-save (filename object &optional mime-charset)
 273   "Save OBJECT to the file specified by FILENAME.
 274 Directory of the file is created if it doesn't exist.
 275 File content is encoded with MIME-CHARSET."
 276   (elmo-set-work-buf
 277    (prin1 object (current-buffer))
 278    ;;(princ "\n" (current-buffer))
 279    (elmo-save-buffer filename mime-charset)))
 280
 281 (defsubst elmo-imap4-decode-folder-string (string)
 282   (if elmo-imap4-use-modified-utf7
 283       (utf7-decode-string string 'imap)
 284     string))
 285
 286 (defsubst elmo-imap4-encode-folder-string (string)
 287   (if elmo-imap4-use-modified-utf7
 288       (utf7-encode-string string 'imap)
 289     string))
 290
 291 (defun elmo-network-get-spec (folder default-server default-port default-tls)
 292   (let (server port tls)
 293     (if (string-match "\\(@[^@:/!]+\\)?\\(:[0-9]+\\)?\\(!*\\)$" folder)
 294         (progn
 295           (if (match-beginning 1)
 296               (setq server (elmo-match-substring 1 folder 1))
 297             (setq server default-server))
 298           (if (match-beginning 2)
 299               (setq port
 300                     (string-to-int (elmo-match-substring 2 folder 1)))
 301             (setq port default-port))
 302           (setq tls (elmo-match-string 3 folder))
 303           (if (and (match-beginning 3)
 304                    (> (length tls) 0))
 305               (setq tls (if (= 2 (length tls)) 'starttls
 306                           (string= tls "!")))
 307             (setq tls default-tls))
 308           (setq folder (substring folder 0 (match-beginning 0))))
 309       (setq server default-server
 310             port   default-port
 311             tls    default-tls))
 312     (cons folder (list server port tls))))
 313
 314 (defun elmo-imap4-get-spec (folder)
 315   (let ((default-user    elmo-default-imap4-user)
 316         (default-server  elmo-default-imap4-server)
 317         (default-port    elmo-default-imap4-port)
 318         (default-tls     elmo-default-imap4-ssl)
 319         spec mailbox user auth)
 320     (when (string-match "\\(.*\\)@\\(.*\\)" default-server)
 321       ;; case: default-imap4-server is specified like
 322       ;; "hoge%imap.server@gateway".
 323       (setq default-user (elmo-match-string 1 default-server))
 324       (setq default-server (elmo-match-string 2 default-server)))
 325     (setq spec (elmo-network-get-spec
 326                 folder default-server default-port default-tls))
 327     (setq folder (car spec))
 328     (when (string-match
 329            "^\\(%\\)\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?"
 330            folder)
 331       (progn
 332         (setq mailbox (if (match-beginning 2)
 333                           (elmo-match-string 2 folder)
 334                         elmo-default-imap4-mailbox))
 335         (setq user (if (match-beginning 3)
 336                        (elmo-match-substring 3 folder 1)
 337                      default-user))
 338         (setq auth (if (match-beginning 4)
 339                        (elmo-match-substring 4 folder 1)
 340                      elmo-default-imap4-authenticate-type))
 341         (append (list 'imap4
 342                       (elmo-imap4-encode-folder-string mailbox)
 343                       user auth)
 344                 (cdr spec))))))
 345
 346 (defsubst elmo-imap4-spec-mailbox (spec)
 347   (nth 1 spec))
 348
 349 (defsubst elmo-imap4-spec-username (spec)
 350   (nth 2 spec))
 351
 352 (defsubst elmo-imap4-spec-auth (spec)
 353   (nth 3 spec))
 354
 355 (defsubst elmo-imap4-spec-hostname (spec)
 356   (nth 4 spec))
 357
 358 (defsubst elmo-imap4-spec-port (spec)
 359   (nth 5 spec))
 360
 361 (defsubst elmo-imap4-spec-ssl (spec)
 362   (nth 6 spec))
 363
 364 (defsubst elmo-imap4-spec-folder (spec) ;; obsolete
 365   (nth 1 spec))
 366
 367 (defsubst elmo-imap4-connection-get-process (conn)
 368   (nth 1 conn))
 369
 370 (defsubst elmo-imap4-connection-get-buffer (conn)
 371   (nth 0 conn))
 372
 373 (defsubst elmo-imap4-connection-get-cwf (conn)
 374   (nth 2 conn))
 375
 376 (defun elmo-nntp-get-spec (folder)
 377   (let (spec group user)
 378     (setq spec (elmo-network-get-spec folder
 379                                       elmo-default-nntp-server
 380                                       elmo-default-nntp-port
 381                                       elmo-default-nntp-ssl))
 382     (setq folder (car spec))
 383     (when (string-match
 384            "^\\(-\\)\\([^:@!]*\\)\\(:[^/!]+\\)?\\(/[^/:@!]+\\)?"
 385            folder)
 386       (setq group
 387             (if (match-beginning 2)
 388                 (elmo-match-string 2 folder)))
 389       (setq user
 390             (if (match-beginning 3)
 391                 (elmo-match-substring 3 folder 1)
 392               elmo-default-nntp-user))
 393       (append (list 'nntp group user)
 394               (cdr spec)))))
 395
 396 (defsubst elmo-nntp-spec-group (spec)
 397   (nth 1 spec))
 398
 399 (defsubst elmo-nntp-spec-username (spec)
 400   (nth 2 spec))
 401
 402 ;; future use?
 403 ;; (defsubst elmo-nntp-spec-auth (spec))
 404
 405 (defsubst elmo-nntp-spec-hostname (spec)
 406   (nth 3 spec))
 407
 408 (defsubst elmo-nntp-spec-port (spec)
 409   (nth 4 spec))
 410
 411 (defsubst elmo-nntp-spec-ssl (spec)
 412   (nth 5 spec))
 413
 414 (defun elmo-localdir-get-spec (folder)
 415   (let (fld-name path)
 416     (when (string-match
 417            "^\\(\\+\\)\\(.*\\)$"
 418            folder)
 419       (if (eq (length (setq fld-name
 420                             (elmo-match-string 2 folder))) 0)
 421           (setq fld-name "")
 422         )
 423       (if (file-name-absolute-p fld-name)
 424           (setq path (expand-file-name fld-name))
 425         (setq path fld-name))
 426         ;(setq path (expand-file-name fld-name
 427         ;elmo-localdir-folder-path)))
 428       (list (if (elmo-folder-maildir-p folder)
 429                 'maildir
 430               'localdir) path))))
 431
 432 (defun elmo-maildir-get-spec (folder)
 433   (let (fld-name path)
 434     (when (string-match
 435            "^\\(\\.\\)\\(.*\\)$"
 436            folder)
 437       (if (eq (length (setq fld-name
 438                             (elmo-match-string 2 folder))) 0)
 439           (setq fld-name ""))
 440       (if (file-name-absolute-p fld-name)
 441           (setq path (expand-file-name fld-name))
 442         (setq path fld-name))
 443       (list 'maildir path))))
 444
 445 (defun elmo-folder-maildir-p (folder)
 446   (catch 'found
 447     (let ((li elmo-maildir-list))
 448       (while li
 449         (if (string-match (car li) folder)
 450             (throw 'found t))
 451         (setq li (cdr li))))))
 452
 453 (defun elmo-localnews-get-spec (folder)
 454   (let (fld-name)
 455     (when (string-match
 456          "^\\(=\\)\\(.*\\)$"
 457          folder)
 458       (if (eq (length (setq fld-name
 459                             (elmo-match-string 2 folder))) 0)
 460           (setq fld-name "")
 461         )
 462       (list 'localnews
 463             (elmo-replace-in-string fld-name "\\." "/")))))
 464
 465 (defun elmo-cache-get-spec (folder)
 466   (let (fld-name)
 467     (when (string-match
 468          "^\\(!\\)\\(.*\\)$"
 469          folder)
 470       (if (eq (length (setq fld-name
 471                             (elmo-match-string 2 folder))) 0)
 472           (setq fld-name "")
 473         )
 474       (list 'cache
 475             (elmo-replace-in-string fld-name "\\." "/")))))
 476
 477 ;; Archive interface by OKUNISHI Fujikazu <fuji0924@mbox.kyoto-inet.or.jp>
 478 (defun elmo-archive-get-spec (folder)
 479   (require 'elmo-archive)
 480   (let (fld-name type prefix)
 481     (when (string-match
 482            "^\\(\\$\\)\\([^;]*\\);?\\([^;]*\\);?\\([^;]*\\)$"
 483            folder)
 484       ;; Drive letter is OK!
 485       (if (eq (length (setq fld-name
 486                             (elmo-match-string 2 folder))) 0)
 487           (setq fld-name "")
 488         )
 489       (if (eq (length (setq type
 490                             (elmo-match-string 3 folder))) 0)
 491           (setq type (symbol-name elmo-archive-default-type)))
 492       (if (eq (length (setq prefix
 493                             (elmo-match-string 4 folder))) 0)
 494           (setq prefix ""))
 495       (list 'archive fld-name (intern-soft type) prefix))))
 496
 497 (defun elmo-pop3-get-spec (folder)
 498   (let (spec user auth)
 499     (setq spec (elmo-network-get-spec folder
 500                                       elmo-default-pop3-server
 501                                       elmo-default-pop3-port
 502                                       elmo-default-pop3-ssl))
 503     (setq folder (car spec))
 504     (when (string-match
 505            "^\\(&\\)\\([^:/!]*\\)\\(/[^/:@!]+\\)?"
 506            folder)
 507       (setq user (if (match-beginning 2)
 508                      (elmo-match-string 2 folder)))
 509       (if (eq (length user) 0)
 510           (setq user elmo-default-pop3-user))
 511       (setq auth (if (match-beginning 3)
 512                      (elmo-match-substring 3 folder 1)
 513                    elmo-default-pop3-authenticate-type))
 514       (append (list 'pop3 user auth)
 515               (cdr spec)))))
 516
 517 (defsubst elmo-pop3-spec-username (spec)
 518   (nth 1 spec))
 519
 520 (defsubst elmo-pop3-spec-auth (spec)
 521   (nth 2 spec))
 522
 523 (defsubst elmo-pop3-spec-hostname (spec)
 524   (nth 3 spec))
 525
 526 (defsubst elmo-pop3-spec-port (spec)
 527   (nth 4 spec))
 528
 529 (defsubst elmo-pop3-spec-ssl (spec)
 530   (nth 5 spec))
 531
 532 (defun elmo-internal-get-spec (folder)
 533   (if (string-match "\\('\\)\\([^/]*\\)/?\\(.*\\)$" folder)
 534       (let* ((item (downcase (elmo-match-string 2 folder)))
 535              (sym (and (> (length item) 0) (intern item))))
 536         (cond ((or (null sym)
 537                    (eq sym 'mark))
 538                (list 'internal sym (elmo-match-string 3 folder)))
 539               ((eq sym 'cache)
 540                (list 'cache (elmo-match-string 3 folder)))
 541               (t (error "Invalid internal folder spec"))))))
 542
 543 (defun elmo-multi-get-spec (folder)
 544   (save-match-data
 545     (when (string-match
 546            "^\\(\\*\\)\\(.*\\)$"
 547            folder)
 548       (append (list 'multi)
 549               (split-string
 550                (elmo-match-string 2 folder)
 551                ",")))))
 552
 553 (defun elmo-filter-get-spec (folder)
 554   (save-match-data
 555     (when (string-match
 556            "^\\(/\\)\\(.*\\)$"
 557            folder)
 558       (let ((spec (elmo-match-string 2 folder))
 559             filter)
 560         (when (string-match "\\([^/]+\\)/" spec)
 561           (setq filter (elmo-match-string 1 spec))
 562           (setq spec (substring spec (match-end 0))))
 563         (cond
 564          ((string-match "^\\(last\\|first\\):\\(.*\\)$" filter) ; partial
 565           (setq filter (vector 'partial
 566                                (elmo-match-string 1 filter)
 567                                (elmo-match-string 2 filter))))
 568          (t
 569           (setq filter (elmo-parse-search-condition filter))))
 570         (list 'filter filter spec)))))
 571
 572 (defun elmo-pipe-get-spec (folder)
 573   (when (string-match "^\\(|\\)\\([^|]*\\)|\\(.*\\)$" folder)
 574     (list 'pipe
 575           (elmo-match-string 2 folder)
 576           (elmo-match-string 3 folder))))
 577
 578 (defun elmo-folder-get-spec (folder)
 579   "return spec of folder"
 580   (let ((type (elmo-folder-get-type folder)))
 581     (if type
 582         (funcall (intern (concat "elmo-" (symbol-name type) "-get-spec"))
 583                  folder)
 584       (error "%s is not supported folder type" folder))))
 585
 586 (defun elmo-parse-search-condition (condition)
 587   (let ((terms (split-string condition "|")) ; split by OR
 588         term ret-val)
 589     (while terms
 590       (setq term (car terms))
 591       (cond
 592        ((string-match "^\\([a-zA-Z\\-]+\\)=\\(.*\\)$" term)
 593         (if (save-match-data
 594               (string-match "tocc" (elmo-match-string 1 term))) ;; syntax sugar
 595             (setq ret-val (nconc
 596                            ret-val
 597                            (list (vector 'match "to"
 598                                          (elmo-match-string 2 term))
 599                                  (vector 'match "cc"
 600                                          (elmo-match-string 2 term)))))
 601           (setq ret-val (cons (vector 'match
 602                                       (elmo-match-string 1 term)
 603                                       (elmo-match-string 2 term))
 604                               ret-val))))
 605        ((string-match "^\\([a-zA-Z\\-]+\\)!=\\(.*\\)$" term)
 606         (if (save-match-data
 607               (string-match "tocc" (elmo-match-string 1 term))) ;; syntax sugar
 608             (setq ret-val (nconc
 609                            ret-val
 610                            (list (vector 'unmatch "to"
 611                                          (elmo-match-string 2 term))
 612                                  (vector 'unmatch "cc"
 613                                          (elmo-match-string 2 term)))))
 614           (setq ret-val (cons (vector 'unmatch
 615                                       (elmo-match-string 1 term)
 616                                       (elmo-match-string 2 term))
 617                               ret-val))))
 618        ((string-match "^\\(since\\|before\\):\\(.*\\)$" term)
 619         (setq ret-val (cons (vector 'date
 620                                     (elmo-match-string 1 term)
 621                                     (elmo-match-string 2 term))
 622                             ret-val))))
 623       (setq terms (cdr terms)))
 624     ret-val))
 625
 626 (defun elmo-multi-get-real-folder-number (folder number)
 627   (let* ((spec (elmo-folder-get-spec folder))
 628          (flds (cdr spec))
 629          (num number)
 630          (fld (nth (- (/ num elmo-multi-divide-number) 1) flds)))
 631     (cons fld (% num elmo-multi-divide-number))))
 632
 633 (defsubst elmo-buffer-replace (regexp &optional newtext)
 634   (goto-char (point-min))
 635   (while (re-search-forward regexp nil t)
 636     (replace-match (or newtext ""))))
 637
 638 (defsubst elmo-delete-char (char string &optional unibyte)
 639   (save-match-data
 640     (elmo-set-work-buf
 641      (let ((coding-system-for-read 'no-conversion)
 642            (coding-system-for-write 'no-conversion))
 643        (if unibyte (elmo-set-buffer-multibyte nil))
 644        (insert string)
 645        (goto-char (point-min))
 646        (while (search-forward (char-to-string char) nil t)
 647          (replace-match ""))
 648        (buffer-string)))))
 649
 650 (defsubst elmo-delete-cr-get-content-type ()
 651   (save-excursion
 652     (goto-char (point-min))
 653     (while (search-forward "\r\n" nil t)
 654       (replace-match "\n"))
 655     (goto-char (point-min))
 656     (or (std11-field-body "content-type")
 657         t)))
 658
 659 (defun elmo-delete-cr (string)
 660   (save-match-data
 661     (elmo-set-work-buf
 662      (insert string)
 663      (goto-char (point-min))
 664      (while (search-forward "\r\n" nil t)
 665        (replace-match "\n"))
 666      (buffer-string))))
 667
 668 (defun elmo-uniq-list (lst)
 669   "Distractively uniqfy elements of LST."
 670   (let ((tmp lst))
 671     (while tmp (setq tmp (setcdr tmp (and (cdr tmp) (delete (car tmp) (cdr tmp)))))))
 672   lst)
 673
 674 (defun elmo-string-partial-p (string)
 675   (and (stringp string) (string-match "message/partial" string)))
 676
 677 (defun elmo-get-file-string (filename &optional remove-final-newline)
 678   (elmo-set-work-buf
 679    (let (insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 680          insert-file-contents-post-hook)
 681      (when (file-exists-p filename)
 682        (if filename
 683            (as-binary-input-file (insert-file-contents filename)))
 684        (when (and remove-final-newline
 685                   (> (buffer-size) 0)
 686                   (= (char-after (1- (point-max))) ?\n))
 687          (goto-char (point-max))
 688          (delete-backward-char 1))
 689        (buffer-string)))))
 690
 691 (defun elmo-save-string (string filename)
 692   (if string
 693       (elmo-set-work-buf
 694        (as-binary-output-file
 695         (insert string)
 696         (write-region (point-min) (point-max)
 697                       filename nil 'no-msg))
 698        )))
 699
 700 (defun elmo-max-of-list (nlist)
 701   (let ((l nlist)
 702         (max-num 0))
 703     (while l
 704       (if (< max-num (car l))
 705           (setq max-num (car l)))
 706       (setq l (cdr l)))
 707     max-num))
 708
 709 (defun elmo-concat-path (path filename)
 710   (if (not (string= path ""))
 711       (if (string= elmo-path-sep (substring path (- (length path) 1)))
 712           (concat path filename)
 713         (concat path elmo-path-sep filename))
 714     filename))
 715
 716 (defvar elmo-passwd-alist nil)
 717
 718 (defun elmo-passwd-alist-load ()
 719   (save-excursion
 720     (let ((filename (expand-file-name elmo-passwd-alist-file-name
 721                                       elmo-msgdb-dir))
 722           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*"))
 723           insert-file-contents-pre-hook   ; To avoid autoconv-xmas...
 724           insert-file-contents-post-hook
 725           ret-val)
 726       (if (not (file-readable-p filename))
 727           ()
 728         (set-buffer tmp-buffer)
 729         (insert-file-contents filename)
 730         (setq ret-val
 731               (condition-case nil
 732                   (read (current-buffer))
 733                 (error nil nil))))
 734       (kill-buffer tmp-buffer)
 735       ret-val)))
 736
 737 (defun elmo-passwd-alist-save ()
 738   "Save password into file."
 739   (interactive)
 740   (save-excursion
 741     (let ((filename (expand-file-name elmo-passwd-alist-file-name
 742                                       elmo-msgdb-dir))
 743           (tmp-buffer (get-buffer-create " *elmo-passwd-alist-tmp*")))
 744       (set-buffer tmp-buffer)
 745       (erase-buffer)
 746       (prin1 elmo-passwd-alist tmp-buffer)
 747       (princ "\n" tmp-buffer)
 748 ;      (if (and (file-exists-p filename)
 749 ;             (not (equal 384 (file-modes filename))))
 750 ;        (error "%s is not safe.chmod 600 %s!" filename filename))
 751       (if (file-writable-p filename)
 752          (progn
 753            (write-region (point-min) (point-max)
 754                          filename nil 'no-msg)
 755            (set-file-modes filename 384))
 756         (message (format "%s is not writable." filename)))
 757       (kill-buffer tmp-buffer))))
 758
 759 (defun elmo-get-passwd (user-at-host)
 760   "Get password from password pool."
 761   (let (data pass)
 762     (if (not elmo-passwd-alist)
 763         (setq elmo-passwd-alist (elmo-passwd-alist-load)))
 764     (setq data (assoc user-at-host elmo-passwd-alist))
 765     (if data
 766         (elmo-base64-decode-string (cdr data))
 767       (setq pass (elmo-read-passwd (format "Password for %s: "
 768                                            user-at-host) t))
 769       (setq elmo-passwd-alist
 770             (append elmo-passwd-alist
 771                     (list (cons user-at-host
 772                                 (elmo-base64-encode-string pass)))))
 773       pass)))
 774
 775 (defun elmo-remove-passwd (user-at-host)
 776   "Remove password from password pool (for failure)."
 777   (setq elmo-passwd-alist
 778         (delete (assoc user-at-host elmo-passwd-alist)
 779                 elmo-passwd-alist
 780                 )))
 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
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-condition-match (condition)
1218   (let (term)
1219     (catch 'done
1220       (while condition
1221         (goto-char (point-min))
1222         (setq term (car condition))
1223         (cond
1224          ((and (eq (elmo-filter-type term) 'date)
1225                (string= (elmo-filter-key term) "since"))
1226           (let ((date (elmo-date-get-datevec (elmo-filter-value term))))
1227             (if (string<
1228                  (timezone-make-sortable-date (aref date 0)
1229                                               (aref date 1)
1230                                               (aref date 2)
1231                                               (timezone-make-time-string
1232                                                (aref date 3)
1233                                                (aref date 4)
1234                                                (aref date 5)))
1235                  (timezone-make-date-sortable (std11-field-body "date")))
1236                 (throw 'done t))))
1237          ((and (eq (elmo-filter-type term) 'date)
1238                (string= (elmo-filter-key term) "before"))
1239           (let ((date (elmo-date-get-datevec (elmo-filter-value term))))
1240             (if (string<
1241                  (timezone-make-date-sortable (std11-field-body "date"))
1242                  (timezone-make-sortable-date (aref date 0)
1243                                               (aref date 1)
1244                                               (aref date 2)
1245                                               (timezone-make-time-string
1246                                                (aref date 3)
1247                                                (aref date 4)
1248                                                (aref date 5))))
1249                 (throw 'done t))))
1250          ((eq (elmo-filter-type term) 'match)
1251           (if (string= "body" (elmo-filter-key term))
1252               (progn
1253                 (re-search-forward "^$" nil t)     ; goto body
1254                 (if (search-forward (elmo-filter-value term) nil t)
1255                     (throw 'done t)))
1256             (let ((fval (eword-decode-string
1257                          (or (std11-field-body (elmo-filter-key term)) ""))))
1258               (if (and fval (string-match (elmo-filter-value term)
1259                                           fval))
1260                   (throw 'done t)))))
1261          ((eq (elmo-filter-type term) 'unmatch)
1262           (if (string= "body" (elmo-filter-key term))
1263               (progn
1264                 (re-search-forward "^$" nil t)     ; goto body
1265                 (if (not (search-forward (elmo-filter-value term) nil t))
1266                     (throw 'done t)))
1267             (let ((fval (eword-decode-string
1268                          (or (std11-field-body (elmo-filter-key term)) ""))))
1269               (if fval
1270                   (if (not (string-match (elmo-filter-value term)
1271                                          fval))
1272                       (throw 'done t))
1273                 (throw 'done t)))))) ; OK?
1274         (setq condition (cdr condition)))
1275       (throw 'done nil))))
1276
1277 (defsubst elmo-file-field-condition-match (file condition)
1278   (elmo-set-work-buf
1279    (as-binary-input-file
1280     (insert-file-contents file))
1281    (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1282    (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
1283    (elmo-buffer-field-condition-match condition)))
1284
1285 (defun elmo-cross-device-link-error-p (err)
1286   (let ((errobj err)
1287         cur)
1288     (catch 'done
1289       (while errobj
1290         (if (and (stringp (setq cur (car errobj)))
1291                  (or (string-match "cross-device" cur)
1292                      (string-match "operation not supported" cur)))
1293             (throw 'done t))
1294         (setq errobj (cdr errobj)))
1295       nil)))
1296
1297 (defmacro elmo-get-hash-val (string hashtable)
1298   (let ((sym (list 'intern-soft string hashtable)))
1299     (list 'if (list 'boundp sym)
1300        (list 'symbol-value sym))))
1301
1302 (defmacro elmo-set-hash-val (string value hashtable)
1303   (list 'set (list 'intern string hashtable) value))
1304
1305 ;; Make a hash table (default and minimum size is 1024).
1306 (defun elmo-make-hash (&optional hashsize)
1307   (make-vector (if hashsize (max (elmo-create-hash-size hashsize) 1024) 1024) 0))
1308
1309 (defsubst elmo-mime-string (string)
1310   "Normalize MIME encoded string."
1311     (and string
1312          (let (str)
1313            (elmo-set-work-buf
1314             (elmo-set-buffer-multibyte default-enable-multibyte-characters)
1315             (setq str (eword-decode-string
1316                        (decode-mime-charset-string string elmo-mime-charset)))
1317             (setq str (encode-mime-charset-string str elmo-mime-charset))
1318             (elmo-set-buffer-multibyte nil)
1319             str))))
1320
1321 (defsubst elmo-collect-field (beg end downcase-field-name)
1322   (save-excursion
1323     (save-restriction
1324       (narrow-to-region beg end)
1325       (goto-char (point-min))
1326       (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1327             dest name body)
1328         (while (re-search-forward regexp nil t)
1329           (setq name (buffer-substring-no-properties
1330                       (match-beginning 1)(1- (match-end 1))))
1331           (if downcase-field-name
1332               (setq name (downcase name)))
1333           (setq body (buffer-substring-no-properties
1334                       (match-end 0) (std11-field-end)))
1335           (or (assoc name dest)
1336               (setq dest (cons (cons name body) dest))))
1337         dest))))
1338
1339 (defsubst elmo-collect-field-from-string (string downcase-field-name)
1340   (with-temp-buffer
1341     (insert string)
1342     (goto-char (point-min))
1343     (let ((regexp (concat "\\(" std11-field-head-regexp "\\)[ \t]*"))
1344           dest name body)
1345       (while (re-search-forward regexp nil t)
1346         (setq name (buffer-substring-no-properties
1347                     (match-beginning 1)(1- (match-end 1))))
1348         (if downcase-field-name
1349             (setq name (downcase name)))
1350         (setq body (buffer-substring-no-properties
1351                     (match-end 0) (std11-field-end)))
1352         (or (assoc name dest)
1353             (setq dest (cons (cons name body) dest))))
1354       dest)))
1355
1356 (defun elmo-create-hash-size (min)
1357   (let ((i 1))
1358     (while (< i min)
1359       (setq i (* 2 i)))
1360     i))
1361
1362 (defun elmo-safe-filename (folder)
1363   (elmo-replace-in-string
1364    (elmo-replace-in-string
1365     (elmo-replace-in-string folder "/" " ")
1366     ":" "__")
1367    "|" "_or_"))
1368
1369 (defvar elmo-msgid-replace-chars nil)
1370
1371 (defsubst elmo-replace-msgid-as-filename (msgid)
1372   "Replace message-id string as filename."
1373   (setq msgid (elmo-replace-in-string msgid " " "  "))
1374   (if (null elmo-msgid-replace-chars)
1375       (setq elmo-msgid-replace-chars
1376             (regexp-quote (mapconcat
1377                            'car elmo-msgid-replace-string-alist ""))))
1378   (while (string-match (concat "[" elmo-msgid-replace-chars "]")
1379                        msgid)
1380     (setq msgid (concat
1381                  (substring msgid 0 (match-beginning 0))
1382                  (cdr (assoc
1383                        (substring msgid
1384                                   (match-beginning 0) (match-end 0))
1385                        elmo-msgid-replace-string-alist))
1386                  (substring msgid (match-end 0)))))
1387   msgid)
1388
1389 (defsubst elmo-recover-msgid-from-filename (filename)
1390   "Recover Message-ID from filename."
1391   (let (tmp result)
1392     (while (string-match " " filename)
1393       (setq tmp (substring filename
1394                            (match-beginning 0)
1395                            (+ (match-end 0) 1)))
1396       (if (string= tmp "  ")
1397           (setq tmp " ")
1398         (setq tmp (car (rassoc tmp
1399                                elmo-msgid-replace-string-alist))))
1400       (setq result
1401             (concat result
1402                     (substring filename 0 (match-beginning 0))
1403                     tmp))
1404       (setq filename (substring filename (+ (match-end 0) 1))))
1405     (concat result filename)))
1406
1407 (defsubst elmo-copy-file (src dst)
1408   (condition-case err
1409       (elmo-add-name-to-file src dst t)
1410     (error (if (elmo-cross-device-link-error-p err)
1411                (copy-file src dst t)
1412              (error "copy file failed")))))
1413
1414 (defmacro elmo-buffer-exists-p (buffer)
1415   (` (when (, buffer)
1416        (funcall (if (stringp (, buffer)) 'get-buffer 'buffer-name)
1417                 (, buffer)))))
1418
1419 (defmacro elmo-kill-buffer (buffer)
1420   (` (when (elmo-buffer-exists-p (, buffer))
1421        (kill-buffer (, buffer)))))
1422
1423 (defun elmo-delete-lists (keys list)
1424   "Delete all entries in LIST that equal to KEYS."
1425   (while keys
1426     (setq list (delete (car keys) list))
1427     (setq keys (cdr keys)))
1428   list)
1429
1430 (defun elmo-delete-if (pred lst)
1431   "Returns new list contains items which don't satisfy PRED in LST."
1432   (let (result)
1433     (while lst
1434       (unless (funcall pred (car lst))
1435         (setq result (nconc result (list (car lst)))))
1436       (setq lst (cdr lst)))
1437     result))
1438
1439 (defun elmo-list-delete (list1 list2)
1440   "Any element of list1 is deleted from list2."
1441   (while list1
1442     (setq list2 (delete (car list1) list2))
1443     (setq list1 (cdr list1)))
1444   list2)
1445
1446 (defun elmo-list-member (list1 list2)
1447   "If any element of list1 is member of list2, returns t."
1448   (catch 'done
1449     (while list1
1450       (if (member (car list1) list2)
1451           (throw 'done t))
1452       (setq list1 (cdr list1)))))
1453
1454 (defun elmo-count-matches (regexp beg end)
1455   (let ((count 0))
1456     (save-excursion
1457       (goto-char beg)
1458       (while (re-search-forward regexp end t)
1459         (setq count (1+ count)))
1460       count)))
1461
1462 (if (fboundp 'display-error)
1463     (defalias 'elmo-display-error 'display-error)
1464   (defun elmo-display-error (error-object stream)
1465     "a tiny function to display error-object to the stream."
1466     (let ((first t)
1467           (errobj error-object)
1468           err-mes)
1469       (while errobj
1470         (setq err-mes (concat err-mes (format
1471                                        (if (stringp (car errobj))
1472                                            "%s"
1473                                          (if (boundp 'nemacs-version)
1474                                              "%s"
1475                                            "%S")) (car errobj))))
1476         (setq errobj (cdr errobj))
1477         (if errobj (setq err-mes (concat err-mes (if first ": " ", "))))
1478         (setq first nil))
1479       (princ err-mes stream))))
1480
1481 (if (fboundp 'lprogress-display)
1482     (defalias 'elmo-display-progress 'lprogress-display)
1483   (defun elmo-display-progress (label format &optional value &rest args)
1484     "Print a progress message."
1485     (if (and (null format) (null args))
1486         (message nil)
1487       (apply (function message) (concat format " %d%%")
1488              (nconc args (list value))))))
1489
1490 (defun elmo-time-expire (before-time diff-time)
1491   (let* ((current (current-time))
1492          (rest (when (< (nth 1 current) (nth 1 before-time))
1493                  (expt 2 16)))
1494          diff)
1495     (setq diff
1496           (list (- (+ (car current) (if rest -1 0)) (car before-time))
1497                 (- (+ (or rest 0) (nth 1 current)) (nth 1 before-time))))
1498     (and (eq (car diff) 0)
1499          (< diff-time (nth 1 diff)))))
1500
1501 (defun elmo-open-network-stream (name buffer host service ssl)
1502   (let ((auto-plugged (and elmo-auto-change-plugged
1503                            (> elmo-auto-change-plugged 0)))
1504         process)
1505     (if (eq ssl 'starttls)
1506         (require 'starttls)
1507       (if ssl (require 'ssl)))
1508     (condition-case err
1509         (let (process-connection-type)
1510           (setq process
1511                 (if (eq ssl 'starttls)
1512                     (starttls-open-stream name buffer host service)
1513                   (if ssl
1514                       (open-ssl-stream name buffer host service)
1515                     (open-network-stream name buffer host service)))))
1516       (error
1517        (when auto-plugged
1518          (elmo-set-plugged nil host service (current-time))
1519          (message "Auto plugged off at %s:%d" host service)
1520          (sit-for 1))
1521        (signal (car err) (cdr err))))
1522     (when process
1523       (process-kill-without-query process)
1524       (when auto-plugged
1525         (elmo-set-plugged t host service))
1526       process)))
1527
1528 (if (fboundp 'std11-fetch-field)
1529     (defalias 'elmo-field-body 'std11-fetch-field) ;;no narrow-to-region
1530   (defalias 'elmo-field-body 'std11-field-body))
1531
1532 (defmacro elmo-string (string)
1533   "String without text property"
1534   (` (let ((obj (copy-sequence (, string))))
1535        (set-text-properties 0 (length obj) nil obj)
1536        obj)))
1537
1538 (defun elmo-y-or-n-p (prompt &optional auto default)
1539   "Same as `y-or-n-p'.
1540 But if optional argument AUTO is non-nil, DEFAULT is returned."
1541   (if auto
1542       default
1543     (y-or-n-p prompt)))
1544
1545 (defun elmo-string-member (string slist)
1546   "Returns t if STRING is a member of the SLIST."
1547   (catch 'found
1548     (while slist
1549       (if (and (stringp (car slist))
1550                (string= string (car slist)))
1551           (throw 'found t))
1552       (setq slist (cdr slist)))))
1553
1554 (defun elmo-string-match-member (str list &optional case-ignore)
1555   (let ((case-fold-search case-ignore))
1556     (catch 'member
1557       (while list
1558         (if (string-match (car list) str)
1559             (throw 'member (car list)))
1560         (setq list (cdr list))))))
1561
1562 (defsubst elmo-string-delete-match (string pos)
1563   (concat (substring string
1564                      0 (match-beginning pos))
1565           (substring string
1566                      (match-end pos)
1567                      (length string))))
1568
1569 (defun elmo-string-match-assoc (key alist &optional case-ignore)
1570   (let ((case-fold-search case-ignore)
1571         a)
1572     (catch 'loop
1573       (while alist
1574         (setq a (car alist))
1575         (if (and (consp a)
1576                  (stringp (car a))
1577                  (string-match key (car a)))
1578             (throw 'loop a))
1579         (setq alist (cdr alist))))))
1580
1581 (defun elmo-string-matched-assoc (key alist &optional case-ignore)
1582   (let ((case-fold-search case-ignore)
1583         a)
1584     (catch 'loop
1585       (while alist
1586         (setq a (car alist))
1587         (if (and (consp a)
1588                  (stringp (car a))
1589                  (string-match (car a) key))
1590             (throw 'loop a))
1591         (setq alist (cdr alist))))))
1592
1593 (defun elmo-string-assoc (key alist)
1594   (let (a)
1595     (catch 'loop
1596       (while alist
1597         (setq a (car alist))
1598         (if (and (consp a)
1599                  (stringp (car a))
1600                  (string= key (car a)))
1601             (throw 'loop a))
1602         (setq alist (cdr alist))))))
1603
1604 (defun elmo-string-rassoc (key alist)
1605   (let (a)
1606     (catch 'loop
1607       (while alist
1608         (setq a (car alist))
1609         (if (and (consp a)
1610                  (stringp (cdr a))
1611                  (string= key (cdr a)))
1612             (throw 'loop a))
1613         (setq alist (cdr alist))))))
1614
1615 (provide 'elmo-util)
1616
1617 ;;; elmo-util.el ends here