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