elmo/elmo-imap4.el

   1 ;;; elmo-imap4.el -- IMAP4 Interface for ELMO.
   2
   3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
   4 ;; Copyright (C) 1999,2000      Kenichi OKADA <okada@opaopa.org>
   5 ;; Copyright (C) 2000           OKAZAKI Tetsurou <okazaki@be.to>
   6 ;; Copyright (C) 2000           Daiki Ueno <ueno@unixuser.org>
   7
   8 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
   9 ;;      Kenichi OKADA <okada@opaopa.org>
  10 ;;      OKAZAKI Tetsurou <okazaki@be.to>
  11 ;;      Daiki Ueno <ueno@unixuser.org>
  12 ;; Keywords: mail, net news
  13
  14 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
  15
  16 ;; This program is free software; you can redistribute it and/or modify
  17 ;; it under the terms of the GNU General Public License as published by
  18 ;; the Free Software Foundation; either version 2, or (at your option)
  19 ;; any later version.
  20 ;;
  21 ;; This program is distributed in the hope that it will be useful,
  22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 ;; GNU General Public License for more details.
  25 ;;
  26 ;; You should have received a copy of the GNU General Public License
  27 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  28 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  29 ;; Boston, MA 02111-1307, USA.
  30 ;;
  31
  32 ;;; Commentary:
  33 ;;
  34 ;; Origin of IMAP parser part is imap.el, included in Gnus.
  35 ;;
  36 ;;    Copyright (C) 1998, 1999, 2000
  37 ;;    Free Software Foundation, Inc.
  38 ;;    Author: Simon Josefsson <jas@pdc.kth.se>
  39 ;;
  40
  41 (require 'elmo-vars)
  42 (require 'elmo-util)
  43 (require 'elmo-msgdb)
  44 (require 'elmo-date)
  45 (require 'elmo-cache)
  46 (require 'elmo-net)
  47 (require 'utf7)
  48
  49 ;;; Code:
  50 (eval-when-compile (require 'cl))
  51
  52 (defvar elmo-imap4-use-lock t
  53   "USE IMAP4 with locking process.")
  54 ;;
  55 ;;; internal variables
  56 ;;
  57 (defvar elmo-imap4-seq-prefix "elmo-imap4")
  58 (defvar elmo-imap4-seqno 0)
  59 (defvar elmo-imap4-use-uid t
  60   "Use UID as message number.")
  61
  62 (defvar elmo-imap4-current-response nil)
  63 (defvar elmo-imap4-status nil)
  64 (defvar elmo-imap4-reached-tag "elmo-imap40")
  65
  66 ;;; buffer local variables
  67
  68 (defvar elmo-imap4-extra-namespace-alist
  69   '(("^{.*/nntp}.*$" . ".")) ; Default is for UW's remote nntp mailbox...
  70   "Extra namespace alist.  A list of cons cell like: (REGEXP . DELIMITER).")
  71 (defvar elmo-imap4-default-hierarchy-delimiter "/")
  72
  73 (defvar elmo-imap4-server-capability nil)
  74 (defvar elmo-imap4-server-namespace nil)
  75
  76 (defvar elmo-imap4-parsing nil) ; indicates parsing.
  77
  78 (defvar elmo-imap4-fetch-callback nil)
  79 (defvar elmo-imap4-fetch-callback-data nil)
  80 (defvar elmo-imap4-status-callback nil)
  81 (defvar elmo-imap4-status-callback-data nil)
  82
  83 (defvar elmo-imap4-server-diff-async-callback nil)
  84 (defvar elmo-imap4-server-diff-async-callback-data nil)
  85
  86 ;;; progress...(no use?)
  87 (defvar elmo-imap4-count-progress nil)
  88 (defvar elmo-imap4-count-progress-message nil)
  89 (defvar elmo-imap4-progress-count nil)
  90
  91 ;;; XXX Temporal implementation
  92 (defvar elmo-imap4-current-msgdb nil)
  93
  94 (defvar elmo-imap4-local-variables
  95   '(elmo-imap4-status
  96     elmo-imap4-current-response
  97     elmo-imap4-seqno
  98     elmo-imap4-parsing
  99     elmo-imap4-reached-tag
 100     elmo-imap4-count-progress
 101     elmo-imap4-count-progress-message
 102     elmo-imap4-progress-count
 103     elmo-imap4-fetch-callback
 104     elmo-imap4-fetch-callback-data
 105     elmo-imap4-status-callback
 106     elmo-imap4-status-callback-data
 107     elmo-imap4-current-msgdb))
 108
 109 (defvar elmo-imap4-display-literal-progress nil)
 110 ;;;;
 111
 112 (defconst elmo-imap4-quoted-specials-list '(?\\ ?\"))
 113
 114 (defconst elmo-imap4-non-atom-char-regex
 115   (eval-when-compile
 116     (concat "[^" "]!#$&'+,./0-9:;<=>?@A-Z[^_`a-z|}~-" "]")))
 117
 118 (defconst elmo-imap4-non-text-char-regex
 119   (eval-when-compile
 120     (concat "[^"
 121             "]\x01-\x09\x0b\x0c\x0e-\x1f\x7f !\"#$%&'()*+,./0-9:;<=>?@A-Z[\\^_`a-z{|}~-"
 122             "]")))
 123
 124 (defconst elmo-imap4-literal-threshold 1024
 125  "Limitation of characters that can be used in a quoted string.")
 126
 127 ;; For debugging.
 128 (defvar elmo-imap4-debug nil
 129   "Non-nil forces IMAP4 folder as debug mode.
 130 Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"")
 131
 132 (defvar elmo-imap4-debug-inhibit-logging nil)
 133
 134 ;;;
 135
 136 (eval-and-compile
 137   (luna-define-class elmo-imap4-session (elmo-network-session)
 138                      (capability current-mailbox read-only))
 139   (luna-define-internal-accessors 'elmo-imap4-session))
 140
 141 ;;; imap4 spec
 142
 143 (defsubst elmo-imap4-spec-mailbox (spec)
 144   (nth 1 spec))
 145
 146 (defsubst elmo-imap4-spec-username (spec)
 147   (nth 2 spec))
 148
 149 (defsubst elmo-imap4-spec-auth (spec)
 150   (nth 3 spec))
 151
 152 (defsubst elmo-imap4-spec-hostname (spec)
 153   (nth 4 spec))
 154
 155 (defsubst elmo-imap4-spec-port (spec)
 156   (nth 5 spec))
 157
 158 (defsubst elmo-imap4-spec-stream-type (spec)
 159   (nth 6 spec))
 160
 161
 162 ;;; Debug
 163
 164 (defsubst elmo-imap4-debug (message &rest args)
 165   (if elmo-imap4-debug
 166       (with-current-buffer (get-buffer-create "*IMAP4 DEBUG*")
 167         (goto-char (point-max))
 168         (if elmo-imap4-debug-inhibit-logging
 169             (insert "NO LOGGING\n")
 170           (insert (apply 'format message args) "\n")))))
 171
 172 ;;; Response
 173
 174 (defmacro elmo-imap4-response-continue-req-p (response)
 175   "Returns non-nil if RESPONSE is '+' response."
 176   (` (assq 'continue-req (, response))))
 177
 178 (defmacro elmo-imap4-response-ok-p (response)
 179   "Returns non-nil if RESPONSE is an 'OK' response."
 180   (` (assq 'ok (, response))))
 181
 182 (defmacro elmo-imap4-response-bye-p (response)
 183   "Returns non-nil if RESPONSE is an 'BYE' response."
 184   (` (assq 'bye (, response))))
 185
 186 (defmacro elmo-imap4-response-value (response symbol)
 187   "Get value of the SYMBOL from RESPONSE."
 188   (` (nth 1 (assq (, symbol) (, response)))))
 189
 190 (defsubst elmo-imap4-response-value-all (response symbol)
 191   "Get all value of the SYMBOL from RESPONSE."
 192   (let (matched)
 193     (while response
 194       (if (eq (car (car response)) symbol)
 195           (setq matched (nconc matched (nth 1 (car response)))))
 196       (setq response (cdr response)))
 197     matched))
 198
 199 (defmacro elmo-imap4-response-error-text (response)
 200   "Returns text of NO, BAD, BYE response."
 201   (` (nth 1 (or (elmo-imap4-response-value (, response) 'no)
 202                 (elmo-imap4-response-value (, response) 'bad)
 203                 (elmo-imap4-response-value (, response) 'bye)))))
 204
 205 (defmacro elmo-imap4-response-bodydetail-text (response)
 206   "Returns text of BODY[section]<partial>."
 207   (` (nth 3 (assq 'bodydetail (, response)))))
 208
 209 ;;; Session commands.
 210
 211 ; (defun elmo-imap4-send-command-wait (session command)
 212 ;   "Send COMMAND to the SESSION and wait for response.
 213 ; Returns RESPONSE (parsed lisp object) of IMAP session."
 214 ;   (elmo-imap4-read-response session
 215 ;                           (elmo-imap4-send-command
 216 ;                            session
 217 ;                            command)))
 218
 219 (defun elmo-imap4-send-command-wait (session command)
 220   "Send COMMAND to the SESSION.
 221 Returns RESPONSE (parsed lisp object) of IMAP session.
 222 If response is not `OK', causes error with IMAP response text."
 223   (elmo-imap4-accept-ok session
 224                         (elmo-imap4-send-command
 225                          session
 226                          command)))
 227
 228 (defun elmo-imap4-send-command (session command)
 229   "Send COMMAND to the SESSION.
 230 Returns a TAG string which is assigned to the COMAND."
 231   (let* ((command-args (if (listp command)
 232                            command
 233                          (list command)))
 234          (process (elmo-network-session-process-internal session))
 235          cmdstr tag token kind)
 236     (with-current-buffer (process-buffer process)
 237       (setq tag (concat elmo-imap4-seq-prefix
 238                         (number-to-string
 239                          (setq elmo-imap4-seqno (+ 1 elmo-imap4-seqno)))))
 240       (setq cmdstr (concat tag " "))
 241       ;; (erase-buffer) No need.
 242       (goto-char (point-min))
 243       (if (elmo-imap4-response-bye-p elmo-imap4-current-response)
 244           (signal 'elmo-imap4-bye-error
 245                   (list (elmo-imap4-response-error-text
 246                          elmo-imap4-current-response))))
 247       (setq elmo-imap4-current-response nil)
 248       (if elmo-imap4-parsing
 249           (error "IMAP process is running. Please wait (or plug again.)"))
 250       (setq elmo-imap4-parsing t)
 251       (elmo-imap4-debug "<-(%s)- %s" tag command)
 252       (while (setq token (car command-args))
 253         (cond ((stringp token)   ; formatted
 254                (setq cmdstr (concat cmdstr token)))
 255               ((listp token)     ; unformatted
 256                (setq kind (car token))
 257                (cond ((eq kind 'atom)
 258                       (setq cmdstr (concat cmdstr (nth 1 token))))
 259                      ((eq kind 'quoted)
 260                       (setq cmdstr (concat
 261                                     cmdstr
 262                                     (elmo-imap4-format-quoted (nth 1 token)))))
 263                      ((eq kind 'literal)
 264                       (setq cmdstr (concat cmdstr
 265                                            (format "{%d}" (nth 2 token))))
 266                       (process-send-string process cmdstr)
 267                       (process-send-string process "\r\n")
 268                       (setq cmdstr nil)
 269                       (elmo-imap4-accept-continue-req session)
 270                       (cond ((stringp (nth 1 token))
 271                              (setq cmdstr (nth 1 token)))
 272                             ((bufferp (nth 1 token))
 273                              (with-current-buffer (nth 1 token)
 274                                (process-send-region
 275                                 process
 276                                 (point-min)
 277                                 (+ (point-min) (nth 2 token)))))
 278                             (t
 279                              (error "Wrong argument for literal"))))
 280                      (t
 281                       (error "Unknown token kind %s" kind))))
 282               (t
 283                (error "Invalid argument")))
 284         (setq command-args (cdr command-args)))
 285       (if cmdstr
 286           (process-send-string process cmdstr))
 287       (process-send-string process "\r\n")
 288       tag)))
 289
 290 (defun elmo-imap4-send-string (session string)
 291   "Send STRING to the SESSION."
 292   (with-current-buffer (process-buffer
 293                         (elmo-network-session-process-internal session))
 294     (setq elmo-imap4-current-response nil)
 295     (goto-char (point-min))
 296     (elmo-imap4-debug "<-- %s" string)
 297     (process-send-string (elmo-network-session-process-internal session)
 298                          string)
 299     (process-send-string (elmo-network-session-process-internal session)
 300                          "\r\n")))
 301
 302 (defun elmo-imap4-read-response (session tag)
 303   "Read parsed response from SESSION.
 304 TAG is the tag of the command"
 305   (with-current-buffer (process-buffer
 306                         (elmo-network-session-process-internal session))
 307     (while (not (or (string= tag elmo-imap4-reached-tag)
 308                     (elmo-imap4-response-bye-p elmo-imap4-current-response)))
 309       (when (memq (process-status
 310                    (elmo-network-session-process-internal session))
 311                   '(open run))
 312         (accept-process-output (elmo-network-session-process-internal session)
 313                                1)))
 314     (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response))
 315     (setq elmo-imap4-parsing nil)
 316     elmo-imap4-current-response))
 317
 318 (defsubst elmo-imap4-read-untagged (process)
 319   (with-current-buffer (process-buffer process)
 320     (while (not elmo-imap4-current-response)
 321       (accept-process-output process 1))
 322     (elmo-imap4-debug "=>%s" (prin1-to-string elmo-imap4-current-response))
 323     elmo-imap4-current-response))
 324
 325 (defun elmo-imap4-read-continue-req (session)
 326   "Returns a text following to continue-req in SESSION.
 327 If response is not `+' response, returns nil."
 328   (elmo-imap4-response-value
 329    (elmo-imap4-read-untagged
 330     (elmo-network-session-process-internal session))
 331    'continue-req))
 332
 333 (defun elmo-imap4-accept-continue-req (session)
 334   "Returns non-nil if `+' (continue-req) response is arrived in SESSION.
 335 If response is not `+' response, cause an error."
 336   (let (response)
 337     (setq response
 338           (elmo-imap4-read-untagged
 339            (elmo-network-session-process-internal session)))
 340     (or (elmo-imap4-response-continue-req-p response)
 341         (error "IMAP error: %s"
 342                (or (elmo-imap4-response-error-text response)
 343                    "No continut-req from server.")))))
 344
 345 (defun elmo-imap4-read-ok (session tag)
 346   "Returns non-nil if `OK' response of the command with TAG is arrived
 347 in SESSION. If response is not `OK' response, returns nil."
 348   (elmo-imap4-response-ok-p
 349    (elmo-imap4-read-response session tag)))
 350
 351 (defun elmo-imap4-accept-ok (session tag)
 352   "Accept only `OK' response from SESSION.
 353 If response is not `OK' response, causes error with IMAP response text."
 354   (let ((response (elmo-imap4-read-response session tag)))
 355     (if (elmo-imap4-response-ok-p response)
 356         response
 357       (if (elmo-imap4-response-bye-p response)
 358           (signal 'elmo-imap4-bye-error
 359                   (list (elmo-imap4-response-error-text response)))
 360         (error "IMAP error: %s"
 361                (or (elmo-imap4-response-error-text response)
 362                    "No `OK' response from server."))))))
 363 ;;;
 364
 365 (defun elmo-imap4-session-check (session)
 366   (with-current-buffer (elmo-network-session-buffer session)
 367     (setq elmo-imap4-fetch-callback nil)
 368     (setq elmo-imap4-fetch-callback-data nil))
 369   (elmo-imap4-send-command-wait session "check"))
 370
 371 (defun elmo-imap4-atom-p (string)
 372   "Return t if STRING is an atom defined in rfc2060."
 373   (if (string= string "")
 374       nil
 375     (save-match-data
 376       (not (string-match elmo-imap4-non-atom-char-regex string)))))
 377
 378 (defun elmo-imap4-quotable-p (string)
 379   "Return t if STRING can be formatted as a quoted defined in rfc2060."
 380   (save-match-data
 381     (not (string-match elmo-imap4-non-text-char-regex string))))
 382
 383 (defun elmo-imap4-nil (string)
 384   "Return a list represents the special atom \"NIL\" defined in rfc2060, \
 385 if STRING is nil.
 386 Otherwise return nil."
 387   (if (eq string nil)
 388       (list 'atom "NIL")))
 389
 390 (defun elmo-imap4-atom (string)
 391   "Return a list represents STRING as an atom defined in rfc2060.
 392 Return nil if STRING is not an atom.  See `elmo-imap4-atom-p'."
 393   (if (elmo-imap4-atom-p string)
 394       (list 'atom string)))
 395
 396 (defun elmo-imap4-quoted (string)
 397   "Return a list represents STRING as a quoted defined in rfc2060.
 398 Return nil if STRING can not be formatted as a quoted.  See `elmo-imap4-quotable-p'."
 399   (if (elmo-imap4-quotable-p string)
 400       (list 'quoted string)))
 401
 402 (defun elmo-imap4-literal-1 (string-or-buffer length)
 403   "Internal function for `elmo-imap4-literal' and `elmo-imap4-buffer-literal'.
 404 Return a list represents STRING-OR-BUFFER as a literal defined in rfc2060.
 405 STRING-OR-BUFFER must be an encoded string or a single-byte string or a single-byte buffer.
 406 LENGTH must be the number of octets for STRING-OR-BUFFER."
 407   (list 'literal string-or-buffer length))
 408
 409 (defun elmo-imap4-literal (string)
 410   "Return a list represents STRING as a literal defined in rfc2060.
 411 STRING must be an encoded or a single-byte string."
 412   (elmo-imap4-literal-1 string (length string)))
 413
 414 (defun elmo-imap4-buffer-literal (buffer)
 415   "Return a list represents BUFFER as a literal defined in rfc2060.
 416 BUFFER must be a single-byte buffer."
 417   (elmo-imap4-literal-1 buffer (with-current-buffer buffer
 418                                  (buffer-size))))
 419
 420 (defun elmo-imap4-string-1 (string length)
 421   "Internal function for `elmo-imap4-string' and `elmo-imap4-buffer-string'.
 422 Return a list represents STRING as a string defined in rfc2060.
 423 STRING must be an encoded or a single-byte string.
 424 LENGTH must be the number of octets for STRING."
 425   (or (elmo-imap4-quoted string)
 426       (elmo-imap4-literal-1 string length)))
 427
 428 (defun elmo-imap4-string (string)
 429   "Return a list represents STRING as a string defined in rfc2060.
 430 STRING must be an encoded or a single-byte string."
 431   (let ((length (length string)))
 432     (if (< elmo-imap4-literal-threshold length)
 433         (elmo-imap4-literal-1 string length)
 434       (elmo-imap4-string-1 string length))))
 435
 436 (defun elmo-imap4-buffer-string (buffer)
 437   "Return a list represents BUFFER as a string defined in rfc2060.
 438 BUFFER must be a single-byte buffer."
 439   (let ((length (with-current-buffer buffer
 440                   (buffer-size))))
 441     (if (< elmo-imap4-literal-threshold length)
 442         (elmo-imap4-literal-1 buffer length)
 443       (elmo-imap4-string-1 (with-current-buffer buffer
 444                              (buffer-string))
 445                            length))))
 446
 447 (defun elmo-imap4-astring-1 (string length)
 448   "Internal function for `elmo-imap4-astring' and `elmo-imap4-buffer-astring'.
 449 Return a list represents STRING as an astring defined in rfc2060.
 450 STRING must be an encoded or a single-byte string.
 451 LENGTH must be the number of octets for STRING."
 452   (or (elmo-imap4-atom string)
 453       (elmo-imap4-string-1 string length)))
 454
 455 (defun elmo-imap4-astring (string)
 456   "Return a list represents STRING as an astring defined in rfc2060.
 457 STRING must be an encoded or a single-byte string."
 458   (let ((length (length string)))
 459     (if (< elmo-imap4-literal-threshold length)
 460         (elmo-imap4-literal-1 string length)
 461       (elmo-imap4-astring-1 string length))))
 462
 463 (defun elmo-imap4-buffer-astring (buffer)
 464   "Return a list represents BUFFER as an astring defined in rfc2060.
 465 BUFFER must be a single-byte buffer."
 466   (let ((length (with-current-buffer buffer
 467                   (buffer-size))))
 468     (if (< elmo-imap4-literal-threshold length)
 469         (elmo-imap4-literal-1 buffer length)
 470       (elmo-imap4-astring-1 (with-current-buffer buffer
 471                               (buffer-string))
 472                             length))))
 473
 474 (defun elmo-imap4-nstring (string)
 475   "Return a list represents STRING as a nstring defined in rfc2060.
 476 STRING must be an encoded or a single-byte string."
 477    (or (elmo-imap4-nil string)
 478        (elmo-imap4-string string)))
 479
 480 (defun elmo-imap4-buffer-nstring (buffer)
 481   "Return a list represents BUFFER as a nstring defined in rfc2060.
 482 BUFFER must be a single-byte buffer."
 483    (or (elmo-imap4-nil buffer)
 484        (elmo-imap4-buffer-string buffer)))
 485
 486 (defalias 'elmo-imap4-mailbox 'elmo-imap4-astring)
 487 (defalias 'elmo-imap4-field-body 'elmo-imap4-astring)
 488 (defalias 'elmo-imap4-userid 'elmo-imap4-astring)
 489 (defalias 'elmo-imap4-password 'elmo-imap4-astring)
 490
 491 (defun elmo-imap4-format-quoted (string)
 492   "Return STRING in a form of the quoted-string defined in rfc2060."
 493   (concat "\""
 494           (std11-wrap-as-quoted-pairs string elmo-imap4-quoted-specials-list)
 495           "\""))
 496
 497 (defsubst elmo-imap4-response-get-selectable-mailbox-list (response)
 498   (delq nil
 499         (mapcar
 500          (lambda (entry)
 501            (if (and (eq 'list (car entry))
 502                     (not (member "\\NoSelect" (nth 1 (nth 1 entry)))))
 503                (car (nth 1 entry))))
 504          response)))
 505
 506 ;;; Backend methods.
 507 (defun elmo-imap4-list-folders (spec &optional hierarchy)
 508   (let* ((root (elmo-imap4-spec-mailbox spec))
 509          (session (elmo-imap4-get-session spec))
 510          (delim (or
 511                  (cdr
 512                   (elmo-string-matched-assoc
 513                    root
 514                    (with-current-buffer (elmo-network-session-buffer session)
 515                      elmo-imap4-server-namespace)))
 516                  elmo-imap4-default-hierarchy-delimiter))
 517          result append-serv type)
 518     ;; Append delimiter
 519     (if (and root
 520              (not (string= root ""))
 521              (not (string-match (concat "\\(.*\\)"
 522                                         (regexp-quote delim)
 523                                         "\\'")
 524                                 root)))
 525         (setq root (concat root delim)))
 526     (setq result (elmo-imap4-response-get-selectable-mailbox-list
 527                   (elmo-imap4-send-command-wait
 528                    session
 529                    (list "list " (elmo-imap4-mailbox root) " *"))))
 530     (unless (string= (elmo-imap4-spec-username spec)
 531                      elmo-default-imap4-user)
 532       (setq append-serv (concat ":" (elmo-imap4-spec-username spec))))
 533     (unless (eq (elmo-imap4-spec-auth spec)
 534                 (or elmo-default-imap4-authenticate-type 'clear))
 535       (setq append-serv
 536             (concat append-serv "/" (symbol-name (elmo-imap4-spec-auth spec)))))
 537     (unless (string= (elmo-imap4-spec-hostname spec)
 538                      elmo-default-imap4-server)
 539       (setq append-serv (concat append-serv "@" (elmo-imap4-spec-hostname
 540                                                  spec))))
 541     (unless (eq (elmo-imap4-spec-port spec)
 542                 elmo-default-imap4-port)
 543       (setq append-serv (concat append-serv ":"
 544                                 (int-to-string
 545                                  (elmo-imap4-spec-port spec)))))
 546     (setq type (elmo-imap4-spec-stream-type spec))
 547     (unless (eq (elmo-network-stream-type-symbol type)
 548                 elmo-default-imap4-stream-type)
 549       (if type
 550           (setq append-serv (concat append-serv
 551                                     (elmo-network-stream-type-spec-string
 552                                      type)))))
 553     (if hierarchy
 554         (let (folder folders ret)
 555           (while (setq folders (car result))
 556             (if (prog1
 557                     (string-match
 558                      (concat "^\\(" root "[^" delim "]" "+\\)" delim)
 559                           folders)
 560                   (setq folder (match-string 1 folders)))
 561                 (progn
 562                   (setq ret
 563                         (append ret (list (list
 564                                            (concat "%" (elmo-imap4-decode-folder-string folder)
 565                                                    (and append-serv
 566                                                         (eval append-serv)))))))
 567                   (setq result
 568                         (delq nil
 569                               (mapcar '(lambda (fld)
 570                                          (unless
 571                                              (string-match
 572                                               (concat "^" (regexp-quote folder) delim)
 573                                               fld)
 574                                            fld))
 575                                       result))))
 576               (setq ret (append ret (list
 577                                      (concat "%" (elmo-imap4-decode-folder-string folders)
 578                                              (and append-serv
 579                                                   (eval append-serv))))))
 580               (setq result (cdr result))))
 581           ret)
 582       (mapcar (lambda (fld)
 583                 (concat "%" (elmo-imap4-decode-folder-string fld)
 584                         (and append-serv
 585                              (eval append-serv))))
 586               result))))
 587
 588 (defun elmo-imap4-folder-exists-p (spec)
 589   (let ((session (elmo-imap4-get-session spec)))
 590     (if (string=
 591          (elmo-imap4-session-current-mailbox-internal session)
 592          (elmo-imap4-spec-mailbox spec))
 593         t
 594       (elmo-imap4-session-select-mailbox
 595        session
 596        (elmo-imap4-spec-mailbox spec)
 597        'force 'no-error))))
 598
 599 (defun elmo-imap4-folder-creatable-p (spec)
 600   t)
 601
 602 (defun elmo-imap4-create-folder-maybe (spec dummy)
 603   (unless (elmo-imap4-folder-exists-p spec)
 604     (elmo-imap4-create-folder spec)))
 605
 606 (defun elmo-imap4-create-folder (spec)
 607   (elmo-imap4-send-command-wait
 608    (elmo-imap4-get-session spec)
 609    (list "create " (elmo-imap4-mailbox
 610                     (elmo-imap4-spec-mailbox spec)))))
 611
 612 (defun elmo-imap4-delete-folder (spec)
 613   (let ((session (elmo-imap4-get-session spec))
 614         msgs)
 615     (when (elmo-imap4-spec-mailbox spec)
 616       (when (setq msgs (elmo-imap4-list-folder spec))
 617         (elmo-imap4-delete-msgs spec msgs))
 618       (elmo-imap4-send-command-wait session "close")
 619       (elmo-imap4-send-command-wait
 620        session
 621        (list "delete "
 622              (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec)))))))
 623
 624 (defun elmo-imap4-rename-folder (old-spec new-spec)
 625   (let ((session (elmo-imap4-get-session old-spec)))
 626     (elmo-imap4-session-select-mailbox session
 627                                        (elmo-imap4-spec-mailbox old-spec))
 628     (elmo-imap4-send-command-wait session "close")
 629     (elmo-imap4-send-command-wait
 630      session
 631      (list "rename "
 632            (elmo-imap4-mailbox
 633             (elmo-imap4-spec-mailbox old-spec))
 634            " "
 635            (elmo-imap4-mailbox
 636             (elmo-imap4-spec-mailbox new-spec))))))
 637
 638 (defun elmo-imap4-max-of-folder (spec)
 639   (let ((session (elmo-imap4-get-session spec))
 640          (killed (and elmo-use-killed-list
 641                       (elmo-msgdb-killed-list-load
 642                        (elmo-msgdb-expand-path spec))))
 643         status)
 644     (with-current-buffer (elmo-network-session-buffer session)
 645       (setq elmo-imap4-status-callback nil)
 646       (setq elmo-imap4-status-callback-data nil))
 647     (setq status (elmo-imap4-response-value
 648                   (elmo-imap4-send-command-wait
 649                    session
 650                    (list "status "
 651                          (elmo-imap4-mailbox
 652                           (elmo-imap4-spec-mailbox spec))
 653                          " (uidnext messages)"))
 654                   'status))
 655     (cons
 656      (- (elmo-imap4-response-value status 'uidnext) 1)
 657      (if killed
 658          (-
 659           (elmo-imap4-response-value status 'messages)
 660           (elmo-msgdb-killed-list-length killed))
 661        (elmo-imap4-response-value status 'messages)))))
 662
 663 (defun elmo-imap4-folder-diff (spec folder &optional number-list)
 664   (if elmo-use-server-diff
 665       (elmo-imap4-server-diff spec)
 666     (elmo-generic-folder-diff spec folder number-list)))
 667
 668 (defun elmo-imap4-get-session (spec &optional if-exists)
 669   (elmo-network-get-session
 670    'elmo-imap4-session
 671    "IMAP"
 672    (elmo-imap4-spec-hostname spec)
 673    (elmo-imap4-spec-port spec)
 674    (elmo-imap4-spec-username spec)
 675    (elmo-imap4-spec-auth spec)
 676    (elmo-imap4-spec-stream-type spec)
 677    if-exists))
 678
 679 (defun elmo-imap4-commit (spec)
 680   (if (elmo-imap4-plugged-p spec)
 681       (let ((session (elmo-imap4-get-session spec 'if-exists)))
 682         (when session
 683           (if (string=
 684                (elmo-imap4-session-current-mailbox-internal session)
 685                (elmo-imap4-spec-mailbox spec))
 686               (if elmo-imap4-use-select-to-update-status
 687                   (elmo-imap4-session-select-mailbox
 688                    session
 689                    (elmo-imap4-spec-mailbox spec)
 690                    'force)
 691                 (elmo-imap4-session-check session)))))))
 692
 693 (defun elmo-imap4-session-select-mailbox (session mailbox
 694                                                   &optional force no-error)
 695   "Select MAILBOX in SESSION.
 696 If optional argument FORCE is non-nil, select mailbox even if current mailbox
 697 is same as MAILBOX.
 698 If second optional argument NO-ERROR is non-nil, don't cause an error when
 699 selecting folder was failed.
 700 Returns response value if selecting folder succeed. "
 701   (when (or force
 702             (not (string=
 703                   (elmo-imap4-session-current-mailbox-internal session)
 704                   mailbox)))
 705     (let (response result)
 706       (unwind-protect
 707           (setq response
 708                 (elmo-imap4-read-response
 709                  session
 710                  (elmo-imap4-send-command
 711                   session
 712                   (list
 713                    "select "
 714                    (elmo-imap4-mailbox mailbox)))))
 715         (if (setq result (elmo-imap4-response-ok-p response))
 716             (progn
 717               (elmo-imap4-session-set-current-mailbox-internal session mailbox)
 718               (elmo-imap4-session-set-read-only-internal
 719                session
 720                (nth 1 (assq 'read-only (assq 'ok response)))))
 721           (elmo-imap4-session-set-current-mailbox-internal session nil)
 722           (unless no-error
 723             (error (or
 724                     (elmo-imap4-response-error-text response)
 725                     (format "Select %s failed" mailbox))))))
 726       (and result response))))
 727
 728 (defun elmo-imap4-check-validity (spec validity-file)
 729 ;;; Not used.
 730 ;;;(elmo-imap4-send-command-wait
 731 ;;;(elmo-imap4-get-session spec)
 732 ;;;(list "status "
 733 ;;;      (elmo-imap4-mailbox
 734 ;;;       (elmo-imap4-spec-mailbox spec))
 735 ;;;      " (uidvalidity)")))
 736   )
 737
 738 (defun elmo-imap4-sync-validity  (spec validity-file)
 739   ;; Not used.
 740   )
 741
 742 (defun elmo-imap4-list (spec flag)
 743   (let ((session (elmo-imap4-get-session spec)))
 744     (elmo-imap4-session-select-mailbox session
 745                                        (elmo-imap4-spec-mailbox spec))
 746     (elmo-imap4-response-value
 747      (elmo-imap4-send-command-wait
 748       session
 749       (format (if elmo-imap4-use-uid "uid search %s"
 750                 "search %s") flag))
 751      'search)))
 752
 753 (defun elmo-imap4-list-folder (spec &optional nohide)
 754   (let* ((killed (and elmo-use-killed-list
 755                       (elmo-msgdb-killed-list-load
 756                        (elmo-msgdb-expand-path spec))))
 757          (max (elmo-msgdb-max-of-killed killed))
 758          numbers)
 759     (setq numbers (elmo-imap4-list spec
 760                                    (if (or nohide
 761                                            (null (eq max 0)))
 762                                        (format "uid %d:*" (1+ max))
 763                                      "all")))
 764     (elmo-living-messages numbers killed)))
 765
 766 (defun elmo-imap4-list-folder-unread (spec number-alist mark-alist
 767                                            unread-marks)
 768   (if (and (elmo-imap4-plugged-p spec)
 769            (elmo-imap4-use-flag-p spec))
 770       (elmo-imap4-list spec "unseen")
 771     (elmo-generic-list-folder-unread spec number-alist mark-alist
 772                                      unread-marks)))
 773
 774 (defun elmo-imap4-list-folder-important (spec number-alist)
 775   (if (and (elmo-imap4-plugged-p spec)
 776            (elmo-imap4-use-flag-p spec))
 777       (elmo-imap4-list spec "flagged")))
 778
 779 (defmacro elmo-imap4-detect-search-charset (string)
 780   (` (with-temp-buffer
 781        (insert (, string))
 782        (detect-mime-charset-region (point-min) (point-max)))))
 783
 784 (defun elmo-imap4-search-internal-primitive (spec session filter from-msgs)
 785   (let ((search-key (elmo-filter-key filter))
 786         (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to"))
 787         charset)
 788     (cond
 789      ((string= "last" search-key)
 790       (let ((numbers (or from-msgs (elmo-imap4-list-folder spec))))
 791         (nthcdr (max (- (length numbers)
 792                         (string-to-int (elmo-filter-value filter)))
 793                      0)
 794                 numbers)))
 795      ((string= "first" search-key)
 796       (let* ((numbers (or from-msgs (elmo-imap4-list-folder spec)))
 797              (rest (nthcdr (string-to-int (elmo-filter-value filter) )
 798                            numbers)))
 799         (mapcar '(lambda (x) (delete x numbers)) rest)
 800         numbers))
 801      ((or (string= "since" search-key)
 802           (string= "before" search-key))
 803       (setq search-key (concat "sent" search-key))
 804       (elmo-imap4-response-value
 805        (elmo-imap4-send-command-wait session
 806                                      (format
 807                                       (if elmo-imap4-use-uid
 808                                           "uid search %s%s%s %s"
 809                                         "search %s%s%s %s")
 810                                       (if from-msgs
 811                                           (concat
 812                                            (if elmo-imap4-use-uid "uid ")
 813                                            (cdr
 814                                             (car
 815                                              (elmo-imap4-make-number-set-list
 816                                               from-msgs)))
 817                                            " ")
 818                                         "")
 819                                       (if (eq (elmo-filter-type filter)
 820                                               'unmatch)
 821                                           "not " "")
 822                                       search-key
 823                                       (elmo-date-get-description
 824                                        (elmo-date-get-datevec
 825                                         (elmo-filter-value filter)))))
 826        'search))
 827      (t
 828       (setq charset
 829             (if (eq (length (elmo-filter-value filter)) 0)
 830                 (setq charset 'us-ascii)
 831               (elmo-imap4-detect-search-charset
 832                (elmo-filter-value filter))))
 833       (elmo-imap4-response-value
 834        (elmo-imap4-send-command-wait session
 835                                      (list
 836                                       (if elmo-imap4-use-uid "uid ")
 837                                       "search "
 838                                       "CHARSET "
 839                                       (elmo-imap4-astring
 840                                        (symbol-name charset))
 841                                       " "
 842                                       (if from-msgs
 843                                           (concat
 844                                            (if elmo-imap4-use-uid "uid ")
 845                                            (cdr
 846                                             (car
 847                                              (elmo-imap4-make-number-set-list
 848                                               from-msgs)))
 849                                            " ")
 850                                         "")
 851                                       (if (eq (elmo-filter-type filter)
 852                                               'unmatch)
 853                                           "not " "")
 854                                       (format "%s%s "
 855                                               (if (member
 856                                                    (elmo-filter-key filter)
 857                                                    imap-search-keys)
 858                                                   ""
 859                                                 "header ")
 860                                               (elmo-filter-key filter))
 861                                       (elmo-imap4-astring
 862                                        (encode-mime-charset-string
 863                                         (elmo-filter-value filter) charset))))
 864        'search)))))
 865
 866 (defun elmo-imap4-search-internal (spec session condition from-msgs)
 867   (let (result)
 868     (cond
 869      ((vectorp condition)
 870       (setq result (elmo-imap4-search-internal-primitive
 871                     spec session condition from-msgs)))
 872      ((eq (car condition) 'and)
 873       (setq result (elmo-imap4-search-internal spec session (nth 1 condition)
 874                                                from-msgs)
 875             result (elmo-list-filter result
 876                                      (elmo-imap4-search-internal
 877                                       spec session (nth 2 condition)
 878                                       from-msgs))))
 879      ((eq (car condition) 'or)
 880       (setq result (elmo-imap4-search-internal
 881                     spec session (nth 1 condition) from-msgs)
 882             result (elmo-uniq-list
 883                     (nconc result
 884                            (elmo-imap4-search-internal
 885                             spec session (nth 2 condition) from-msgs)))
 886             result (sort result '<))))))
 887
 888
 889 (defun elmo-imap4-search (spec condition &optional from-msgs)
 890   (save-excursion
 891     (let ((session (elmo-imap4-get-session spec)))
 892       (elmo-imap4-session-select-mailbox
 893        session
 894        (elmo-imap4-spec-mailbox spec))
 895       (elmo-imap4-search-internal spec session condition from-msgs))))
 896
 897 (defun elmo-imap4-use-flag-p (spec)
 898   (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp
 899                      (elmo-imap4-spec-mailbox spec))))
 900
 901 (static-cond
 902  ((fboundp 'float)
 903   ;; Emacs can parse dot symbol.
 904   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 905   (defvar elmo-imap4-rfc822-text "RFC822\.TEXT")
 906   (defvar elmo-imap4-rfc822-header "RFC822\.HEADER")
 907   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 908   (defvar elmo-imap4-header-fields "HEADER\.FIELDS")
 909   (defmacro elmo-imap4-replace-dot-symbols ()) ;; noop
 910   (defalias 'elmo-imap4-fetch-read 'read)
 911   )
 912  (t
 913   ;;; For Nemacs.
 914   ;; Cannot parse dot symbol.
 915   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 916   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 917   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 918   (defvar elmo-imap4-rfc822-text "RFC822_TEXT")
 919   (defvar elmo-imap4-rfc822-header "RFC822_HEADER")
 920   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 921   (defun elmo-imap4-fetch-read (buffer)
 922     (with-current-buffer buffer
 923       (let ((beg (point))
 924             token)
 925         (when (re-search-forward "[[ ]" nil t)
 926           (goto-char (match-beginning 0))
 927           (setq token (buffer-substring beg (point)))
 928           (cond ((string= token "RFC822.SIZE")
 929                  (intern elmo-imap4-rfc822-size))
 930                 ((string= token "RFC822.HEADER")
 931                  (intern elmo-imap4-rfc822-header))
 932                 ((string= token "RFC822.TEXT")
 933                  (intern elmo-imap4-rfc822-text))
 934                 ((string= token "HEADER\.FIELDS")
 935                  (intern elmo-imap4-header-fields))
 936                 (t (goto-char beg)
 937                    (elmo-read (current-buffer))))))))))
 938
 939 (defun elmo-imap4-make-number-set-list (msg-list &optional chop-length)
 940   "Make RFC2060's message set specifier from MSG-LIST.
 941 Returns a list of (NUMBER . SET-STRING).
 942 SET-STRING is the message set specifier described in RFC2060.
 943 NUMBER is contained message number in SET-STRING.
 944 Every SET-STRING does not contain number of messages longer than CHOP-LENGTH.
 945 If CHOP-LENGTH is not specified, message set is not chopped."
 946   (let (count cont-list set-list)
 947     (setq msg-list (sort (copy-sequence msg-list) '<))
 948     (while msg-list
 949       (setq cont-list nil)
 950       (setq count 0)
 951       (unless chop-length
 952         (setq chop-length (length msg-list)))
 953       (while (and (not (null msg-list))
 954                   (< count chop-length))
 955         (setq cont-list
 956               (elmo-number-set-append
 957                cont-list (car msg-list)))
 958         (incf count)
 959         (setq msg-list (cdr msg-list)))
 960       (setq set-list
 961             (cons
 962              (cons
 963               count
 964               (mapconcat
 965                (lambda (x)
 966                  (cond ((consp x)
 967                         (format "%s:%s" (car x) (cdr x)))
 968                        ((integerp x)
 969                         (int-to-string x))))
 970                cont-list
 971                ","))
 972              set-list)))
 973     (nreverse set-list)))
 974
 975 ;;
 976 ;; set mark
 977 ;; read-mark -> "\\Seen"
 978 ;; important -> "\\Flagged"
 979 ;;
 980 ;; (delete -> \\Deleted)
 981 (defun elmo-imap4-mark-set-on-msgs (spec msgs mark &optional unmark no-expunge)
 982   "SET flag of MSGS as MARK.
 983 If optional argument UNMARK is non-nil, unmark."
 984   (let ((session (elmo-imap4-get-session spec))
 985         set-list)
 986     (elmo-imap4-session-select-mailbox session
 987                                        (elmo-imap4-spec-mailbox spec))
 988     (setq set-list (elmo-imap4-make-number-set-list msgs))
 989     (when set-list
 990       (with-current-buffer (elmo-network-session-buffer session)
 991         (setq elmo-imap4-fetch-callback nil)
 992         (setq elmo-imap4-fetch-callback-data nil))
 993       (elmo-imap4-send-command-wait
 994        session
 995        (format
 996         (if elmo-imap4-use-uid
 997             "uid store %s %sflags.silent (%s)"
 998           "store %s %sflags.silent (%s)")
 999         (cdr (car set-list))
1000         (if unmark "-" "+")
1001         mark))
1002       (unless no-expunge
1003         (elmo-imap4-send-command-wait session "expunge")))
1004     t))
1005
1006 (defun elmo-imap4-mark-as-important (spec msgs)
1007   (and (elmo-imap4-use-flag-p spec)
1008        (elmo-imap4-mark-set-on-msgs spec msgs "\\Flagged" nil 'no-expunge)))
1009
1010 (defun elmo-imap4-mark-as-read (spec msgs)
1011   (and (elmo-imap4-use-flag-p spec)
1012        (elmo-imap4-mark-set-on-msgs spec msgs "\\Seen" nil 'no-expunge)))
1013
1014 (defun elmo-imap4-unmark-important (spec msgs)
1015   (and (elmo-imap4-use-flag-p spec)
1016        (elmo-imap4-mark-set-on-msgs spec msgs "\\Flagged" 'unmark
1017                                     'no-expunge)))
1018
1019 (defun elmo-imap4-mark-as-unread (spec msgs)
1020   (and (elmo-imap4-use-flag-p spec)
1021        (elmo-imap4-mark-set-on-msgs spec msgs "\\Seen" 'unmark 'no-expunge)))
1022
1023 (defun elmo-imap4-delete-msgs (spec msgs)
1024   (elmo-imap4-mark-set-on-msgs spec msgs "\\Deleted"))
1025
1026 (defun elmo-imap4-delete-msgs-no-expunge (spec msgs)
1027   (elmo-imap4-mark-set-on-msgs spec msgs "\\Deleted" nil 'no-expunge))
1028
1029 (defun elmo-imap4-msgdb-create-as-numlist (spec numlist new-mark already-mark
1030                                                 seen-mark important-mark
1031                                                 seen-list)
1032   "Create msgdb for SPEC for NUMLIST."
1033   (elmo-imap4-msgdb-create spec numlist new-mark already-mark
1034                            seen-mark important-mark seen-list t))
1035
1036 ;; Current buffer is process buffer.
1037 (defun elmo-imap4-fetch-callback (element app-data)
1038   (funcall elmo-imap4-fetch-callback
1039            (with-temp-buffer
1040              (insert (or (elmo-imap4-response-bodydetail-text element)
1041                          ""))
1042              ;; Delete CR.
1043              (goto-char (point-min))
1044              (while (search-forward "\r\n" nil t)
1045                (replace-match "\n"))
1046              (elmo-msgdb-create-overview-from-buffer
1047               (elmo-imap4-response-value element 'uid)
1048               (elmo-imap4-response-value element 'rfc822size)))
1049            (elmo-imap4-response-value element 'flags)
1050            app-data))
1051
1052 ;;
1053 ;; app-data:
1054 ;; cons of list
1055 ;; 0: new-mark 1: already-mark 2: seen-mark 3: important-mark
1056 ;; 4: seen-list
1057 ;; and result of use-flag-p.
1058 (defun elmo-imap4-fetch-callback-1 (entity flags app-data)
1059   "A msgdb entity callback function."
1060   (let* ((use-flag (cdr app-data))
1061          (app-data (car app-data))
1062          (seen (member (car entity) (nth 4 app-data)))
1063          mark)
1064     (if (member "\\Flagged" flags)
1065         (elmo-msgdb-global-mark-set (car entity) (nth 3 app-data)))
1066     (setq mark (or (elmo-msgdb-global-mark-get (car entity))
1067                    (if (elmo-cache-exists-p (car entity)) ;; XXX
1068                        (if (or seen
1069                                (and use-flag
1070                                     (member "\\Seen" flags)))
1071                            nil
1072                          (nth 1 app-data))
1073                      (if (or seen
1074                              (and use-flag
1075                                   (member "\\Seen" flags)))
1076                          (if elmo-imap4-use-cache
1077                              (nth 2 app-data))
1078                        (nth 0 app-data)))))
1079     (setq elmo-imap4-current-msgdb
1080           (elmo-msgdb-append
1081            elmo-imap4-current-msgdb
1082            (list (list entity)
1083                  (list (cons (elmo-msgdb-overview-entity-get-number entity)
1084                              (car entity)))
1085                  (if mark
1086                      (list
1087                       (list (elmo-msgdb-overview-entity-get-number entity)
1088                             mark))))))))
1089
1090 (defun elmo-imap4-msgdb-create (spec numlist &rest args)
1091   "Create msgdb for SPEC."
1092   (when numlist
1093     (let ((session (elmo-imap4-get-session spec))
1094           (headers
1095            (append
1096             '("Subject" "From" "To" "Cc" "Date"
1097               "Message-Id" "References" "In-Reply-To")
1098             elmo-msgdb-extra-fields))
1099           (total 0)
1100           (length (length numlist))
1101           rfc2060 set-list)
1102       (setq rfc2060 (memq 'imap4rev1
1103                           (elmo-imap4-session-capability-internal
1104                            session)))
1105       (message "Getting overview...")
1106       (elmo-imap4-session-select-mailbox session
1107                                          (elmo-imap4-spec-mailbox spec))
1108       (setq set-list (elmo-imap4-make-number-set-list
1109                       numlist
1110                       elmo-imap4-overview-fetch-chop-length))
1111       ;; Setup callback.
1112       (with-current-buffer (elmo-network-session-buffer session)
1113         (setq elmo-imap4-current-msgdb nil
1114               elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1
1115               elmo-imap4-fetch-callback-data (cons args
1116                                                    (elmo-imap4-use-flag-p
1117                                                     spec)))
1118         (while set-list
1119           (elmo-imap4-send-command-wait
1120            session
1121            ;; get overview entity from IMAP4
1122            (format "%sfetch %s (%s rfc822.size flags)"
1123                    (if elmo-imap4-use-uid "uid " "")
1124                    (cdr (car set-list))
1125                    (if rfc2060
1126                        (format "body.peek[header.fields %s]" headers)
1127                      (format "%s" headers))))
1128           (when (> length elmo-display-progress-threshold)
1129             (setq total (+ total (car (car set-list))))
1130             (elmo-display-progress
1131              'elmo-imap4-msgdb-create "Getting overview..."
1132              (/ (* total 100) length)))
1133           (setq set-list (cdr set-list)))
1134         (message "Getting overview...done")
1135         elmo-imap4-current-msgdb))))
1136
1137 (defun elmo-imap4-parse-capability (string)
1138   (if (string-match "^\\*\\(.*\\)$" string)
1139       (elmo-read
1140        (concat "(" (downcase (elmo-match-string 1 string)) ")"))))
1141
1142 (defun elmo-imap4-clear-login (session)
1143   (let ((elmo-imap4-debug-inhibit-logging t))
1144     (or
1145      (elmo-imap4-read-ok
1146       session
1147       (elmo-imap4-send-command
1148        session
1149        (list "login "
1150              (elmo-imap4-userid (elmo-network-session-user-internal session))
1151              " "
1152              (elmo-imap4-password
1153               (elmo-get-passwd (elmo-network-session-password-key session))))))
1154      (signal 'elmo-authenticate-error '(elmo-imap4-clear-login)))))
1155
1156 (defun elmo-imap4-auth-login (session)
1157   (let ((tag (elmo-imap4-send-command session "authenticate login"))
1158         (elmo-imap4-debug-inhibit-logging t))
1159     (or (elmo-imap4-read-continue-req session)
1160         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
1161     (elmo-imap4-send-string session
1162                             (elmo-base64-encode-string
1163                              (elmo-network-session-user-internal session)))
1164     (or (elmo-imap4-read-continue-req session)
1165         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
1166     (elmo-imap4-send-string session
1167                             (elmo-base64-encode-string
1168                              (elmo-get-passwd
1169                               (elmo-network-session-password-key session))))
1170     (or (elmo-imap4-read-ok session tag)
1171         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
1172     (setq elmo-imap4-status 'auth)))
1173
1174 (luna-define-method
1175   elmo-network-initialize-session-buffer :after ((session
1176                                                   elmo-imap4-session) buffer)
1177   (with-current-buffer buffer
1178     (mapcar 'make-variable-buffer-local elmo-imap4-local-variables)
1179     (setq elmo-imap4-seqno 0)
1180     (setq elmo-imap4-status 'initial)))
1181
1182 (luna-define-method elmo-network-initialize-session ((session
1183                                                       elmo-imap4-session))
1184   (let ((process (elmo-network-session-process-internal session)))
1185     (with-current-buffer (process-buffer process)
1186       ;; Skip garbage output from process before greeting.
1187       (while (and (memq (process-status process) '(open run))
1188                   (goto-char (point-max))
1189                   (forward-line -1)
1190                   (not (elmo-imap4-parse-greeting)))
1191         (accept-process-output process 1))
1192       (set-process-filter process 'elmo-imap4-arrival-filter)
1193       (set-process-sentinel process 'elmo-imap4-sentinel)
1194 ;;;   (while (and (memq (process-status process) '(open run))
1195 ;;;               (eq elmo-imap4-status 'initial))
1196 ;;;     (message "Waiting for server response...")
1197 ;;;     (accept-process-output process 1))
1198 ;;;   (message "")
1199       (unless (memq elmo-imap4-status '(nonauth auth))
1200         (signal 'elmo-open-error
1201                 (list 'elmo-network-initialize-session)))
1202       (elmo-imap4-session-set-capability-internal
1203        session
1204        (elmo-imap4-response-value
1205         (elmo-imap4-send-command-wait session "capability")
1206         'capability))
1207       (when (eq (elmo-network-stream-type-symbol
1208                  (elmo-network-session-stream-type-internal session))
1209                 'starttls)
1210         (or (memq 'starttls
1211                   (elmo-imap4-session-capability-internal session))
1212             (signal 'elmo-open-error
1213                     '(elmo-imap4-starttls-error)))
1214         (elmo-imap4-send-command-wait session "starttls")
1215         (starttls-negotiate process)))))
1216
1217 (luna-define-method elmo-network-authenticate-session ((session
1218                                                         elmo-imap4-session))
1219   (with-current-buffer (process-buffer
1220                         (elmo-network-session-process-internal session))
1221     (let* ((auth (elmo-network-session-auth-internal session))
1222            (auth (if (listp auth) auth (list auth))))
1223       (unless (or (eq elmo-imap4-status 'auth)
1224                   (null auth))
1225         (cond
1226          ((eq 'clear (car auth))
1227           (elmo-imap4-clear-login session))
1228          ((eq 'login (car auth))
1229           (elmo-imap4-auth-login session))
1230          (t
1231           (let* ((elmo-imap4-debug-inhibit-logging t)
1232                  (sasl-mechanisms
1233                   (delq nil
1234                         (mapcar
1235                          '(lambda (cap)
1236                             (if (string-match "^auth=\\(.*\\)$"
1237                                               (symbol-name cap))
1238                                 (match-string 1 (upcase (symbol-name cap)))))
1239                          (elmo-imap4-session-capability-internal session))))
1240                  (mechanism
1241                   (sasl-find-mechanism
1242                    (delq nil
1243                          (mapcar '(lambda (cap) (upcase (symbol-name cap)))
1244                                  (if (listp auth)
1245                                      auth
1246                                    (list auth)))))) ;)
1247                  client name step response tag
1248                  sasl-read-passphrase)
1249             (unless mechanism
1250               (if (or elmo-imap4-force-login
1251                       (y-or-n-p
1252                        (format
1253                         "There's no %s capability in server. continue?"
1254                         (elmo-list-to-string
1255                          (elmo-network-session-auth-internal session)))))
1256                   (setq mechanism (sasl-find-mechanism
1257                                    sasl-mechanisms))
1258                 (signal 'elmo-authenticate-error
1259                         '(elmo-imap4-auth-no-mechanisms))))
1260             (setq client
1261                   (sasl-make-client
1262                    mechanism
1263                    (elmo-network-session-user-internal session)
1264                    "imap"
1265                    (elmo-network-session-host-internal session)))
1266 ;;;         (if elmo-imap4-auth-user-realm
1267 ;;;             (sasl-client-set-property client 'realm elmo-imap4-auth-user-realm))
1268             (setq name (sasl-mechanism-name mechanism)
1269                   step (sasl-next-step client nil))
1270             (elmo-network-session-set-auth-internal
1271              session
1272              (intern (downcase name)))
1273             (setq sasl-read-passphrase
1274                   (function
1275                    (lambda (prompt)
1276                      (elmo-get-passwd
1277                       (elmo-network-session-password-key session)))))
1278             (setq tag
1279                   (elmo-imap4-send-command
1280                    session
1281                    (concat "AUTHENTICATE " name
1282                            (and (sasl-step-data step)
1283                                 (concat
1284                                  " "
1285                                  (elmo-base64-encode-string
1286                                   (sasl-step-data step)
1287                                   'no-lin-break))))))
1288             (catch 'done
1289               (while t
1290                 (setq response
1291                       (elmo-imap4-read-untagged
1292                        (elmo-network-session-process-internal session)))
1293                 (if (elmo-imap4-response-ok-p response)
1294                     (if (sasl-next-step client step)
1295                         ;; Bogus server?
1296                         (signal 'elmo-authenticate-error
1297                                 (list (intern
1298                                        (concat "elmo-imap4-auth-"
1299                                                (downcase name)))))
1300                       ;; The authentication process is finished.
1301                       (throw 'done nil)))
1302                 (unless (elmo-imap4-response-continue-req-p response)
1303                   ;; response is NO or BAD.
1304                   (signal 'elmo-authenticate-error
1305                           (list (intern
1306                                  (concat "elmo-imap4-auth-"
1307                                          (downcase name))))))
1308                 (sasl-step-set-data
1309                  step
1310                  (elmo-base64-decode-string
1311                   (elmo-imap4-response-value response 'continue-req)))
1312                 (setq step (sasl-next-step client step))
1313                 (setq tag
1314                       (elmo-imap4-send-string
1315                        session
1316                        (if (sasl-step-data step)
1317                            (elmo-base64-encode-string (sasl-step-data step)
1318                                                       'no-line-break)
1319                          ""))))))))))))
1320
1321 (luna-define-method elmo-network-setup-session ((session
1322                                                  elmo-imap4-session))
1323   (with-current-buffer (elmo-network-session-buffer session)
1324     (when (memq 'namespace (elmo-imap4-session-capability-internal session))
1325       (setq elmo-imap4-server-namespace
1326             (elmo-imap4-response-value
1327              (elmo-imap4-send-command-wait session "namespace")
1328              'namespace)))))
1329
1330 (defun elmo-imap4-setup-send-buffer (string)
1331   (let ((tmp-buf (get-buffer-create " *elmo-imap4-setup-send-buffer*")))
1332     (save-excursion
1333       (save-match-data
1334         (set-buffer tmp-buf)
1335         (erase-buffer)
1336         (elmo-set-buffer-multibyte nil)
1337         (insert string)
1338         (goto-char (point-min))
1339         (if (eq (re-search-forward "^$" nil t)
1340                 (point-max))
1341             (insert "\n"))
1342         (goto-char (point-min))
1343         (while (search-forward "\n" nil t)
1344           (replace-match "\r\n"))))
1345     tmp-buf))
1346
1347 (defun elmo-imap4-read-part (folder msg part)
1348   (let* ((spec (elmo-folder-get-spec folder))
1349          (session (elmo-imap4-get-session spec)))
1350     (elmo-imap4-session-select-mailbox session
1351                                        (elmo-imap4-spec-mailbox spec))
1352     (with-current-buffer (elmo-network-session-buffer session)
1353       (setq elmo-imap4-fetch-callback nil)
1354       (setq elmo-imap4-fetch-callback-data nil))
1355     (unless elmo-inhibit-display-retrieval-progress
1356       (setq elmo-imap4-display-literal-progress t))
1357     (prog1
1358         (unwind-protect
1359             (elmo-delete-cr
1360              (elmo-imap4-response-bodydetail-text
1361               (elmo-imap4-response-value-all
1362                (elmo-imap4-send-command-wait session
1363                                              (format
1364                                               (if elmo-imap4-use-uid
1365                                                   "uid fetch %s body.peek[%s]"
1366                                                 "fetch %s body.peek[%s]")
1367                                               msg part))
1368                'fetch)))
1369           (setq elmo-imap4-display-literal-progress nil))
1370       (unless elmo-inhibit-display-retrieval-progress
1371         (elmo-display-progress 'elmo-imap4-display-literal-progress
1372                                "" 100)  ; remove progress bar.
1373         (message "Retrieving...done.")))))
1374
1375 (defun elmo-imap4-prefetch-msg (spec msg outbuf)
1376   (elmo-imap4-read-msg spec msg outbuf nil 'unseen))
1377
1378 (defun elmo-imap4-read-msg (spec msg outbuf
1379                                  &optional msgdb leave-seen-flag-untouched)
1380   (let ((session (elmo-imap4-get-session spec))
1381         response)
1382     (elmo-imap4-session-select-mailbox session
1383                                        (elmo-imap4-spec-mailbox spec))
1384     (with-current-buffer (elmo-network-session-buffer session)
1385       (setq elmo-imap4-fetch-callback nil)
1386       (setq elmo-imap4-fetch-callback-data nil))
1387     (unless elmo-inhibit-display-retrieval-progress
1388       (setq elmo-imap4-display-literal-progress t))
1389     (unwind-protect
1390         (setq response
1391               (elmo-imap4-send-command-wait session
1392                                             (format
1393                                              (if elmo-imap4-use-uid
1394                                                  "uid fetch %s body%s[]"
1395                                                "fetch %s body%s[]")
1396                                              msg
1397                                              (if leave-seen-flag-untouched
1398                                                  ".peek" ""))))
1399       (setq elmo-imap4-display-literal-progress nil))
1400     (unless elmo-inhibit-display-retrieval-progress
1401       (elmo-display-progress 'elmo-imap4-display-literal-progress
1402                              "" 100)  ; remove progress bar.
1403       (message "Retrieving...done."))
1404     (and (setq response (elmo-imap4-response-bodydetail-text
1405                          (elmo-imap4-response-value-all
1406                           response 'fetch )))
1407          (with-current-buffer outbuf
1408            (erase-buffer)
1409            (insert response)
1410            (elmo-delete-cr-get-content-type)))))
1411
1412 (defun elmo-imap4-setup-send-buffer-from-file (file)
1413   (let ((tmp-buf (get-buffer-create
1414                   " *elmo-imap4-setup-send-buffer-from-file*")))
1415     (save-excursion
1416       (save-match-data
1417         (set-buffer tmp-buf)
1418         (erase-buffer)
1419         (as-binary-input-file
1420          (insert-file-contents file))
1421         (goto-char (point-min))
1422         (if (eq (re-search-forward "^$" nil t)
1423                 (point-max))
1424             (insert "\n"))
1425         (goto-char (point-min))
1426         (while (search-forward "\n" nil t)
1427           (replace-match "\r\n"))))
1428     tmp-buf))
1429
1430 (defun elmo-imap4-delete-msgids (spec msgids)
1431   "If actual message-id is matched, then delete it."
1432   (let ((message-ids msgids)
1433         (i 0)
1434         (num (length msgids)))
1435     (while message-ids
1436       (setq i (+ 1 i))
1437       (message "Deleting message...%d/%d" i num)
1438       (elmo-imap4-delete-msg-by-id spec (car message-ids))
1439       (setq message-ids (cdr message-ids)))
1440     (elmo-imap4-send-command-wait (elmo-imap4-get-session spec) "expunge")))
1441
1442 (defun elmo-imap4-delete-msg-by-id (spec msgid)
1443   (let ((session (elmo-imap4-get-session spec)))
1444     (elmo-imap4-session-select-mailbox session
1445                                        (elmo-imap4-spec-mailbox spec))
1446     (elmo-imap4-delete-msgs-no-expunge
1447      spec
1448      (elmo-imap4-response-value
1449       (elmo-imap4-send-command-wait session
1450                                     (list
1451                                      (if elmo-imap4-use-uid
1452                                          "uid search header message-id "
1453                                        "search header message-id ")
1454                                      (elmo-imap4-field-body msgid)))
1455       'search))))
1456
1457 (defun elmo-imap4-append-msg-by-id (spec msgid)
1458   (let ((session (elmo-imap4-get-session spec))
1459         send-buf)
1460     (elmo-imap4-session-select-mailbox session
1461                                        (elmo-imap4-spec-mailbox spec))
1462     (setq send-buf (elmo-imap4-setup-send-buffer-from-file
1463                     (elmo-cache-get-path msgid)))
1464     (unwind-protect
1465         (elmo-imap4-send-command-wait
1466          session
1467          (list
1468           "append "
1469           (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec))
1470           " (\\Seen) "
1471           (elmo-imap4-buffer-literal send-buf)))
1472       (kill-buffer send-buf)))
1473   t)
1474
1475 (defun elmo-imap4-append-msg (spec string &optional msg no-see)
1476   (let ((session (elmo-imap4-get-session spec))
1477         send-buf result)
1478     (elmo-imap4-session-select-mailbox session
1479                                        (elmo-imap4-spec-mailbox spec))
1480     (setq send-buf (elmo-imap4-setup-send-buffer string))
1481     (unwind-protect
1482         (setq result (elmo-imap4-response-ok-p
1483                       (elmo-imap4-send-command-wait
1484                        session
1485                        (list
1486                         "append "
1487                         (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec))
1488                         (if no-see " " " (\\Seen) ")
1489                         (elmo-imap4-buffer-literal send-buf)))))
1490       (kill-buffer send-buf))
1491     result))
1492
1493 (defun elmo-imap4-copy-msgs (dst-spec
1494                              msgs src-spec &optional expunge-it same-number)
1495   "Equivalence of hostname, username is assumed."
1496   (let ((session (elmo-imap4-get-session src-spec)))
1497     (elmo-imap4-session-select-mailbox session
1498                                        (elmo-imap4-spec-mailbox src-spec))
1499     (while msgs
1500       (elmo-imap4-send-command-wait session
1501                                     (list
1502                                      (format
1503                                       (if elmo-imap4-use-uid
1504                                           "uid copy %s "
1505                                         "copy %s ")
1506                                       (car msgs))
1507                                      (elmo-imap4-mailbox
1508                                       (elmo-imap4-spec-mailbox dst-spec))))
1509       (setq msgs (cdr msgs)))
1510     (when expunge-it
1511       (elmo-imap4-send-command-wait session "expunge"))
1512     t))
1513
1514 (defun elmo-imap4-server-diff-async-callback-1 (status data)
1515   (funcall elmo-imap4-server-diff-async-callback
1516            (cons (elmo-imap4-response-value status 'unseen)
1517                  (elmo-imap4-response-value status 'messages))
1518            data))
1519
1520 (defun elmo-imap4-server-diff-async (spec)
1521   (let ((session (elmo-imap4-get-session spec)))
1522     ;; commit.
1523     ;; (elmo-imap4-commit spec)
1524     (with-current-buffer (elmo-network-session-buffer session)
1525       (setq elmo-imap4-status-callback
1526             'elmo-imap4-server-diff-async-callback-1)
1527       (setq elmo-imap4-status-callback-data
1528             elmo-imap4-server-diff-async-callback-data))
1529     (elmo-imap4-send-command session
1530                              (list
1531                               "status "
1532                               (elmo-imap4-mailbox
1533                                (elmo-imap4-spec-mailbox spec))
1534                               " (unseen messages)"))))
1535
1536 (defun elmo-imap4-server-diff (spec)
1537   "Get server status"
1538   (let ((session (elmo-imap4-get-session spec))
1539         response)
1540     ;; commit.
1541 ;;; (elmo-imap4-commit spec)
1542     (with-current-buffer (elmo-network-session-buffer session)
1543       (setq elmo-imap4-status-callback nil)
1544       (setq elmo-imap4-status-callback-data nil))
1545     (setq response
1546           (elmo-imap4-send-command-wait session
1547                                         (list
1548                                          "status "
1549                                          (elmo-imap4-mailbox
1550                                           (elmo-imap4-spec-mailbox spec))
1551                                          " (unseen messages)")))
1552     (setq response (elmo-imap4-response-value response 'status))
1553     (cons (elmo-imap4-response-value response 'unseen)
1554           (elmo-imap4-response-value response 'messages))))
1555
1556 (defun elmo-imap4-use-cache-p (spec number)
1557   elmo-imap4-use-cache)
1558
1559 (defun elmo-imap4-local-file-p (spec number)
1560   nil)
1561
1562 (defun elmo-imap4-port-label (spec)
1563   (concat "imap4"
1564           (if (elmo-imap4-spec-stream-type spec)
1565               (concat "!" (symbol-name
1566                            (elmo-network-stream-type-symbol
1567                             (elmo-imap4-spec-stream-type spec)))))))
1568
1569
1570 (defsubst elmo-imap4-portinfo (spec)
1571   (list (elmo-imap4-spec-hostname spec) (elmo-imap4-spec-port spec)))
1572
1573 (defun elmo-imap4-plugged-p (spec)
1574   (apply 'elmo-plugged-p
1575          (append (elmo-imap4-portinfo spec)
1576                  (list nil (quote (elmo-imap4-port-label spec))))))
1577
1578 (defun elmo-imap4-set-plugged (spec plugged add)
1579   (apply 'elmo-set-plugged plugged
1580          (append (elmo-imap4-portinfo spec)
1581                  (list nil nil (quote (elmo-imap4-port-label spec)) add))))
1582
1583 (defalias 'elmo-imap4-sync-number-alist 'elmo-generic-sync-number-alist)
1584
1585 ;;; IMAP parser.
1586
1587 (defvar elmo-imap4-server-eol "\r\n"
1588   "The EOL string sent from the server.")
1589
1590 (defvar elmo-imap4-client-eol "\r\n"
1591   "The EOL string we send to the server.")
1592
1593 (defun elmo-imap4-find-next-line ()
1594   "Return point at end of current line, taking into account literals.
1595 Return nil if no complete line has arrived."
1596   (when (re-search-forward (concat elmo-imap4-server-eol "\\|{\\([0-9]+\\)}"
1597                                    elmo-imap4-server-eol)
1598                            nil t)
1599     (if (match-string 1)
1600         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1601             (progn
1602               (if (and elmo-imap4-display-literal-progress
1603                        (> (string-to-number (match-string 1))
1604                           (min elmo-display-retrieval-progress-threshold 100)))
1605                   (elmo-display-progress
1606                    'elmo-imap4-display-literal-progress
1607                    (format "Retrieving (%d/%d bytes)..."
1608                            (- (point-max) (point))
1609                            (string-to-number (match-string 1)))
1610                    (/ (- (point-max) (point))
1611                       (/ (string-to-number (match-string 1)) 100))))
1612               nil)
1613           (goto-char (+ (point) (string-to-number (match-string 1))))
1614           (elmo-imap4-find-next-line))
1615       (point))))
1616
1617 (defun elmo-imap4-sentinel (process string)
1618   (delete-process process))
1619
1620 (defun elmo-imap4-arrival-filter (proc string)
1621   "IMAP process filter."
1622   (when (buffer-live-p (process-buffer proc))
1623   (with-current-buffer (process-buffer proc)
1624     (elmo-imap4-debug "-> %s" string)
1625     (goto-char (point-max))
1626     (insert string)
1627     (let (end)
1628       (goto-char (point-min))
1629       (while (setq end (elmo-imap4-find-next-line))
1630         (save-restriction
1631           (narrow-to-region (point-min) end)
1632           (delete-backward-char (length elmo-imap4-server-eol))
1633           (goto-char (point-min))
1634           (unwind-protect
1635               (cond ((eq elmo-imap4-status 'initial)
1636                      (setq elmo-imap4-current-response
1637                            (list
1638                             (list 'greeting (elmo-imap4-parse-greeting)))))
1639                     ((or (eq elmo-imap4-status 'auth)
1640                          (eq elmo-imap4-status 'nonauth)
1641                          (eq elmo-imap4-status 'selected)
1642                          (eq elmo-imap4-status 'examine))
1643                      (setq elmo-imap4-current-response
1644                            (cons
1645                             (elmo-imap4-parse-response)
1646                             elmo-imap4-current-response)))
1647                     (t
1648                      (message "Unknown state %s in arrival filter"
1649                               elmo-imap4-status))))
1650           (delete-region (point-min) (point-max))))))))
1651
1652 ;; IMAP parser.
1653
1654 (defsubst elmo-imap4-forward ()
1655   (or (eobp) (forward-char 1)))
1656
1657 (defsubst elmo-imap4-parse-number ()
1658   (when (looking-at "[0-9]+")
1659     (prog1
1660         (string-to-number (match-string 0))
1661       (goto-char (match-end 0)))))
1662
1663 (defsubst elmo-imap4-parse-literal ()
1664   (when (looking-at "{\\([0-9]+\\)}\r\n")
1665     (let ((pos (match-end 0))
1666           (len (string-to-number (match-string 1))))
1667       (if (< (point-max) (+ pos len))
1668           nil
1669         (goto-char (+ pos len))
1670         (buffer-substring pos (+ pos len))))))
1671 ;;;     (list ' pos (+ pos len))))))
1672
1673 (defsubst elmo-imap4-parse-string ()
1674   (cond ((eq (char-after (point)) ?\")
1675          (forward-char 1)
1676          (let ((p (point)) (name ""))
1677            (skip-chars-forward "^\"\\\\")
1678            (setq name (buffer-substring p (point)))
1679            (while (eq (char-after (point)) ?\\)
1680              (setq p (1+ (point)))
1681              (forward-char 2)
1682              (skip-chars-forward "^\"\\\\")
1683              (setq name (concat name (buffer-substring p (point)))))
1684            (forward-char 1)
1685            name))
1686         ((eq (char-after (point)) ?{)
1687          (elmo-imap4-parse-literal))))
1688
1689 (defsubst elmo-imap4-parse-nil ()
1690   (if (looking-at "NIL")
1691       (goto-char (match-end 0))))
1692
1693 (defsubst elmo-imap4-parse-nstring ()
1694   (or (elmo-imap4-parse-string)
1695       (and (elmo-imap4-parse-nil)
1696            nil)))
1697
1698 (defsubst elmo-imap4-parse-astring ()
1699   (or (elmo-imap4-parse-string)
1700       (buffer-substring (point)
1701                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1702                             (goto-char (1- (match-end 0)))
1703                           (end-of-line)
1704                           (point)))))
1705
1706 (defsubst elmo-imap4-parse-address ()
1707   (let (address)
1708     (when (eq (char-after (point)) ?\()
1709       (elmo-imap4-forward)
1710       (setq address (vector (prog1 (elmo-imap4-parse-nstring)
1711                               (elmo-imap4-forward))
1712                             (prog1 (elmo-imap4-parse-nstring)
1713                               (elmo-imap4-forward))
1714                             (prog1 (elmo-imap4-parse-nstring)
1715                               (elmo-imap4-forward))
1716                             (elmo-imap4-parse-nstring)))
1717       (when (eq (char-after (point)) ?\))
1718         (elmo-imap4-forward)
1719         address))))
1720
1721 (defsubst elmo-imap4-parse-address-list ()
1722   (if (eq (char-after (point)) ?\()
1723       (let (address addresses)
1724         (elmo-imap4-forward)
1725         (while (and (not (eq (char-after (point)) ?\)))
1726                     ;; next line for MS Exchange bug
1727                     (progn (and (eq (char-after (point)) ? ) (elmo-imap4-forward)) t)
1728                     (setq address (elmo-imap4-parse-address)))
1729           (setq addresses (cons address addresses)))
1730         (when (eq (char-after (point)) ?\))
1731           (elmo-imap4-forward)
1732           (nreverse addresses)))
1733     (assert (elmo-imap4-parse-nil))))
1734
1735 (defsubst elmo-imap4-parse-mailbox ()
1736   (let ((mailbox (elmo-imap4-parse-astring)))
1737     (if (string-equal "INBOX" (upcase mailbox))
1738         "INBOX"
1739       mailbox)))
1740
1741 (defun elmo-imap4-parse-greeting ()
1742   "Parse a IMAP greeting."
1743   (cond ((looking-at "\\* OK ")
1744          (setq elmo-imap4-status 'nonauth))
1745         ((looking-at "\\* PREAUTH ")
1746          (setq elmo-imap4-status 'auth))
1747         ((looking-at "\\* BYE ")
1748          (setq elmo-imap4-status 'closed))))
1749
1750 (defun elmo-imap4-parse-response ()
1751   "Parse a IMAP command response."
1752   (let (token)
1753     (case (setq token (elmo-read (current-buffer)))
1754       (+ (progn
1755            (skip-chars-forward " ")
1756            (list 'continue-req (buffer-substring (point) (point-max)))))
1757       (* (case (prog1 (setq token (elmo-read (current-buffer)))
1758                  (elmo-imap4-forward))
1759            (OK         (elmo-imap4-parse-resp-text-code))
1760            (NO         (elmo-imap4-parse-resp-text-code))
1761            (BAD        (elmo-imap4-parse-resp-text-code))
1762            (BYE        (elmo-imap4-parse-bye))
1763            (FLAGS      (list 'flags
1764                              (elmo-imap4-parse-flag-list)))
1765            (LIST       (list 'list (elmo-imap4-parse-data-list)))
1766            (LSUB       (list 'lsub (elmo-imap4-parse-data-list)))
1767            (SEARCH     (list
1768                         'search
1769                         (elmo-read (concat "("
1770                                       (buffer-substring (point) (point-max))
1771                                       ")"))))
1772            (STATUS     (elmo-imap4-parse-status))
1773            ;; Added
1774            (NAMESPACE  (elmo-imap4-parse-namespace))
1775            (CAPABILITY (list 'capability
1776                              (elmo-read
1777                               (concat "(" (downcase (buffer-substring
1778                                                      (point) (point-max)))
1779                                       ")"))))
1780            (ACL        (elmo-imap4-parse-acl))
1781            (t       (case (prog1 (elmo-read (current-buffer))
1782                             (elmo-imap4-forward))
1783                       (EXISTS  (list 'exists token))
1784                       (RECENT  (list 'recent token))
1785                       (EXPUNGE (list 'expunge token))
1786                       (FETCH   (elmo-imap4-parse-fetch token))
1787                       (t       (list 'garbage (buffer-string)))))))
1788       (t (if (not (string-match elmo-imap4-seq-prefix (symbol-name token)))
1789              (list 'garbage (buffer-string))
1790            (case (prog1 (elmo-read (current-buffer))
1791                    (elmo-imap4-forward))
1792              (OK  (progn
1793                     (setq elmo-imap4-parsing nil)
1794                     (setq token (symbol-name token))
1795                     (elmo-unintern token)
1796                     (elmo-imap4-debug "*%s* OK arrived" token)
1797                     (setq elmo-imap4-reached-tag token)
1798                     (list 'ok (elmo-imap4-parse-resp-text-code))))
1799              (NO  (progn
1800                     (setq elmo-imap4-parsing nil)
1801                     (setq token (symbol-name token))
1802                     (elmo-unintern token)
1803                     (elmo-imap4-debug "*%s* NO arrived" token)
1804                     (setq elmo-imap4-reached-tag token)
1805                     (let (code text)
1806                       (when (eq (char-after (point)) ?\[)
1807                         (setq code (buffer-substring (point)
1808                                                      (search-forward "]")))
1809                         (elmo-imap4-forward))
1810                       (setq text (buffer-substring (point) (point-max)))
1811                       (list 'no (list code text)))))
1812              (BAD (progn
1813                     (setq elmo-imap4-parsing nil)
1814                     (elmo-imap4-debug "*%s* BAD arrived" token)
1815                     (setq token (symbol-name token))
1816                     (elmo-unintern token)
1817                     (setq elmo-imap4-reached-tag token)
1818                     (let (code text)
1819                       (when (eq (char-after (point)) ?\[)
1820                         (setq code (buffer-substring (point)
1821                                                      (search-forward "]")))
1822                         (elmo-imap4-forward))
1823                       (setq text (buffer-substring (point) (point-max)))
1824                       (list 'bad (list code text)))))
1825              (t   (list 'garbage (buffer-string)))))))))
1826
1827 (defun elmo-imap4-parse-bye ()
1828   (let (code text)
1829     (when (eq (char-after (point)) ?\[)
1830       (setq code (buffer-substring (point)
1831                                    (search-forward "]")))
1832       (elmo-imap4-forward))
1833     (setq text (buffer-substring (point) (point-max)))
1834     (list 'bye (list code text))))
1835
1836 (defun elmo-imap4-parse-text ()
1837   (goto-char (point-min))
1838   (when (search-forward "[" nil t)
1839     (search-forward "]")
1840     (elmo-imap4-forward))
1841   (list 'text (buffer-substring (point) (point-max))))
1842
1843 (defun elmo-imap4-parse-resp-text-code ()
1844   (when (eq (char-after (point)) ?\[)
1845     (elmo-imap4-forward)
1846     (cond ((search-forward "PERMANENTFLAGS " nil t)
1847            (list 'permanentflags (elmo-imap4-parse-flag-list)))
1848           ((search-forward "UIDNEXT " nil t)
1849            (list 'uidnext (elmo-read (current-buffer))))
1850           ((search-forward "UNSEEN " nil t)
1851            (list 'unseen (elmo-read (current-buffer))))
1852           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
1853            (list 'uidvalidity (match-string 1)))
1854           ((search-forward "READ-ONLY" nil t)
1855            (list 'read-only t))
1856           ((search-forward "READ-WRITE" nil t)
1857            (list 'read-write t))
1858           ((search-forward "NEWNAME " nil t)
1859            (let (oldname newname)
1860              (setq oldname (elmo-imap4-parse-string))
1861              (elmo-imap4-forward)
1862              (setq newname (elmo-imap4-parse-string))
1863              (list 'newname newname oldname)))
1864           ((search-forward "TRYCREATE" nil t)
1865            (list 'trycreate t))
1866           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
1867            (list 'appenduid
1868                  (list (match-string 1)
1869                        (string-to-number (match-string 2)))))
1870           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
1871            (list 'copyuid (list (match-string 1)
1872                                 (match-string 2)
1873                                 (match-string 3))))
1874           ((search-forward "ALERT] " nil t)
1875            (message "IMAP server information: %s"
1876                     (buffer-substring (point) (point-max))))
1877           (t (list 'unknown)))))
1878
1879 (defun elmo-imap4-parse-data-list ()
1880   (let (flags delimiter mailbox)
1881     (setq flags (elmo-imap4-parse-flag-list))
1882     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
1883       (setq delimiter (match-string 1))
1884       (goto-char (1+ (match-end 0)))
1885       (when (setq mailbox (elmo-imap4-parse-mailbox))
1886         (list mailbox flags delimiter)))))
1887
1888 (defsubst elmo-imap4-parse-header-list ()
1889   (when (eq (char-after (point)) ?\()
1890     (let (strlist)
1891       (while (not (eq (char-after (point)) ?\)))
1892         (elmo-imap4-forward)
1893         (push (elmo-imap4-parse-astring) strlist))
1894       (elmo-imap4-forward)
1895       (nreverse strlist))))
1896
1897 (defsubst elmo-imap4-parse-fetch-body-section ()
1898   (let ((section
1899          (buffer-substring (point)
1900                            (1-
1901                             (progn (re-search-forward "[] ]" nil t)
1902                                    (point))))))
1903     (if (eq (char-before) ? )
1904         (prog1
1905             (mapconcat 'identity
1906                        (cons section (elmo-imap4-parse-header-list)) " ")
1907           (search-forward "]" nil t))
1908       section)))
1909
1910 (defun elmo-imap4-parse-fetch (response)
1911   (when (eq (char-after (point)) ?\()
1912     (let (element list)
1913       (while (not (eq (char-after (point)) ?\)))
1914         (elmo-imap4-forward)
1915         (let ((token (elmo-imap4-fetch-read (current-buffer))))
1916           (elmo-imap4-forward)
1917           (setq element
1918                 (cond ((eq token 'UID)
1919                        (list 'uid (condition-case nil
1920                                       (elmo-read (current-buffer))
1921                                     (error nil))))
1922                       ((eq token 'FLAGS)
1923                        (list 'flags (elmo-imap4-parse-flag-list)))
1924                       ((eq token 'ENVELOPE)
1925                        (list 'envelope (elmo-imap4-parse-envelope)))
1926                       ((eq token 'INTERNALDATE)
1927                        (list 'internaldate (elmo-imap4-parse-string)))
1928                       ((eq token 'RFC822)
1929                        (list 'rfc822 (elmo-imap4-parse-nstring)))
1930                       ((eq token (intern elmo-imap4-rfc822-header))
1931                        (list 'rfc822header (elmo-imap4-parse-nstring)))
1932                       ((eq token (intern elmo-imap4-rfc822-text))
1933                        (list 'rfc822text (elmo-imap4-parse-nstring)))
1934                       ((eq token (intern elmo-imap4-rfc822-size))
1935                        (list 'rfc822size (elmo-read (current-buffer))))
1936                       ((eq token 'BODY)
1937                        (if (eq (char-before) ?\[)
1938                            (list
1939                             'bodydetail
1940                             (upcase (elmo-imap4-parse-fetch-body-section))
1941                             (and
1942                              (eq (char-after (point)) ?<)
1943                              (buffer-substring (1+ (point))
1944                                                (progn
1945                                                  (search-forward ">" nil t)
1946                                                  (point))))
1947                             (progn (elmo-imap4-forward)
1948                                    (elmo-imap4-parse-nstring)))
1949                          (list 'body (elmo-imap4-parse-body))))
1950                       ((eq token 'BODYSTRUCTURE)
1951                        (list 'bodystructure (elmo-imap4-parse-body)))))
1952           (setq list (cons element list))))
1953       (and elmo-imap4-fetch-callback
1954            (elmo-imap4-fetch-callback list elmo-imap4-fetch-callback-data))
1955       (list 'fetch list))))
1956
1957 (defun elmo-imap4-parse-status ()
1958   (let ((mailbox (elmo-imap4-parse-mailbox))
1959         status)
1960     (when (and mailbox (search-forward "(" nil t))
1961       (while (not (eq (char-after (point)) ?\)))
1962         (setq status
1963               (cons
1964                (let ((token (elmo-read (current-buffer))))
1965                  (cond ((eq token 'MESSAGES)
1966                         (list 'messages (elmo-read (current-buffer))))
1967                        ((eq token 'RECENT)
1968                         (list 'recent (elmo-read (current-buffer))))
1969                        ((eq token 'UIDNEXT)
1970                         (list 'uidnext (elmo-read (current-buffer))))
1971                        ((eq token 'UIDVALIDITY)
1972                         (and (looking-at " \\([0-9]+\\)")
1973                              (prog1 (list 'uidvalidity (match-string 1))
1974                                (goto-char (match-end 1)))))
1975                        ((eq token 'UNSEEN)
1976                         (list 'unseen (elmo-read (current-buffer))))
1977                        (t
1978                         (message
1979                          "Unknown status data %s in mailbox %s ignored"
1980                          token mailbox))))
1981                status))))
1982     (and elmo-imap4-status-callback
1983          (funcall elmo-imap4-status-callback
1984                   status
1985                   elmo-imap4-status-callback-data))
1986     (list 'status status)))
1987
1988
1989 (defmacro elmo-imap4-value (value)
1990   (` (if (eq (, value) 'NIL) nil
1991        (, value))))
1992
1993 (defmacro elmo-imap4-nth (pos list)
1994   (` (let ((value (nth (, pos) (, list))))
1995        (elmo-imap4-value value))))
1996
1997 (defun elmo-imap4-parse-namespace ()
1998   (list 'namespace
1999         (nconc
2000          (copy-sequence elmo-imap4-extra-namespace-alist)
2001          (elmo-imap4-parse-namespace-subr
2002           (elmo-read (concat "(" (buffer-substring
2003                                   (point) (point-max))
2004                              ")"))))))
2005
2006 (defun elmo-imap4-parse-namespace-subr (ns)
2007   (let (prefix delim namespace-alist default-delim)
2008     ;; 0: personal, 1: other, 2: shared
2009     (dotimes (i 3)
2010       (setq namespace-alist
2011             (nconc namespace-alist
2012                    (delq nil
2013                          (mapcar
2014                           (lambda (namespace)
2015                             (setq prefix (elmo-imap4-nth 0 namespace)
2016                                   delim (elmo-imap4-nth 1 namespace))
2017                             (if (and prefix delim
2018                                      (string-match
2019                                       (concat (regexp-quote delim) "\\'")
2020                                       prefix))
2021                                 (setq prefix (substring prefix 0
2022                                                         (match-beginning 0))))
2023                             (if (eq (length prefix) 0)
2024                                 (progn (setq default-delim delim) nil)
2025                               (cons
2026                                (concat "^"
2027                                        (if (string= (downcase prefix) "inbox")
2028                                            "[Ii][Nn][Bb][Oo][Xx]"
2029                                          (regexp-quote prefix))
2030                                        ".*$")
2031                                delim)))
2032                           (elmo-imap4-nth i ns))))))
2033     (if default-delim
2034         (setq namespace-alist
2035               (nconc namespace-alist
2036                      (list (cons "^.*$" default-delim)))))
2037     namespace-alist))
2038
2039 (defun elmo-imap4-parse-acl ()
2040   (let ((mailbox (elmo-imap4-parse-mailbox))
2041         identifier rights acl)
2042     (while (eq (char-after (point)) ?\ )
2043       (elmo-imap4-forward)
2044       (setq identifier (elmo-imap4-parse-astring))
2045       (elmo-imap4-forward)
2046       (setq rights (elmo-imap4-parse-astring))
2047       (setq acl (append acl (list (cons identifier rights)))))
2048     (list 'acl acl mailbox)))
2049
2050 (defun elmo-imap4-parse-flag-list ()
2051   (let ((str (buffer-substring (+ (point) 1)
2052                                (progn (search-forward ")" nil t)
2053                                       (- (point) 1)))))
2054     (unless (eq (length str) 0)
2055       (split-string str))))
2056
2057 (defun elmo-imap4-parse-envelope ()
2058   (when (eq (char-after (point)) ?\()
2059     (elmo-imap4-forward)
2060     (vector (prog1 (elmo-imap4-parse-nstring);; date
2061               (elmo-imap4-forward))
2062             (prog1 (elmo-imap4-parse-nstring);; subject
2063               (elmo-imap4-forward))
2064             (prog1 (elmo-imap4-parse-address-list);; from
2065               (elmo-imap4-forward))
2066             (prog1 (elmo-imap4-parse-address-list);; sender
2067               (elmo-imap4-forward))
2068             (prog1 (elmo-imap4-parse-address-list);; reply-to
2069               (elmo-imap4-forward))
2070             (prog1 (elmo-imap4-parse-address-list);; to
2071               (elmo-imap4-forward))
2072             (prog1 (elmo-imap4-parse-address-list);; cc
2073               (elmo-imap4-forward))
2074             (prog1 (elmo-imap4-parse-address-list);; bcc
2075               (elmo-imap4-forward))
2076             (prog1 (elmo-imap4-parse-nstring);; in-reply-to
2077               (elmo-imap4-forward))
2078             (prog1 (elmo-imap4-parse-nstring);; message-id
2079               (elmo-imap4-forward)))))
2080
2081 (defsubst elmo-imap4-parse-string-list ()
2082   (cond ((eq (char-after (point)) ?\();; body-fld-param
2083          (let (strlist str)
2084            (elmo-imap4-forward)
2085            (while (setq str (elmo-imap4-parse-string))
2086              (push str strlist)
2087              (elmo-imap4-forward))
2088            (nreverse strlist)))
2089         ((elmo-imap4-parse-nil)
2090          nil)))
2091
2092 (defun elmo-imap4-parse-body-extension ()
2093   (if (eq (char-after (point)) ?\()
2094       (let (b-e)
2095         (elmo-imap4-forward)
2096         (push (elmo-imap4-parse-body-extension) b-e)
2097         (while (eq (char-after (point)) ?\ )
2098           (elmo-imap4-forward)
2099           (push (elmo-imap4-parse-body-extension) b-e))
2100         (assert (eq (char-after (point)) ?\)))
2101         (elmo-imap4-forward)
2102         (nreverse b-e))
2103     (or (elmo-imap4-parse-number)
2104         (elmo-imap4-parse-nstring))))
2105
2106 (defsubst elmo-imap4-parse-body-ext ()
2107   (let (ext)
2108     (when (eq (char-after (point)) ?\ );; body-fld-dsp
2109       (elmo-imap4-forward)
2110       (let (dsp)
2111         (if (eq (char-after (point)) ?\()
2112             (progn
2113               (elmo-imap4-forward)
2114               (push (elmo-imap4-parse-string) dsp)
2115               (elmo-imap4-forward)
2116               (push (elmo-imap4-parse-string-list) dsp)
2117               (elmo-imap4-forward))
2118           (assert (elmo-imap4-parse-nil)))
2119         (push (nreverse dsp) ext))
2120       (when (eq (char-after (point)) ?\ );; body-fld-lang
2121         (elmo-imap4-forward)
2122         (if (eq (char-after (point)) ?\()
2123             (push (elmo-imap4-parse-string-list) ext)
2124           (push (elmo-imap4-parse-nstring) ext))
2125         (while (eq (char-after (point)) ?\ );; body-extension
2126           (elmo-imap4-forward)
2127           (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
2128     ext))
2129
2130 (defun elmo-imap4-parse-body ()
2131   (let (body)
2132     (when (eq (char-after (point)) ?\()
2133       (elmo-imap4-forward)
2134       (if (eq (char-after (point)) ?\()
2135           (let (subbody)
2136             (while (and (eq (char-after (point)) ?\()
2137                         (setq subbody (elmo-imap4-parse-body)))
2138               (push subbody body))
2139             (elmo-imap4-forward)
2140             (push (elmo-imap4-parse-string) body);; media-subtype
2141             (when (eq (char-after (point)) ?\ );; body-ext-mpart:
2142               (elmo-imap4-forward)
2143               (if (eq (char-after (point)) ?\();; body-fld-param
2144                   (push (elmo-imap4-parse-string-list) body)
2145                 (push (and (elmo-imap4-parse-nil) nil) body))
2146               (setq body
2147                     (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
2148             (assert (eq (char-after (point)) ?\)))
2149             (elmo-imap4-forward)
2150             (nreverse body))
2151
2152         (push (elmo-imap4-parse-string) body);; media-type
2153         (elmo-imap4-forward)
2154         (push (elmo-imap4-parse-string) body);; media-subtype
2155         (elmo-imap4-forward)
2156         ;; next line for Sun SIMS bug
2157         (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
2158         (if (eq (char-after (point)) ?\();; body-fld-param
2159             (push (elmo-imap4-parse-string-list) body)
2160           (push (and (elmo-imap4-parse-nil) nil) body))
2161         (elmo-imap4-forward)
2162         (push (elmo-imap4-parse-nstring) body);; body-fld-id
2163         (elmo-imap4-forward)
2164         (push (elmo-imap4-parse-nstring) body);; body-fld-desc
2165         (elmo-imap4-forward)
2166         (push (elmo-imap4-parse-string) body);; body-fld-enc
2167         (elmo-imap4-forward)
2168         (push (elmo-imap4-parse-number) body);; body-fld-octets
2169
2170         ;; ok, we're done parsing the required parts, what comes now is one
2171         ;; of three things:
2172         ;;
2173         ;; envelope       (then we're parsing body-type-msg)
2174         ;; body-fld-lines (then we're parsing body-type-text)
2175         ;; body-ext-1part (then we're parsing body-type-basic)
2176         ;;
2177         ;; the problem is that the two first are in turn optionally followed
2178         ;; by the third.  So we parse the first two here (if there are any)...
2179
2180         (when (eq (char-after (point)) ?\ )
2181           (elmo-imap4-forward)
2182           (let (lines)
2183             (cond ((eq (char-after (point)) ?\();; body-type-msg:
2184                    (push (elmo-imap4-parse-envelope) body);; envelope
2185                    (elmo-imap4-forward)
2186                    (push (elmo-imap4-parse-body) body);; body
2187                    (elmo-imap4-forward)
2188                    (push (elmo-imap4-parse-number) body));; body-fld-lines
2189                   ((setq lines (elmo-imap4-parse-number));; body-type-text:
2190                    (push lines body));; body-fld-lines
2191                   (t
2192                    (backward-char)))));; no match...
2193
2194         ;; ...and then parse the third one here...
2195
2196         (when (eq (char-after (point)) ?\ );; body-ext-1part:
2197           (elmo-imap4-forward)
2198           (push (elmo-imap4-parse-nstring) body);; body-fld-md5
2199           (setq body
2200                 (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part..
2201
2202         (assert (eq (char-after (point)) ?\)))
2203         (elmo-imap4-forward)
2204         (nreverse body)))))
2205
2206 (require 'product)
2207 (product-provide (provide 'elmo-imap4) (require 'elmo-version))
2208
2209 ;;; elmo-imap4.el ends here