elmo/elmo-imap4.el

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