elmo/elmo-imap4.el

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