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 ;;;(elmo-imap4-send-command-wait session "close")
 647   (elmo-imap4-send-command-wait
 648    (elmo-imap4-get-session old-spec)
 649    (list "rename "
 650          (elmo-imap4-mailbox
 651           (elmo-imap4-spec-mailbox old-spec))
 652          " "
 653          (elmo-imap4-mailbox
 654           (elmo-imap4-spec-mailbox new-spec)))))
 655
 656 (defun elmo-imap4-max-of-folder (spec)
 657   (let ((session (elmo-imap4-get-session spec))
 658          (killed (and elmo-use-killed-list
 659                       (elmo-msgdb-killed-list-load
 660                        (elmo-msgdb-expand-path spec))))
 661         status)
 662     (with-current-buffer (elmo-network-session-buffer session)
 663       (setq elmo-imap4-status-callback nil)
 664       (setq elmo-imap4-status-callback-data nil))
 665     (setq status (elmo-imap4-response-value
 666                   (elmo-imap4-send-command-wait
 667                    session
 668                    (list "status "
 669                          (elmo-imap4-mailbox
 670                           (elmo-imap4-spec-mailbox spec))
 671                          " (uidnext messages)"))
 672                   'status))
 673     (cons
 674      (- (elmo-imap4-response-value status 'uidnext) 1)
 675      (if killed
 676          (-
 677           (elmo-imap4-response-value status 'messages)
 678           (elmo-msgdb-killed-list-length killed))
 679        (elmo-imap4-response-value status 'messages)))))
 680
 681 (defun elmo-imap4-folder-diff (spec folder &optional number-list)
 682   (if elmo-use-server-diff
 683       (elmo-imap4-server-diff spec)
 684     (elmo-generic-folder-diff spec folder number-list)))
 685
 686 (defun elmo-imap4-get-session (spec &optional if-exists)
 687   (elmo-network-get-session
 688    'elmo-imap4-session
 689    "IMAP"
 690    (elmo-imap4-spec-hostname spec)
 691    (elmo-imap4-spec-port spec)
 692    (elmo-imap4-spec-username spec)
 693    (elmo-imap4-spec-auth spec)
 694    (elmo-imap4-spec-stream-type spec)
 695    if-exists))
 696
 697 (defun elmo-imap4-commit (spec)
 698   (if (elmo-imap4-plugged-p spec)
 699       (let ((session (elmo-imap4-get-session spec 'if-exists)))
 700         (when session
 701           (if (string=
 702                (elmo-imap4-session-current-mailbox-internal session)
 703                (elmo-imap4-spec-mailbox spec))
 704               (if elmo-imap4-use-select-to-update-status
 705                   (elmo-imap4-session-select-mailbox
 706                    session
 707                    (elmo-imap4-spec-mailbox spec)
 708                    'force)
 709                 (elmo-imap4-session-check session)))))))
 710
 711 (defun elmo-imap4-session-select-mailbox (session mailbox
 712                                                   &optional force no-error)
 713   "Select MAILBOX in SESSION.
 714 If optional argument FORCE is non-nil, select mailbox even if current mailbox
 715 is same as MAILBOX.
 716 If second optional argument NO-ERROR is non-nil, don't cause an error when
 717 selecting folder was failed.
 718 Returns response value if selecting folder succeed. "
 719   (when (or force
 720             (not (string=
 721                   (elmo-imap4-session-current-mailbox-internal session)
 722                   mailbox)))
 723     (let (response result)
 724       (unwind-protect
 725           (setq response
 726                 (elmo-imap4-read-response
 727                  session
 728                  (elmo-imap4-send-command
 729                   session
 730                   (list
 731                    "select "
 732                    (elmo-imap4-mailbox mailbox)))))
 733         (if (setq result (elmo-imap4-response-ok-p response))
 734             (progn
 735               (elmo-imap4-session-set-current-mailbox-internal session mailbox)
 736               (elmo-imap4-session-set-read-only-internal
 737                session
 738                (nth 1 (assq 'read-only (assq 'ok response)))))
 739           (elmo-imap4-session-set-current-mailbox-internal session nil)
 740           (unless no-error
 741             (error (or
 742                     (elmo-imap4-response-error-text response)
 743                     (format "Select %s failed" mailbox))))))
 744       (and result response))))
 745
 746 (defun elmo-imap4-check-validity (spec validity-file)
 747 ;;; Not used.
 748 ;;;(elmo-imap4-send-command-wait
 749 ;;;(elmo-imap4-get-session spec)
 750 ;;;(list "status "
 751 ;;;      (elmo-imap4-mailbox
 752 ;;;       (elmo-imap4-spec-mailbox spec))
 753 ;;;      " (uidvalidity)")))
 754   )
 755
 756 (defun elmo-imap4-sync-validity  (spec validity-file)
 757   ;; Not used.
 758   )
 759
 760 (defun elmo-imap4-list (spec flag)
 761   (let ((session (elmo-imap4-get-session spec)))
 762     (elmo-imap4-session-select-mailbox session
 763                                        (elmo-imap4-spec-mailbox spec))
 764     (elmo-imap4-response-value
 765      (elmo-imap4-send-command-wait
 766       session
 767       (format (if elmo-imap4-use-uid "uid search %s"
 768                 "search %s") flag))
 769      'search)))
 770
 771 (defun elmo-imap4-list-folder (spec)
 772   (let ((killed (and elmo-use-killed-list
 773                      (elmo-msgdb-killed-list-load
 774                       (elmo-msgdb-expand-path spec))))
 775         numbers)
 776     (setq numbers (elmo-imap4-list spec "all"))
 777     (elmo-living-messages numbers killed)))
 778
 779 (defun elmo-imap4-list-folder-unread (spec number-alist mark-alist
 780                                            unread-marks)
 781   (if (and (elmo-imap4-plugged-p spec)
 782            (elmo-imap4-use-flag-p spec))
 783       (elmo-imap4-list spec "unseen")
 784     (elmo-generic-list-folder-unread spec number-alist mark-alist
 785                                      unread-marks)))
 786
 787 (defun elmo-imap4-list-folder-important (spec number-alist)
 788   (if (and (elmo-imap4-plugged-p spec)
 789            (elmo-imap4-use-flag-p spec))
 790       (elmo-imap4-list spec "flagged")))
 791
 792 (defmacro elmo-imap4-detect-search-charset (string)
 793   (` (with-temp-buffer
 794        (insert (, string))
 795        (detect-mime-charset-region (point-min) (point-max)))))
 796
 797 (defun elmo-imap4-search-internal-primitive (spec session filter from-msgs)
 798   (let ((search-key (elmo-filter-key filter))
 799         (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to"))
 800         charset)
 801     (cond
 802      ((string= "last" search-key)
 803       (let ((numbers (or from-msgs (elmo-imap4-list-folder spec))))
 804         (nthcdr (max (- (length numbers)
 805                         (string-to-int (elmo-filter-value filter)))
 806                      0)
 807                 numbers)))
 808      ((string= "first" search-key)
 809       (let* ((numbers (or from-msgs (elmo-imap4-list-folder spec)))
 810              (rest (nthcdr (string-to-int (elmo-filter-value filter) )
 811                            numbers)))
 812         (mapcar '(lambda (x) (delete x numbers)) rest)
 813         numbers))
 814      ((or (string= "since" search-key)
 815           (string= "before" search-key))
 816       (setq search-key (concat "sent" search-key))
 817       (elmo-imap4-response-value
 818        (elmo-imap4-send-command-wait session
 819                                      (format
 820                                       (if elmo-imap4-use-uid
 821                                           "uid search %s%s%s %s"
 822                                         "search %s%s%s %s")
 823                                       (if from-msgs
 824                                           (concat
 825                                            (if elmo-imap4-use-uid "uid ")
 826                                            (cdr
 827                                             (car
 828                                              (elmo-imap4-make-number-set-list
 829                                               from-msgs)))
 830                                            " ")
 831                                         "")
 832                                       (if (eq (elmo-filter-type filter)
 833                                               'unmatch)
 834                                           "not " "")
 835                                       search-key
 836                                       (elmo-date-get-description
 837                                        (elmo-date-get-datevec
 838                                         (elmo-filter-value filter)))))
 839        'search))
 840      (t
 841       (setq charset
 842             (if (eq (length (elmo-filter-value filter)) 0)
 843                 (setq charset 'us-ascii)
 844               (elmo-imap4-detect-search-charset
 845                (elmo-filter-value filter))))
 846       (elmo-imap4-response-value
 847        (elmo-imap4-send-command-wait session
 848                                      (list
 849                                       (if elmo-imap4-use-uid "uid ")
 850                                       "search "
 851                                       "CHARSET "
 852                                       (elmo-imap4-astring
 853                                        (symbol-name charset))
 854                                       " "
 855                                       (if from-msgs
 856                                           (concat
 857                                            (if elmo-imap4-use-uid "uid ")
 858                                            (cdr
 859                                             (car
 860                                              (elmo-imap4-make-number-set-list
 861                                               from-msgs)))
 862                                            " ")
 863                                         "")
 864                                       (if (eq (elmo-filter-type filter)
 865                                               'unmatch)
 866                                           "not " "")
 867                                       (format "%s%s "
 868                                               (if (member
 869                                                    (elmo-filter-key filter)
 870                                                    imap-search-keys)
 871                                                   ""
 872                                                 "header ")
 873                                               (elmo-filter-key filter))
 874                                       (elmo-imap4-astring
 875                                        (encode-mime-charset-string
 876                                         (elmo-filter-value filter) charset))))
 877        'search)))))
 878
 879 (defun elmo-imap4-search-internal (spec session condition from-msgs)
 880   (let (result)
 881     (cond
 882      ((vectorp condition)
 883       (setq result (elmo-imap4-search-internal-primitive
 884                     spec session condition from-msgs)))
 885      ((eq (car condition) 'and)
 886       (setq result (elmo-imap4-search-internal spec session (nth 1 condition)
 887                                                from-msgs)
 888             result (elmo-list-filter result
 889                                      (elmo-imap4-search-internal
 890                                       spec session (nth 2 condition)
 891                                       from-msgs))))
 892      ((eq (car condition) 'or)
 893       (setq result (elmo-imap4-search-internal
 894                     spec session (nth 1 condition) from-msgs)
 895             result (elmo-uniq-list
 896                     (nconc result
 897                            (elmo-imap4-search-internal
 898                             spec session (nth 2 condition) from-msgs)))
 899             result (sort result '<))))))
 900
 901
 902 (defun elmo-imap4-search (spec condition &optional from-msgs)
 903   (save-excursion
 904     (let ((session (elmo-imap4-get-session spec)))
 905       (elmo-imap4-session-select-mailbox
 906        session
 907        (elmo-imap4-spec-mailbox spec))
 908       (elmo-imap4-search-internal spec session condition from-msgs))))
 909
 910 (defun elmo-imap4-use-flag-p (spec)
 911   (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp
 912                      (elmo-imap4-spec-mailbox spec))))
 913
 914 (static-cond
 915  ((fboundp 'float)
 916   ;; Emacs can parse dot symbol.
 917   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 918   (defvar elmo-imap4-rfc822-text "RFC822\.TEXT")
 919   (defvar elmo-imap4-rfc822-header "RFC822\.HEADER")
 920   (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
 921   (defvar elmo-imap4-header-fields "HEADER\.FIELDS")
 922   (defmacro elmo-imap4-replace-dot-symbols ()) ;; noop
 923   (defalias 'elmo-imap4-fetch-read 'read)
 924   )
 925  (t
 926   ;;; For Nemacs.
 927   ;; Cannot parse dot symbol.
 928   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 929   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 930   (defvar elmo-imap4-rfc822-size "RFC822_SIZE")
 931   (defvar elmo-imap4-rfc822-text "RFC822_TEXT")
 932   (defvar elmo-imap4-rfc822-header "RFC822_HEADER")
 933   (defvar elmo-imap4-header-fields "HEADER_FIELDS")
 934   (defun elmo-imap4-fetch-read (buffer)
 935     (with-current-buffer buffer
 936       (let ((beg (point))
 937             token)
 938         (when (re-search-forward "[[ ]" nil t)
 939           (goto-char (match-beginning 0))
 940           (setq token (buffer-substring beg (point)))
 941           (cond ((string= token "RFC822.SIZE")
 942                  (intern elmo-imap4-rfc822-size))
 943                 ((string= token "RFC822.HEADER")
 944                  (intern elmo-imap4-rfc822-header))
 945                 ((string= token "RFC822.TEXT")
 946                  (intern elmo-imap4-rfc822-text))
 947                 ((string= token "HEADER\.FIELDS")
 948                  (intern elmo-imap4-header-fields))
 949                 (t (goto-char beg)
 950                    (elmo-read (current-buffer))))))))))
 951
 952 (defun elmo-imap4-make-number-set-list (msg-list &optional chop-length)
 953   "Make RFC2060's message set specifier from MSG-LIST.
 954 Returns a list of (NUMBER . SET-STRING).
 955 SET-STRING is the message set specifier described in RFC2060.
 956 NUMBER is contained message number in SET-STRING.
 957 Every SET-STRING does not contain number of messages longer than CHOP-LENGTH.
 958 If CHOP-LENGTH is not specified, message set is not chopped."
 959   (let (count cont-list set-list)
 960     (setq msg-list (sort (copy-sequence msg-list) '<))
 961     (while msg-list
 962       (setq cont-list nil)
 963       (setq count 0)
 964       (unless chop-length
 965         (setq chop-length (length msg-list)))
 966       (while (and (not (null msg-list))
 967                   (< count chop-length))
 968         (setq cont-list
 969               (elmo-number-set-append
 970                cont-list (car msg-list)))
 971         (incf count)
 972         (setq msg-list (cdr msg-list)))
 973       (setq set-list
 974             (cons
 975              (cons
 976               count
 977               (mapconcat
 978                (lambda (x)
 979                  (cond ((consp x)
 980                         (format "%s:%s" (car x) (cdr x)))
 981                        ((integerp x)
 982                         (int-to-string x))))
 983                cont-list
 984                ","))
 985              set-list)))
 986     (nreverse set-list)))
 987
 988 ;;
 989 ;; set mark
 990 ;; read-mark -> "\\Seen"
 991 ;; important -> "\\Flagged"
 992 ;;
 993 ;; (delete -> \\Deleted)
 994 (defun elmo-imap4-mark-set-on-msgs (spec msgs mark &optional unmark no-expunge)
 995   "SET flag of MSGS as MARK.
 996 If optional argument UNMARK is non-nil, unmark."
 997   (let ((session (elmo-imap4-get-session spec))
 998         set-list)
 999     (elmo-imap4-session-select-mailbox session
1000                                        (elmo-imap4-spec-mailbox spec))
1001     (setq set-list (elmo-imap4-make-number-set-list msgs))
1002     (when set-list
1003       (with-current-buffer (elmo-network-session-buffer session)
1004         (setq elmo-imap4-fetch-callback nil)
1005         (setq elmo-imap4-fetch-callback-data nil))
1006       (elmo-imap4-send-command-wait
1007        session
1008        (format
1009         (if elmo-imap4-use-uid
1010             "uid store %s %sflags.silent (%s)"
1011           "store %s %sflags.silent (%s)")
1012         (cdr (car set-list))
1013         (if unmark "-" "+")
1014         mark))
1015       (unless no-expunge
1016         (elmo-imap4-send-command-wait session "expunge")))
1017     t))
1018
1019 (defun elmo-imap4-mark-as-important (spec msgs)
1020   (and (elmo-imap4-use-flag-p spec)
1021        (elmo-imap4-mark-set-on-msgs spec msgs "\\Flagged" nil 'no-expunge)))
1022
1023 (defun elmo-imap4-mark-as-read (spec msgs)
1024   (and (elmo-imap4-use-flag-p spec)
1025        (elmo-imap4-mark-set-on-msgs spec msgs "\\Seen" nil 'no-expunge)))
1026
1027 (defun elmo-imap4-unmark-important (spec msgs)
1028   (and (elmo-imap4-use-flag-p spec)
1029        (elmo-imap4-mark-set-on-msgs spec msgs "\\Flagged" 'unmark
1030                                     'no-expunge)))
1031
1032 (defun elmo-imap4-mark-as-unread (spec msgs)
1033   (and (elmo-imap4-use-flag-p spec)
1034        (elmo-imap4-mark-set-on-msgs spec msgs "\\Seen" 'unmark 'no-expunge)))
1035
1036 (defun elmo-imap4-delete-msgs (spec msgs)
1037   (elmo-imap4-mark-set-on-msgs spec msgs "\\Deleted"))
1038
1039 (defun elmo-imap4-delete-msgs-no-expunge (spec msgs)
1040   (elmo-imap4-mark-set-on-msgs spec msgs "\\Deleted" nil 'no-expunge))
1041
1042 (defun elmo-imap4-msgdb-create-as-numlist (spec numlist new-mark already-mark
1043                                                 seen-mark important-mark
1044                                                 seen-list)
1045   "Create msgdb for SPEC for NUMLIST."
1046   (elmo-imap4-msgdb-create spec numlist new-mark already-mark
1047                            seen-mark important-mark seen-list t))
1048
1049 ;; Current buffer is process buffer.
1050 (defun elmo-imap4-fetch-callback (element app-data)
1051   (funcall elmo-imap4-fetch-callback
1052            (with-temp-buffer
1053              (insert (or (elmo-imap4-response-bodydetail-text element)
1054                          ""))
1055              ;; Delete CR.
1056              (goto-char (point-min))
1057              (while (search-forward "\r\n" nil t)
1058                (replace-match "\n"))
1059              (elmo-msgdb-create-overview-from-buffer
1060               (elmo-imap4-response-value element 'uid)
1061               (elmo-imap4-response-value element 'rfc822size)))
1062            (elmo-imap4-response-value element 'flags)
1063            app-data))
1064
1065 ;;
1066 ;; app-data:
1067 ;; 0: new-mark 1: already-mark 2: seen-mark 3: important-mark
1068 ;; 4: seen-list 5: as-number
1069 (defun elmo-imap4-fetch-callback-1 (entity flags app-data)
1070   "A msgdb entity callback function."
1071   (let ((seen (member (car entity) (nth 4 app-data)))
1072         mark)
1073     (if (member "\\Flagged" flags)
1074         (elmo-msgdb-global-mark-set (car entity) (nth 3 app-data)))
1075     (setq mark (or (elmo-msgdb-global-mark-get (car entity))
1076                    (if (elmo-cache-exists-p (car entity)) ;; XXX
1077                        (if (or (member "\\Seen" flags) seen)
1078                            nil
1079                          (nth 1 app-data))
1080                      (if (or (member "\\Seen" flags) seen)
1081                          (if elmo-imap4-use-cache
1082                              (nth 2 app-data))
1083                        (nth 0 app-data)))))
1084     (setq elmo-imap4-current-msgdb
1085           (elmo-msgdb-append
1086            elmo-imap4-current-msgdb
1087            (list (list entity)
1088                  (list (cons (elmo-msgdb-overview-entity-get-number entity)
1089                              (car entity)))
1090                  (if mark
1091                      (list
1092                       (list (elmo-msgdb-overview-entity-get-number entity)
1093                             mark))))))))
1094
1095 (defun elmo-imap4-msgdb-create (spec numlist &rest args)
1096   "Create msgdb for SPEC."
1097   (when numlist
1098     (let ((session (elmo-imap4-get-session spec))
1099           (headers
1100            (append
1101             '("Subject" "From" "To" "Cc" "Date"
1102               "Message-Id" "References" "In-Reply-To")
1103             elmo-msgdb-extra-fields))
1104           (total 0)
1105           (length (length numlist))
1106           rfc2060 set-list)
1107       (setq rfc2060 (memq 'imap4rev1
1108                           (elmo-imap4-session-capability-internal
1109                            session)))
1110       (message "Getting overview...")
1111       (elmo-imap4-session-select-mailbox session
1112                                          (elmo-imap4-spec-mailbox spec))
1113       (setq set-list (elmo-imap4-make-number-set-list
1114                       numlist
1115                       elmo-imap4-overview-fetch-chop-length))
1116       ;; Setup callback.
1117       (with-current-buffer (elmo-network-session-buffer session)
1118         (setq elmo-imap4-current-msgdb nil
1119               elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1
1120               elmo-imap4-fetch-callback-data args)
1121         (while set-list
1122           (elmo-imap4-send-command-wait
1123            session
1124            ;; get overview entity from IMAP4
1125            (format "%sfetch %s (%s rfc822.size flags)"
1126                    (if elmo-imap4-use-uid "uid " "")
1127                    (cdr (car set-list))
1128                    (if rfc2060
1129                        (format "body.peek[header.fields %s]" headers)
1130                      (format "%s" headers))))
1131           (when (> length elmo-display-progress-threshold)
1132             (setq total (+ total (car (car set-list))))
1133             (elmo-display-progress
1134              'elmo-imap4-msgdb-create "Getting overview..."
1135              (/ (* total 100) length)))
1136           (setq set-list (cdr set-list)))
1137         (message "Getting overview...done")
1138         elmo-imap4-current-msgdb))))
1139
1140 (defun elmo-imap4-parse-capability (string)
1141   (if (string-match "^\\*\\(.*\\)$" string)
1142       (elmo-read
1143        (concat "(" (downcase (elmo-match-string 1 string)) ")"))))
1144
1145 ;; Current buffer is process buffer.
1146 (defun elmo-imap4-auth-login (session)
1147   (let ((tag (elmo-imap4-send-command session "authenticate login"))
1148         (elmo-imap4-debug-inhibit-logging t))
1149     (or (elmo-imap4-read-continue-req session)
1150         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
1151     (elmo-imap4-send-string session
1152                             (elmo-base64-encode-string
1153                              (elmo-network-session-user-internal session)))
1154     (or (elmo-imap4-read-continue-req session)
1155         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
1156     (elmo-imap4-send-string session
1157                             (elmo-base64-encode-string
1158                              (elmo-get-passwd
1159                               (elmo-network-session-password-key session))))
1160     (or (elmo-imap4-read-ok session tag)
1161         (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
1162     (setq elmo-imap4-status 'auth)))
1163
1164 (defun elmo-imap4-auth-cram-md5 (session)
1165   (let ((tag (elmo-imap4-send-command session "authenticate cram-md5"))
1166         (elmo-imap4-debug-inhibit-logging t)
1167         response)
1168     (or (setq response (elmo-imap4-read-continue-req session))
1169         (signal 'elmo-authenticate-error
1170                 '(elmo-imap4-auth-cram-md5)))
1171     (elmo-imap4-send-string
1172      session
1173      (elmo-base64-encode-string
1174       (sasl-cram-md5 (elmo-network-session-user-internal session)
1175                      (elmo-get-passwd
1176                       (elmo-network-session-password-key session))
1177                      (elmo-base64-decode-string response))))
1178     (or (elmo-imap4-read-ok session tag)
1179         (signal 'elmo-authenticate-error '(elmo-imap4-auth-cram-md5)))))
1180
1181 (defun elmo-imap4-auth-digest-md5 (session)
1182   (let ((tag (elmo-imap4-send-command session "authenticate digest-md5"))
1183         (elmo-imap4-debug-inhibit-logging t)
1184         response)
1185     (or (setq response (elmo-imap4-read-continue-req session))
1186         (signal 'elmo-authenticate-error '(elmo-imap4-auth-digest-md5)))
1187     (elmo-imap4-send-string
1188      session
1189      (elmo-base64-encode-string
1190       (sasl-digest-md5-digest-response
1191        (elmo-base64-decode-string response)
1192        (elmo-network-session-user-internal session)
1193        (elmo-get-passwd (elmo-network-session-password-key session))
1194        "imap"
1195        (elmo-network-session-password-key session))
1196       'no-line-break))
1197     (or (setq response (elmo-imap4-read-continue-req session))
1198         (signal 'elmo-authenticate-error '(elmo-imap4-auth-digest-md5)))
1199     (elmo-imap4-send-string session "")
1200     (or (elmo-imap4-read-ok session tag)
1201         (signal 'elmo-authenticate-error '(elmo-imap4-auth-digest-md5)))))
1202
1203 (defun elmo-imap4-login (session)
1204   (let ((elmo-imap4-debug-inhibit-logging t))
1205     (or
1206      (elmo-imap4-read-ok
1207       session
1208       (elmo-imap4-send-command
1209        session
1210        (list "login "
1211              (elmo-imap4-userid (elmo-network-session-user-internal session))
1212              " "
1213              (elmo-imap4-password
1214               (elmo-get-passwd (elmo-network-session-password-key session))))))
1215      (signal 'elmo-authenticate-error '(login)))))
1216
1217 (luna-define-method
1218   elmo-network-initialize-session-buffer :after ((session
1219                                                   elmo-imap4-session) buffer)
1220   (with-current-buffer buffer
1221     (mapcar 'make-variable-buffer-local elmo-imap4-local-variables)
1222     (setq elmo-imap4-seqno 0)
1223     (setq elmo-imap4-status 'initial)))
1224
1225 (luna-define-method elmo-network-initialize-session ((session
1226                                                       elmo-imap4-session))
1227   (let ((process (elmo-network-session-process-internal session)))
1228     (with-current-buffer (process-buffer process)
1229       ;; Skip garbage output from process before greeting.
1230       (while (and (memq (process-status process) '(open run))
1231                   (goto-char (point-max))
1232                   (forward-line -1)
1233                   (not (elmo-imap4-parse-greeting)))
1234         (accept-process-output process 1))
1235       (set-process-filter process 'elmo-imap4-arrival-filter)
1236       (set-process-sentinel process 'elmo-imap4-sentinel)
1237 ;;;   (while (and (memq (process-status process) '(open run))
1238 ;;;               (eq elmo-imap4-status 'initial))
1239 ;;;     (message "Waiting for server response...")
1240 ;;;     (accept-process-output process 1))
1241 ;;;   (message "")
1242       (unless (memq elmo-imap4-status '(nonauth auth))
1243         (signal 'elmo-open-error
1244                 (list 'elmo-network-initialize-session)))
1245       (elmo-imap4-session-set-capability-internal
1246        session
1247        (elmo-imap4-response-value
1248         (elmo-imap4-send-command-wait session "capability")
1249         'capability))
1250       (when (eq (elmo-network-stream-type-symbol
1251                  (elmo-network-session-stream-type-internal session))
1252                 'starttls)
1253         (or (memq 'starttls
1254                   (elmo-imap4-session-capability-internal session))
1255             (signal 'elmo-open-error
1256                     '(elmo-imap4-starttls-error)))
1257         (elmo-imap4-send-command-wait session "starttls")
1258         (starttls-negotiate process)))))
1259
1260 (luna-define-method elmo-network-authenticate-session ((session
1261                                                         elmo-imap4-session))
1262  (with-current-buffer (process-buffer
1263                        (elmo-network-session-process-internal session))
1264    (unless (eq elmo-imap4-status 'auth)
1265      (unless (or (not (elmo-network-session-auth-internal session))
1266                  (eq (elmo-network-session-auth-internal session) 'plain)
1267                  (and (memq (intern
1268                              (format "auth=%s"
1269                                      (elmo-network-session-auth-internal
1270                                       session)))
1271                             (elmo-imap4-session-capability-internal session))
1272                       (assq
1273                        (elmo-network-session-auth-internal session)
1274                        elmo-imap4-authenticator-alist)))
1275        (if (or elmo-imap4-force-login
1276                (y-or-n-p
1277                 (format
1278                  "There's no %s capability in server. continue?"
1279                  (elmo-network-session-auth-internal session))))
1280            (elmo-network-session-set-auth-internal session nil)
1281          (signal 'elmo-open-error
1282                  '(elmo-network-initialize-session))))
1283      (let ((authenticator
1284             (if (elmo-network-session-auth-internal session)
1285                 (nth 1 (assq
1286                         (elmo-network-session-auth-internal session)
1287                         elmo-imap4-authenticator-alist))
1288               'elmo-imap4-login)))
1289        (funcall authenticator session)))))
1290
1291 (luna-define-method elmo-network-setup-session ((session
1292                                                  elmo-imap4-session))
1293   (with-current-buffer (elmo-network-session-buffer session)
1294     (when (memq 'namespace (elmo-imap4-session-capability-internal session))
1295       (setq elmo-imap4-server-namespace
1296             (elmo-imap4-response-value
1297              (elmo-imap4-send-command-wait session "namespace")
1298              'namespace)))))
1299
1300 (defun elmo-imap4-setup-send-buffer (string)
1301   (let ((tmp-buf (get-buffer-create " *elmo-imap4-setup-send-buffer*")))
1302     (save-excursion
1303       (save-match-data
1304         (set-buffer tmp-buf)
1305         (erase-buffer)
1306         (elmo-set-buffer-multibyte nil)
1307         (insert string)
1308         (goto-char (point-min))
1309         (if (eq (re-search-forward "^$" nil t)
1310                 (point-max))
1311             (insert "\n"))
1312         (goto-char (point-min))
1313         (while (search-forward "\n" nil t)
1314           (replace-match "\r\n"))))
1315     tmp-buf))
1316
1317 (defun elmo-imap4-read-part (folder msg part)
1318   (let* ((spec (elmo-folder-get-spec folder))
1319          (session (elmo-imap4-get-session spec)))
1320     (elmo-imap4-session-select-mailbox session
1321                                        (elmo-imap4-spec-mailbox spec))
1322     (with-current-buffer (elmo-network-session-buffer session)
1323       (setq elmo-imap4-fetch-callback nil)
1324       (setq elmo-imap4-fetch-callback-data nil))
1325     (elmo-delete-cr
1326      (elmo-imap4-response-bodydetail-text
1327       (elmo-imap4-response-value-all
1328        (elmo-imap4-send-command-wait session
1329                                      (format
1330                                       (if elmo-imap4-use-uid
1331                                           "uid fetch %s body.peek[%s]"
1332                                         "fetch %s body.peek[%s]")
1333                                       msg part))
1334        'fetch)))))
1335
1336 (defun elmo-imap4-prefetch-msg (spec msg outbuf)
1337   (elmo-imap4-read-msg spec msg outbuf 'unseen))
1338
1339 (defun elmo-imap4-read-msg (spec msg outbuf
1340                                  &optional leave-seen-flag-untouched)
1341   (let ((session (elmo-imap4-get-session spec))
1342         response)
1343     (elmo-imap4-session-select-mailbox session
1344                                        (elmo-imap4-spec-mailbox spec))
1345     (with-current-buffer (elmo-network-session-buffer session)
1346       (setq elmo-imap4-fetch-callback nil)
1347       (setq elmo-imap4-fetch-callback-data nil))
1348     (setq response
1349           (elmo-imap4-send-command-wait session
1350                                         (format
1351                                          (if elmo-imap4-use-uid
1352                                              "uid fetch %s rfc822%s"
1353                                            "fetch %s rfc822%s")
1354                                          msg
1355                                          (if leave-seen-flag-untouched
1356                                              ".peek" ""))))
1357     (and (setq response (elmo-imap4-response-value
1358                          (elmo-imap4-response-value-all
1359                           response 'fetch )
1360                          'rfc822))
1361          (with-current-buffer outbuf
1362            (erase-buffer)
1363            (insert response)
1364            (elmo-delete-cr-get-content-type)))))
1365
1366 (defun elmo-imap4-setup-send-buffer-from-file (file)
1367   (let ((tmp-buf (get-buffer-create
1368                   " *elmo-imap4-setup-send-buffer-from-file*")))
1369     (save-excursion
1370       (save-match-data
1371         (set-buffer tmp-buf)
1372         (erase-buffer)
1373         (as-binary-input-file
1374          (insert-file-contents file))
1375         (goto-char (point-min))
1376         (if (eq (re-search-forward "^$" nil t)
1377                 (point-max))
1378             (insert "\n"))
1379         (goto-char (point-min))
1380         (while (search-forward "\n" nil t)
1381           (replace-match "\r\n"))))
1382     tmp-buf))
1383
1384 (defun elmo-imap4-delete-msgids (spec msgids)
1385   "If actual message-id is matched, then delete it."
1386   (let ((message-ids msgids)
1387         (i 0)
1388         (num (length msgids)))
1389     (while message-ids
1390       (setq i (+ 1 i))
1391       (message "Deleting message...%d/%d" i num)
1392       (elmo-imap4-delete-msg-by-id spec (car message-ids))
1393       (setq message-ids (cdr message-ids)))
1394     (elmo-imap4-send-command-wait (elmo-imap4-get-session spec) "expunge")))
1395
1396 (defun elmo-imap4-delete-msg-by-id (spec msgid)
1397   (let ((session (elmo-imap4-get-session spec)))
1398     (elmo-imap4-session-select-mailbox session
1399                                        (elmo-imap4-spec-mailbox spec))
1400     (elmo-imap4-delete-msgs-no-expunge
1401      spec
1402      (elmo-imap4-response-value
1403       (elmo-imap4-send-command-wait session
1404                                     (list
1405                                      (if elmo-imap4-use-uid
1406                                          "uid search header message-id "
1407                                        "search header message-id ")
1408                                      (elmo-imap4-field-body msgid)))
1409       'search))))
1410
1411 (defun elmo-imap4-append-msg-by-id (spec msgid)
1412   (let ((session (elmo-imap4-get-session spec))
1413         send-buf)
1414     (elmo-imap4-session-select-mailbox session
1415                                        (elmo-imap4-spec-mailbox spec))
1416     (setq send-buf (elmo-imap4-setup-send-buffer-from-file
1417                     (elmo-cache-get-path msgid)))
1418     (unwind-protect
1419         (elmo-imap4-send-command-wait
1420          session
1421          (list
1422           "append "
1423           (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec))
1424           " (\\Seen) "
1425           (elmo-imap4-buffer-literal send-buf)))
1426       (kill-buffer send-buf)))
1427   t)
1428
1429 (defun elmo-imap4-append-msg (spec string &optional msg no-see)
1430   (let ((session (elmo-imap4-get-session spec))
1431         send-buf)
1432     (elmo-imap4-session-select-mailbox session
1433                                        (elmo-imap4-spec-mailbox spec))
1434     (setq send-buf (elmo-imap4-setup-send-buffer string))
1435     (unwind-protect
1436         (elmo-imap4-send-command-wait
1437          session
1438          (list
1439           "append "
1440           (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec))
1441           (if no-see " " " (\\Seen) ")
1442           (elmo-imap4-buffer-literal send-buf)))
1443       (kill-buffer send-buf)))
1444   t)
1445
1446 (defun elmo-imap4-copy-msgs (dst-spec
1447                              msgs src-spec &optional expunge-it same-number)
1448   "Equivalence of hostname, username is assumed."
1449   (let ((session (elmo-imap4-get-session src-spec)))
1450     (elmo-imap4-session-select-mailbox session
1451                                        (elmo-imap4-spec-mailbox src-spec))
1452     (while msgs
1453       (elmo-imap4-send-command-wait session
1454                                     (list
1455                                      (format
1456                                       (if elmo-imap4-use-uid
1457                                           "uid copy %s "
1458                                         "copy %s ")
1459                                       (car msgs))
1460                                      (elmo-imap4-mailbox
1461                                       (elmo-imap4-spec-mailbox dst-spec))))
1462       (setq msgs (cdr msgs)))
1463     (when expunge-it
1464       (elmo-imap4-send-command-wait session "expunge"))
1465     t))
1466
1467 (defun elmo-imap4-server-diff-async-callback-1 (status data)
1468   (funcall elmo-imap4-server-diff-async-callback
1469            (cons (elmo-imap4-response-value status 'unseen)
1470                  (elmo-imap4-response-value status 'messages))
1471            data))
1472
1473 (defun elmo-imap4-server-diff-async (spec)
1474   (let ((session (elmo-imap4-get-session spec)))
1475     ;; commit.
1476     ;; (elmo-imap4-commit spec)
1477     (with-current-buffer (elmo-network-session-buffer session)
1478       (setq elmo-imap4-status-callback
1479             'elmo-imap4-server-diff-async-callback-1)
1480       (setq elmo-imap4-status-callback-data
1481             elmo-imap4-server-diff-async-callback-data))
1482     (elmo-imap4-send-command session
1483                              (list
1484                               "status "
1485                               (elmo-imap4-mailbox
1486                                (elmo-imap4-spec-mailbox spec))
1487                               " (unseen messages)"))))
1488
1489 (defun elmo-imap4-server-diff (spec)
1490   "Get server status"
1491   (let ((session (elmo-imap4-get-session spec))
1492         response)
1493     ;; commit.
1494 ;;; (elmo-imap4-commit spec)
1495     (with-current-buffer (elmo-network-session-buffer session)
1496       (setq elmo-imap4-status-callback nil)
1497       (setq elmo-imap4-status-callback-data nil))
1498     (setq response
1499           (elmo-imap4-send-command-wait session
1500                                         (list
1501                                          "status "
1502                                          (elmo-imap4-mailbox
1503                                           (elmo-imap4-spec-mailbox spec))
1504                                          " (unseen messages)")))
1505     (setq response (elmo-imap4-response-value response 'status))
1506     (cons (elmo-imap4-response-value response 'unseen)
1507           (elmo-imap4-response-value response 'messages))))
1508
1509 (defun elmo-imap4-use-cache-p (spec number)
1510   elmo-imap4-use-cache)
1511
1512 (defun elmo-imap4-local-file-p (spec number)
1513   nil)
1514
1515 (defun elmo-imap4-port-label (spec)
1516   (concat "imap4"
1517           (if (elmo-imap4-spec-stream-type spec)
1518               (concat "!" (symbol-name
1519                            (elmo-network-stream-type-symbol
1520                             (elmo-imap4-spec-stream-type spec)))))))
1521
1522
1523 (defsubst elmo-imap4-portinfo (spec)
1524   (list (elmo-imap4-spec-hostname spec) (elmo-imap4-spec-port spec)))
1525
1526 (defun elmo-imap4-plugged-p (spec)
1527   (apply 'elmo-plugged-p
1528          (append (elmo-imap4-portinfo spec)
1529                  (list nil (quote (elmo-imap4-port-label spec))))))
1530
1531 (defun elmo-imap4-set-plugged (spec plugged add)
1532   (apply 'elmo-set-plugged plugged
1533          (append (elmo-imap4-portinfo spec)
1534                  (list nil nil (quote (elmo-imap4-port-label spec)) add))))
1535
1536 (defalias 'elmo-imap4-sync-number-alist 'elmo-generic-sync-number-alist)
1537
1538 ;;; IMAP parser.
1539
1540 (defvar elmo-imap4-server-eol "\r\n"
1541   "The EOL string sent from the server.")
1542
1543 (defvar elmo-imap4-client-eol "\r\n"
1544   "The EOL string we send to the server.")
1545
1546 (defun elmo-imap4-find-next-line ()
1547   "Return point at end of current line, taking into account literals.
1548 Return nil if no complete line has arrived."
1549   (when (re-search-forward (concat elmo-imap4-server-eol "\\|{\\([0-9]+\\)}"
1550                                    elmo-imap4-server-eol)
1551                            nil t)
1552     (if (match-string 1)
1553         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1554             nil
1555           (goto-char (+ (point) (string-to-number (match-string 1))))
1556           (elmo-imap4-find-next-line))
1557       (point))))
1558
1559 (defun elmo-imap4-sentinel (process string)
1560   (delete-process process))
1561
1562 (defun elmo-imap4-arrival-filter (proc string)
1563   "IMAP process filter."
1564   (with-current-buffer (process-buffer proc)
1565     (elmo-imap4-debug "-> %s" string)
1566     (goto-char (point-max))
1567     (insert string)
1568     (let (end)
1569       (goto-char (point-min))
1570       (while (setq end (elmo-imap4-find-next-line))
1571         (save-restriction
1572           (narrow-to-region (point-min) end)
1573           (delete-backward-char (length elmo-imap4-server-eol))
1574           (goto-char (point-min))
1575           (unwind-protect
1576               (cond ((eq elmo-imap4-status 'initial)
1577                      (setq elmo-imap4-current-response
1578                            (list
1579                             (list 'greeting (elmo-imap4-parse-greeting)))))
1580                     ((or (eq elmo-imap4-status 'auth)
1581                          (eq elmo-imap4-status 'nonauth)
1582                          (eq elmo-imap4-status 'selected)
1583                          (eq elmo-imap4-status 'examine))
1584                      (setq elmo-imap4-current-response
1585                            (cons
1586                             (elmo-imap4-parse-response)
1587                             elmo-imap4-current-response)))
1588                     (t
1589                      (message "Unknown state %s in arrival filter"
1590                               elmo-imap4-status))))
1591           (delete-region (point-min) (point-max)))))))
1592
1593 ;; IMAP parser.
1594
1595 (defsubst elmo-imap4-forward ()
1596   (or (eobp) (forward-char 1)))
1597
1598 (defsubst elmo-imap4-parse-number ()
1599   (when (looking-at "[0-9]+")
1600     (prog1
1601         (string-to-number (match-string 0))
1602       (goto-char (match-end 0)))))
1603
1604 (defsubst elmo-imap4-parse-literal ()
1605   (when (looking-at "{\\([0-9]+\\)}\r\n")
1606     (let ((pos (match-end 0))
1607           (len (string-to-number (match-string 1))))
1608       (if (< (point-max) (+ pos len))
1609           nil
1610         (goto-char (+ pos len))
1611         (buffer-substring pos (+ pos len))))))
1612 ;;;     (list ' pos (+ pos len))))))
1613
1614 (defsubst elmo-imap4-parse-string ()
1615   (cond ((eq (char-after (point)) ?\")
1616          (forward-char 1)
1617          (let ((p (point)) (name ""))
1618            (skip-chars-forward "^\"\\\\")
1619            (setq name (buffer-substring p (point)))
1620            (while (eq (char-after (point)) ?\\)
1621              (setq p (1+ (point)))
1622              (forward-char 2)
1623              (skip-chars-forward "^\"\\\\")
1624              (setq name (concat name (buffer-substring p (point)))))
1625            (forward-char 1)
1626            name))
1627         ((eq (char-after (point)) ?{)
1628          (elmo-imap4-parse-literal))))
1629
1630 (defsubst elmo-imap4-parse-nil ()
1631   (if (looking-at "NIL")
1632       (goto-char (match-end 0))))
1633
1634 (defsubst elmo-imap4-parse-nstring ()
1635   (or (elmo-imap4-parse-string)
1636       (and (elmo-imap4-parse-nil)
1637            nil)))
1638
1639 (defsubst elmo-imap4-parse-astring ()
1640   (or (elmo-imap4-parse-string)
1641       (buffer-substring (point)
1642                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1643                             (goto-char (1- (match-end 0)))
1644                           (end-of-line)
1645                           (point)))))
1646
1647 (defsubst elmo-imap4-parse-address ()
1648   (let (address)
1649     (when (eq (char-after (point)) ?\()
1650       (elmo-imap4-forward)
1651       (setq address (vector (prog1 (elmo-imap4-parse-nstring)
1652                               (elmo-imap4-forward))
1653                             (prog1 (elmo-imap4-parse-nstring)
1654                               (elmo-imap4-forward))
1655                             (prog1 (elmo-imap4-parse-nstring)
1656                               (elmo-imap4-forward))
1657                             (elmo-imap4-parse-nstring)))
1658       (when (eq (char-after (point)) ?\))
1659         (elmo-imap4-forward)
1660         address))))
1661
1662 (defsubst elmo-imap4-parse-address-list ()
1663   (if (eq (char-after (point)) ?\()
1664       (let (address addresses)
1665         (elmo-imap4-forward)
1666         (while (and (not (eq (char-after (point)) ?\)))
1667                     ;; next line for MS Exchange bug
1668                     (progn (and (eq (char-after (point)) ? ) (elmo-imap4-forward)) t)
1669                     (setq address (elmo-imap4-parse-address)))
1670           (setq addresses (cons address addresses)))
1671         (when (eq (char-after (point)) ?\))
1672           (elmo-imap4-forward)
1673           (nreverse addresses)))
1674     (assert (elmo-imap4-parse-nil))))
1675
1676 (defsubst elmo-imap4-parse-mailbox ()
1677   (let ((mailbox (elmo-imap4-parse-astring)))
1678     (if (string-equal "INBOX" (upcase mailbox))
1679         "INBOX"
1680       mailbox)))
1681
1682 (defun elmo-imap4-parse-greeting ()
1683   "Parse a IMAP greeting."
1684   (cond ((looking-at "\\* OK ")
1685          (setq elmo-imap4-status 'nonauth))
1686         ((looking-at "\\* PREAUTH ")
1687          (setq elmo-imap4-status 'auth))
1688         ((looking-at "\\* BYE ")
1689          (setq elmo-imap4-status 'closed))))
1690
1691 (defun elmo-imap4-parse-response ()
1692   "Parse a IMAP command response."
1693   (let (token)
1694     (case (setq token (elmo-read (current-buffer)))
1695       (+ (progn
1696            (skip-chars-forward " ")
1697            (list 'continue-req (buffer-substring (point) (point-max)))))
1698       (* (case (prog1 (setq token (elmo-read (current-buffer)))
1699                  (elmo-imap4-forward))
1700            (OK         (elmo-imap4-parse-resp-text-code))
1701            (NO         (elmo-imap4-parse-resp-text-code))
1702            (BAD        (elmo-imap4-parse-resp-text-code))
1703            (BYE        (elmo-imap4-parse-bye))
1704            (FLAGS      (list 'flags
1705                              (elmo-imap4-parse-flag-list)))
1706            (LIST       (list 'list (elmo-imap4-parse-data-list)))
1707            (LSUB       (list 'lsub (elmo-imap4-parse-data-list)))
1708            (SEARCH     (list
1709                         'search
1710                         (elmo-read (concat "("
1711                                       (buffer-substring (point) (point-max))
1712                                       ")"))))
1713            (STATUS     (elmo-imap4-parse-status))
1714            ;; Added
1715            (NAMESPACE  (elmo-imap4-parse-namespace))
1716            (CAPABILITY (list 'capability
1717                              (elmo-read
1718                               (concat "(" (downcase (buffer-substring
1719                                                      (point) (point-max)))
1720                                       ")"))))
1721            (ACL        (elmo-imap4-parse-acl))
1722            (t       (case (prog1 (elmo-read (current-buffer))
1723                             (elmo-imap4-forward))
1724                       (EXISTS  (list 'exists token))
1725                       (RECENT  (list 'recent token))
1726                       (EXPUNGE (list 'expunge token))
1727                       (FETCH   (elmo-imap4-parse-fetch token))
1728                       (t       (list 'garbage (buffer-string)))))))
1729       (t (if (not (string-match elmo-imap4-seq-prefix (symbol-name token)))
1730              (list 'garbage (buffer-string))
1731            (case (prog1 (elmo-read (current-buffer))
1732                    (elmo-imap4-forward))
1733              (OK  (progn
1734                     (setq elmo-imap4-parsing nil)
1735                     (setq token (symbol-name token))
1736                     (elmo-unintern token)
1737                     (elmo-imap4-debug "*%s* OK arrived" token)
1738                     (setq elmo-imap4-reached-tag token)
1739                     (list 'ok (elmo-imap4-parse-resp-text-code))))
1740              (NO  (progn
1741                     (setq elmo-imap4-parsing nil)
1742                     (setq token (symbol-name token))
1743                     (elmo-unintern token)
1744                     (elmo-imap4-debug "*%s* NO arrived" token)
1745                     (setq elmo-imap4-reached-tag token)
1746                     (let (code text)
1747                       (when (eq (char-after (point)) ?\[)
1748                         (setq code (buffer-substring (point)
1749                                                      (search-forward "]")))
1750                         (elmo-imap4-forward))
1751                       (setq text (buffer-substring (point) (point-max)))
1752                       (list 'no (list code text)))))
1753              (BAD (progn
1754                     (setq elmo-imap4-parsing nil)
1755                     (elmo-imap4-debug "*%s* BAD arrived" token)
1756                     (setq token (symbol-name token))
1757                     (elmo-unintern token)
1758                     (setq elmo-imap4-reached-tag token)
1759                     (let (code text)
1760                       (when (eq (char-after (point)) ?\[)
1761                         (setq code (buffer-substring (point)
1762                                                      (search-forward "]")))
1763                         (elmo-imap4-forward))
1764                       (setq text (buffer-substring (point) (point-max)))
1765                       (list 'bad (list code text)))))
1766              (t   (list 'garbage (buffer-string)))))))))
1767
1768 (defun elmo-imap4-parse-bye ()
1769   (let (code text)
1770     (when (eq (char-after (point)) ?\[)
1771       (setq code (buffer-substring (point)
1772                                    (search-forward "]")))
1773       (elmo-imap4-forward))
1774     (setq text (buffer-substring (point) (point-max)))
1775     (list 'bye (list code text))))
1776
1777 (defun elmo-imap4-parse-text ()
1778   (goto-char (point-min))
1779   (when (search-forward "[" nil t)
1780     (search-forward "]")
1781     (elmo-imap4-forward))
1782   (list 'text (buffer-substring (point) (point-max))))
1783
1784 (defun elmo-imap4-parse-resp-text-code ()
1785   (when (eq (char-after (point)) ?\[)
1786     (elmo-imap4-forward)
1787     (cond ((search-forward "PERMANENTFLAGS " nil t)
1788            (list 'permanentflags (elmo-imap4-parse-flag-list)))
1789           ((search-forward "UIDNEXT " nil t)
1790            (list 'uidnext (elmo-read (current-buffer))))
1791           ((search-forward "UNSEEN " nil t)
1792            (list 'unseen (elmo-read (current-buffer))))
1793           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
1794            (list 'uidvalidity (match-string 1)))
1795           ((search-forward "READ-ONLY" nil t)
1796            (list 'read-only t))
1797           ((search-forward "READ-WRITE" nil t)
1798            (list 'read-write t))
1799           ((search-forward "NEWNAME " nil t)
1800            (let (oldname newname)
1801              (setq oldname (elmo-imap4-parse-string))
1802              (elmo-imap4-forward)
1803              (setq newname (elmo-imap4-parse-string))
1804              (list 'newname newname oldname)))
1805           ((search-forward "TRYCREATE" nil t)
1806            (list 'trycreate t))
1807           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
1808            (list 'appenduid
1809                  (list (match-string 1)
1810                        (string-to-number (match-string 2)))))
1811           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
1812            (list 'copyuid (list (match-string 1)
1813                                 (match-string 2)
1814                                 (match-string 3))))
1815           ((search-forward "ALERT] " nil t)
1816            (message "IMAP server information: %s"
1817                     (buffer-substring (point) (point-max))))
1818           (t (list 'unknown)))))
1819
1820 (defun elmo-imap4-parse-data-list ()
1821   (let (flags delimiter mailbox)
1822     (setq flags (elmo-imap4-parse-flag-list))
1823     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
1824       (setq delimiter (match-string 1))
1825       (goto-char (1+ (match-end 0)))
1826       (when (setq mailbox (elmo-imap4-parse-mailbox))
1827         (list mailbox flags delimiter)))))
1828
1829 (defsubst elmo-imap4-parse-header-list ()
1830   (when (eq (char-after (point)) ?\()
1831     (let (strlist)
1832       (while (not (eq (char-after (point)) ?\)))
1833         (elmo-imap4-forward)
1834         (push (elmo-imap4-parse-astring) strlist))
1835       (elmo-imap4-forward)
1836       (nreverse strlist))))
1837
1838 (defsubst elmo-imap4-parse-fetch-body-section ()
1839   (let ((section
1840          (buffer-substring (point)
1841                            (1-
1842                             (progn (re-search-forward "[] ]" nil t)
1843                                    (point))))))
1844     (if (eq (char-before) ? )
1845         (prog1
1846             (mapconcat 'identity
1847                        (cons section (elmo-imap4-parse-header-list)) " ")
1848           (search-forward "]" nil t))
1849       section)))
1850
1851 (defun elmo-imap4-parse-fetch (response)
1852   (when (eq (char-after (point)) ?\()
1853     (let (element list)
1854       (while (not (eq (char-after (point)) ?\)))
1855         (elmo-imap4-forward)
1856         (let ((token (elmo-imap4-fetch-read (current-buffer))))
1857           (elmo-imap4-forward)
1858           (setq element
1859                 (cond ((eq token 'UID)
1860                        (list 'uid (condition-case nil
1861                                       (elmo-read (current-buffer))
1862                                     (error nil))))
1863                       ((eq token 'FLAGS)
1864                        (list 'flags (elmo-imap4-parse-flag-list)))
1865                       ((eq token 'ENVELOPE)
1866                        (list 'envelope (elmo-imap4-parse-envelope)))
1867                       ((eq token 'INTERNALDATE)
1868                        (list 'internaldate (elmo-imap4-parse-string)))
1869                       ((eq token 'RFC822)
1870                        (list 'rfc822 (elmo-imap4-parse-nstring)))
1871                       ((eq token (intern elmo-imap4-rfc822-header))
1872                        (list 'rfc822header (elmo-imap4-parse-nstring)))
1873                       ((eq token (intern elmo-imap4-rfc822-text))
1874                        (list 'rfc822text (elmo-imap4-parse-nstring)))
1875                       ((eq token (intern elmo-imap4-rfc822-size))
1876                        (list 'rfc822size (elmo-read (current-buffer))))
1877                       ((eq token 'BODY)
1878                        (if (eq (char-before) ?\[)
1879                            (list
1880                             'bodydetail
1881                             (upcase (elmo-imap4-parse-fetch-body-section))
1882                             (and
1883                              (eq (char-after (point)) ?<)
1884                              (buffer-substring (1+ (point))
1885                                                (progn
1886                                                  (search-forward ">" nil t)
1887                                                  (point))))
1888                             (progn (elmo-imap4-forward)
1889                                    (elmo-imap4-parse-nstring)))
1890                          (list 'body (elmo-imap4-parse-body))))
1891                       ((eq token 'BODYSTRUCTURE)
1892                        (list 'bodystructure (elmo-imap4-parse-body)))))
1893           (setq list (cons element list))))
1894       (and elmo-imap4-fetch-callback
1895            (elmo-imap4-fetch-callback list elmo-imap4-fetch-callback-data))
1896       (list 'fetch list))))
1897
1898 (defun elmo-imap4-parse-status ()
1899   (let ((mailbox (elmo-imap4-parse-mailbox))
1900         status)
1901     (when (and mailbox (search-forward "(" nil t))
1902       (while (not (eq (char-after (point)) ?\)))
1903         (setq status
1904               (cons
1905                (let ((token (elmo-read (current-buffer))))
1906                  (cond ((eq token 'MESSAGES)
1907                         (list 'messages (elmo-read (current-buffer))))
1908                        ((eq token 'RECENT)
1909                         (list 'recent (elmo-read (current-buffer))))
1910                        ((eq token 'UIDNEXT)
1911                         (list 'uidnext (elmo-read (current-buffer))))
1912                        ((eq token 'UIDVALIDITY)
1913                         (and (looking-at " \\([0-9]+\\)")
1914                              (prog1 (list 'uidvalidity (match-string 1))
1915                                (goto-char (match-end 1)))))
1916                        ((eq token 'UNSEEN)
1917                         (list 'unseen (elmo-read (current-buffer))))
1918                        (t
1919                         (message
1920                          "Unknown status data %s in mailbox %s ignored"
1921                          token mailbox))))
1922                status))))
1923     (and elmo-imap4-status-callback
1924          (funcall elmo-imap4-status-callback
1925                   status
1926                   elmo-imap4-status-callback-data))
1927     (list 'status status)))
1928
1929
1930 (defmacro elmo-imap4-value (value)
1931   (` (if (eq (, value) 'NIL) nil
1932        (, value))))
1933
1934 (defmacro elmo-imap4-nth (pos list)
1935   (` (let ((value (nth (, pos) (, list))))
1936        (elmo-imap4-value value))))
1937
1938 (defun elmo-imap4-parse-namespace ()
1939   (list 'namespace
1940         (nconc
1941          (copy-sequence elmo-imap4-extra-namespace-alist)
1942          (elmo-imap4-parse-namespace-subr
1943           (elmo-read (concat "(" (buffer-substring
1944                                   (point) (point-max))
1945                              ")"))))))
1946
1947 (defun elmo-imap4-parse-namespace-subr (ns)
1948   (let (prefix delim namespace-alist default-delim)
1949     ;; 0: personal, 1: other, 2: shared
1950     (dotimes (i 3)
1951       (setq namespace-alist
1952             (nconc namespace-alist
1953                    (delq nil
1954                          (mapcar
1955                           (lambda (namespace)
1956                             (setq prefix (elmo-imap4-nth 0 namespace)
1957                                   delim (elmo-imap4-nth 1 namespace))
1958                             (if (and prefix delim
1959                                      (string-match
1960                                       (concat (regexp-quote delim) "\\'")
1961                                       prefix))
1962                                 (setq prefix (substring prefix 0
1963                                                         (match-beginning 0))))
1964                             (if (eq (length prefix) 0)
1965                                 (progn (setq default-delim delim) nil)
1966                               (cons
1967                                (concat "^"
1968                                        (if (string= (downcase prefix) "inbox")
1969                                            "[Ii][Nn][Bb][Oo][Xx]"
1970                                          (regexp-quote prefix))
1971                                        ".*$")
1972                                delim)))
1973                           (elmo-imap4-nth i ns))))))
1974     (if default-delim
1975         (setq namespace-alist
1976               (nconc namespace-alist
1977                      (list (cons "^.*$" default-delim)))))
1978     namespace-alist))
1979
1980 (defun elmo-imap4-parse-acl ()
1981   (let ((mailbox (elmo-imap4-parse-mailbox))
1982         identifier rights acl)
1983     (while (eq (char-after (point)) ?\ )
1984       (elmo-imap4-forward)
1985       (setq identifier (elmo-imap4-parse-astring))
1986       (elmo-imap4-forward)
1987       (setq rights (elmo-imap4-parse-astring))
1988       (setq acl (append acl (list (cons identifier rights)))))
1989     (list 'acl acl mailbox)))
1990
1991 (defun elmo-imap4-parse-flag-list ()
1992   (let ((str (buffer-substring (+ (point) 1)
1993                                (progn (search-forward ")" nil t)
1994                                       (- (point) 1)))))
1995     (unless (eq (length str) 0)
1996       (split-string str))))
1997
1998 (defun elmo-imap4-parse-envelope ()
1999   (when (eq (char-after (point)) ?\()
2000     (elmo-imap4-forward)
2001     (vector (prog1 (elmo-imap4-parse-nstring);; date
2002               (elmo-imap4-forward))
2003             (prog1 (elmo-imap4-parse-nstring);; subject
2004               (elmo-imap4-forward))
2005             (prog1 (elmo-imap4-parse-address-list);; from
2006               (elmo-imap4-forward))
2007             (prog1 (elmo-imap4-parse-address-list);; sender
2008               (elmo-imap4-forward))
2009             (prog1 (elmo-imap4-parse-address-list);; reply-to
2010               (elmo-imap4-forward))
2011             (prog1 (elmo-imap4-parse-address-list);; to
2012               (elmo-imap4-forward))
2013             (prog1 (elmo-imap4-parse-address-list);; cc
2014               (elmo-imap4-forward))
2015             (prog1 (elmo-imap4-parse-address-list);; bcc
2016               (elmo-imap4-forward))
2017             (prog1 (elmo-imap4-parse-nstring);; in-reply-to
2018               (elmo-imap4-forward))
2019             (prog1 (elmo-imap4-parse-nstring);; message-id
2020               (elmo-imap4-forward)))))
2021
2022 (defsubst elmo-imap4-parse-string-list ()
2023   (cond ((eq (char-after (point)) ?\();; body-fld-param
2024          (let (strlist str)
2025            (elmo-imap4-forward)
2026            (while (setq str (elmo-imap4-parse-string))
2027              (push str strlist)
2028              (elmo-imap4-forward))
2029            (nreverse strlist)))
2030         ((elmo-imap4-parse-nil)
2031          nil)))
2032
2033 (defun elmo-imap4-parse-body-extension ()
2034   (if (eq (char-after (point)) ?\()
2035       (let (b-e)
2036         (elmo-imap4-forward)
2037         (push (elmo-imap4-parse-body-extension) b-e)
2038         (while (eq (char-after (point)) ?\ )
2039           (elmo-imap4-forward)
2040           (push (elmo-imap4-parse-body-extension) b-e))
2041         (assert (eq (char-after (point)) ?\)))
2042         (elmo-imap4-forward)
2043         (nreverse b-e))
2044     (or (elmo-imap4-parse-number)
2045         (elmo-imap4-parse-nstring))))
2046
2047 (defsubst elmo-imap4-parse-body-ext ()
2048   (let (ext)
2049     (when (eq (char-after (point)) ?\ );; body-fld-dsp
2050       (elmo-imap4-forward)
2051       (let (dsp)
2052         (if (eq (char-after (point)) ?\()
2053             (progn
2054               (elmo-imap4-forward)
2055               (push (elmo-imap4-parse-string) dsp)
2056               (elmo-imap4-forward)
2057               (push (elmo-imap4-parse-string-list) dsp)
2058               (elmo-imap4-forward))
2059           (assert (elmo-imap4-parse-nil)))
2060         (push (nreverse dsp) ext))
2061       (when (eq (char-after (point)) ?\ );; body-fld-lang
2062         (elmo-imap4-forward)
2063         (if (eq (char-after (point)) ?\()
2064             (push (elmo-imap4-parse-string-list) ext)
2065           (push (elmo-imap4-parse-nstring) ext))
2066         (while (eq (char-after (point)) ?\ );; body-extension
2067           (elmo-imap4-forward)
2068           (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
2069     ext))
2070
2071 (defun elmo-imap4-parse-body ()
2072   (let (body)
2073     (when (eq (char-after (point)) ?\()
2074       (elmo-imap4-forward)
2075       (if (eq (char-after (point)) ?\()
2076           (let (subbody)
2077             (while (and (eq (char-after (point)) ?\()
2078                         (setq subbody (elmo-imap4-parse-body)))
2079               (push subbody body))
2080             (elmo-imap4-forward)
2081             (push (elmo-imap4-parse-string) body);; media-subtype
2082             (when (eq (char-after (point)) ?\ );; body-ext-mpart:
2083               (elmo-imap4-forward)
2084               (if (eq (char-after (point)) ?\();; body-fld-param
2085                   (push (elmo-imap4-parse-string-list) body)
2086                 (push (and (elmo-imap4-parse-nil) nil) body))
2087               (setq body
2088                     (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
2089             (assert (eq (char-after (point)) ?\)))
2090             (elmo-imap4-forward)
2091             (nreverse body))
2092
2093         (push (elmo-imap4-parse-string) body);; media-type
2094         (elmo-imap4-forward)
2095         (push (elmo-imap4-parse-string) body);; media-subtype
2096         (elmo-imap4-forward)
2097         ;; next line for Sun SIMS bug
2098         (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
2099         (if (eq (char-after (point)) ?\();; body-fld-param
2100             (push (elmo-imap4-parse-string-list) body)
2101           (push (and (elmo-imap4-parse-nil) nil) body))
2102         (elmo-imap4-forward)
2103         (push (elmo-imap4-parse-nstring) body);; body-fld-id
2104         (elmo-imap4-forward)
2105         (push (elmo-imap4-parse-nstring) body);; body-fld-desc
2106         (elmo-imap4-forward)
2107         (push (elmo-imap4-parse-string) body);; body-fld-enc
2108         (elmo-imap4-forward)
2109         (push (elmo-imap4-parse-number) body);; body-fld-octets
2110
2111         ;; ok, we're done parsing the required parts, what comes now is one
2112         ;; of three things:
2113         ;;
2114         ;; envelope       (then we're parsing body-type-msg)
2115         ;; body-fld-lines (then we're parsing body-type-text)
2116         ;; body-ext-1part (then we're parsing body-type-basic)
2117         ;;
2118         ;; the problem is that the two first are in turn optionally followed
2119         ;; by the third.  So we parse the first two here (if there are any)...
2120
2121         (when (eq (char-after (point)) ?\ )
2122           (elmo-imap4-forward)
2123           (let (lines)
2124             (cond ((eq (char-after (point)) ?\();; body-type-msg:
2125                    (push (elmo-imap4-parse-envelope) body);; envelope
2126                    (elmo-imap4-forward)
2127                    (push (elmo-imap4-parse-body) body);; body
2128                    (elmo-imap4-forward)
2129                    (push (elmo-imap4-parse-number) body));; body-fld-lines
2130                   ((setq lines (elmo-imap4-parse-number));; body-type-text:
2131                    (push lines body));; body-fld-lines
2132                   (t
2133                    (backward-char)))));; no match...
2134
2135         ;; ...and then parse the third one here...
2136
2137         (when (eq (char-after (point)) ?\ );; body-ext-1part:
2138           (elmo-imap4-forward)
2139           (push (elmo-imap4-parse-nstring) body);; body-fld-md5
2140           (setq body
2141                 (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part..
2142
2143         (assert (eq (char-after (point)) ?\)))
2144         (elmo-imap4-forward)
2145         (nreverse body)))))
2146
2147 (require 'product)
2148 (product-provide (provide 'elmo-imap4) (require 'elmo-version))
2149
2150 ;;; elmo-imap4.el ends here