elmo/elmo-imap4.el

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