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