elmo/elmo-imap4.el

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