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 ;;; dirty hack
1156 ;;;(defconst sasl-imap4-login-steps
1157 ;;;  '(sasl-imap4-login-response))
1158 ;;;
1159 ;;;(defun sasl-imap4-login-response (client step)
1160 ;;;  (concat
1161 ;;;   (sasl-client-name client)
1162 ;;;   " "
1163 ;;;   (sasl-read-passphrase
1164 ;;;    (format "LOGIN passphrase for %s: " (sasl-client-name client)))))
1165 ;;;
1166 ;;;(put 'sasl-imap4-login 'sasl-mechanism
1167 ;;;     (sasl-make-mechanism "IMAP4-LOGIN" sasl-imap4-login-steps))
1168 ;;;
1169 ;;;(provide 'sasl-imap4-login)
1170
1171 (luna-define-method
1172   elmo-network-initialize-session-buffer :after ((session
1173                                                   elmo-imap4-session) buffer)
1174   (with-current-buffer buffer
1175     (mapcar 'make-variable-buffer-local elmo-imap4-local-variables)
1176     (setq elmo-imap4-seqno 0)
1177     (setq elmo-imap4-status 'initial)))
1178
1179 (luna-define-method elmo-network-initialize-session ((session
1180                                                       elmo-imap4-session))
1181   (let ((process (elmo-network-session-process-internal session)))
1182     (with-current-buffer (process-buffer process)
1183       ;; Skip garbage output from process before greeting.
1184       (while (and (memq (process-status process) '(open run))
1185                   (goto-char (point-max))
1186                   (forward-line -1)
1187                   (not (elmo-imap4-parse-greeting)))
1188         (accept-process-output process 1))
1189       (set-process-filter process 'elmo-imap4-arrival-filter)
1190       (set-process-sentinel process 'elmo-imap4-sentinel)
1191 ;;;   (while (and (memq (process-status process) '(open run))
1192 ;;;               (eq elmo-imap4-status 'initial))
1193 ;;;     (message "Waiting for server response...")
1194 ;;;     (accept-process-output process 1))
1195 ;;;   (message "")
1196       (unless (memq elmo-imap4-status '(nonauth auth))
1197         (signal 'elmo-open-error
1198                 (list 'elmo-network-initialize-session)))
1199       (elmo-imap4-session-set-capability-internal
1200        session
1201        (elmo-imap4-response-value
1202         (elmo-imap4-send-command-wait session "capability")
1203         'capability))
1204       (when (eq (elmo-network-stream-type-symbol
1205                  (elmo-network-session-stream-type-internal session))
1206                 'starttls)
1207         (or (memq 'starttls
1208                   (elmo-imap4-session-capability-internal session))
1209             (signal 'elmo-open-error
1210                     '(elmo-imap4-starttls-error)))
1211         (elmo-imap4-send-command-wait session "starttls")
1212         (starttls-negotiate process)))))
1213
1214 (luna-define-method elmo-network-authenticate-session ((session
1215                                                         elmo-imap4-session))
1216   (with-current-buffer (process-buffer
1217                         (elmo-network-session-process-internal session))
1218     (let* ((auth (elmo-network-session-auth-internal session))
1219 ;          (auth (mapcar '(lambda (a)
1220 ;                           (if (eq a 'plain)
1221 ;                               'imap4-login
1222 ;                             a))
1223 ;                        (if (listp auth) auth (list auth)))))
1224            (auth (if (listp auth) auth (list auth))))
1225       (unless (or (eq elmo-imap4-status 'auth)
1226                   (null auth))
1227         (if (eq 'plain (car auth))
1228             (elmo-imap4-login session)
1229           (let* ((elmo-imap4-debug-inhibit-logging t)
1230 ;              (sasl-mechanism-alist
1231 ;               (append
1232 ;                sasl-mechanism-alist
1233 ;                (list '("IMAP4-LOGIN" sasl-imap4-login))))
1234                (sasl-mechanisms
1235 ;               (append
1236                  (delq nil
1237                        (mapcar '(lambda (cap)
1238                                   (if (string-match "^auth=\\(.*\\)$"
1239                                                     (symbol-name cap))
1240                                       (match-string 1 (upcase (symbol-name cap)))))
1241                                (elmo-imap4-session-capability-internal session))))
1242 ;                (list "IMAP4-LOGIN")))
1243                (mechanism
1244 ;               (if (eq auth 'any)
1245 ;                   (sasl-find-mechanism sasl-mechanisms)
1246                   (sasl-find-mechanism
1247                    (delq nil
1248                          (mapcar '(lambda (cap) (upcase (symbol-name cap)))
1249                                  (if (listp auth)
1250                                      auth
1251                                    (list auth))))));)
1252                client name step response tag
1253                sasl-read-passphrase)
1254            (unless mechanism
1255               (if (or elmo-imap4-force-login
1256                       (y-or-n-p
1257                        (format
1258                         "There's no %s capability in server. continue?"
1259                         (elmo-list-to-string
1260                          (elmo-network-session-auth-internal session)))))
1261                   (setq mechanism (sasl-find-mechanism
1262                                    sasl-mechanisms))
1263                 (signal 'elmo-authenticate-error '(elmo-imap4-auth-no-mechanisms))))
1264             (setq client
1265                   (sasl-make-client
1266                    mechanism
1267                    (elmo-network-session-user-internal session)
1268                    "imap"
1269                    (elmo-network-session-host-internal session)))
1270 ;;;         (if elmo-imap4-auth-user-realm
1271 ;;;             (sasl-client-set-property client 'realm elmo-imap4-auth-user-realm))
1272             (setq name (sasl-mechanism-name mechanism)
1273                   step (sasl-next-step client nil))
1274             (elmo-network-session-set-auth-internal session
1275                                                     (intern (downcase name)))
1276             (setq sasl-read-passphrase
1277                   (function
1278                    (lambda (prompt)
1279                      (elmo-get-passwd
1280                       (elmo-network-session-password-key session)))))
1281 ;           (if (string= name "IMAP4-LOGIN")
1282 ;               (setq tag
1283 ;                     (elmo-imap4-send-command
1284 ;                      session
1285 ;                      (concat "LOGIN " (sasl-step-data step))))
1286               (setq tag
1287                     (elmo-imap4-send-command
1288                      session
1289                      (concat "AUTHENTICATE " name
1290                              (and (sasl-step-data step)
1291                                   (concat
1292                                    " "
1293                                    (elmo-base64-encode-string
1294                                     (sasl-step-data step)
1295                                     'no-lin-break))))));)
1296             (catch 'done
1297               (while t
1298                 (setq response (elmo-imap4-read-untagged
1299                                 (elmo-network-session-process-internal session)))
1300                 (if (and
1301                      (null (elmo-imap4-response-continue-req-p response))
1302                      (elmo-imap4-response-ok-p response)
1303                      (or (sasl-next-step client step)
1304                          (throw 'done nil)))
1305                     (signal 'elmo-authenticate-error
1306                             (list (intern
1307                                    (concat "elmo-imap4-auth-"
1308                                            (downcase name))))))
1309                 (sasl-step-set-data
1310                  step
1311                  (elmo-base64-decode-string
1312                   (elmo-imap4-response-value response 'continue-req)))
1313                 (setq step (sasl-next-step client step))
1314                 (setq tag
1315                       (elmo-imap4-send-string
1316                        session
1317                        (if (sasl-step-data step)
1318                            (elmo-base64-encode-string (sasl-step-data step)
1319                                                       'no-line-break)
1320                          "")))))))))))
1321
1322 (luna-define-method elmo-network-setup-session ((session
1323                                                  elmo-imap4-session))
1324   (with-current-buffer (elmo-network-session-buffer session)
1325     (when (memq 'namespace (elmo-imap4-session-capability-internal session))
1326       (setq elmo-imap4-server-namespace
1327             (elmo-imap4-response-value
1328              (elmo-imap4-send-command-wait session "namespace")
1329              'namespace)))))
1330
1331 (defun elmo-imap4-setup-send-buffer (string)
1332   (let ((tmp-buf (get-buffer-create " *elmo-imap4-setup-send-buffer*")))
1333     (save-excursion
1334       (save-match-data
1335         (set-buffer tmp-buf)
1336         (erase-buffer)
1337         (elmo-set-buffer-multibyte nil)
1338         (insert string)
1339         (goto-char (point-min))
1340         (if (eq (re-search-forward "^$" nil t)
1341                 (point-max))
1342             (insert "\n"))
1343         (goto-char (point-min))
1344         (while (search-forward "\n" nil t)
1345           (replace-match "\r\n"))))
1346     tmp-buf))
1347
1348 (defun elmo-imap4-read-part (folder msg part)
1349   (let* ((spec (elmo-folder-get-spec folder))
1350          (session (elmo-imap4-get-session spec)))
1351     (elmo-imap4-session-select-mailbox session
1352                                        (elmo-imap4-spec-mailbox spec))
1353     (with-current-buffer (elmo-network-session-buffer session)
1354       (setq elmo-imap4-fetch-callback nil)
1355       (setq elmo-imap4-fetch-callback-data nil))
1356     (elmo-delete-cr
1357      (elmo-imap4-response-bodydetail-text
1358       (elmo-imap4-response-value-all
1359        (elmo-imap4-send-command-wait session
1360                                      (format
1361                                       (if elmo-imap4-use-uid
1362                                           "uid fetch %s body.peek[%s]"
1363                                         "fetch %s body.peek[%s]")
1364                                       msg part))
1365        'fetch)))))
1366
1367 (defun elmo-imap4-prefetch-msg (spec msg outbuf)
1368   (elmo-imap4-read-msg spec msg outbuf 'unseen))
1369
1370 (defun elmo-imap4-read-msg (spec msg outbuf
1371                                  &optional leave-seen-flag-untouched)
1372   (let ((session (elmo-imap4-get-session spec))
1373         response)
1374     (elmo-imap4-session-select-mailbox session
1375                                        (elmo-imap4-spec-mailbox spec))
1376     (with-current-buffer (elmo-network-session-buffer session)
1377       (setq elmo-imap4-fetch-callback nil)
1378       (setq elmo-imap4-fetch-callback-data nil))
1379     (setq response
1380           (elmo-imap4-send-command-wait session
1381                                         (format
1382                                          (if elmo-imap4-use-uid
1383                                              "uid fetch %s rfc822%s"
1384                                            "fetch %s rfc822%s")
1385                                          msg
1386                                          (if leave-seen-flag-untouched
1387                                              ".peek" ""))))
1388     (and (setq response (elmo-imap4-response-value
1389                          (elmo-imap4-response-value-all
1390                           response 'fetch )
1391                          'rfc822))
1392          (with-current-buffer outbuf
1393            (erase-buffer)
1394            (insert response)
1395            (elmo-delete-cr-get-content-type)))))
1396
1397 (defun elmo-imap4-setup-send-buffer-from-file (file)
1398   (let ((tmp-buf (get-buffer-create
1399                   " *elmo-imap4-setup-send-buffer-from-file*")))
1400     (save-excursion
1401       (save-match-data
1402         (set-buffer tmp-buf)
1403         (erase-buffer)
1404         (as-binary-input-file
1405          (insert-file-contents file))
1406         (goto-char (point-min))
1407         (if (eq (re-search-forward "^$" nil t)
1408                 (point-max))
1409             (insert "\n"))
1410         (goto-char (point-min))
1411         (while (search-forward "\n" nil t)
1412           (replace-match "\r\n"))))
1413     tmp-buf))
1414
1415 (defun elmo-imap4-delete-msgids (spec msgids)
1416   "If actual message-id is matched, then delete it."
1417   (let ((message-ids msgids)
1418         (i 0)
1419         (num (length msgids)))
1420     (while message-ids
1421       (setq i (+ 1 i))
1422       (message "Deleting message...%d/%d" i num)
1423       (elmo-imap4-delete-msg-by-id spec (car message-ids))
1424       (setq message-ids (cdr message-ids)))
1425     (elmo-imap4-send-command-wait (elmo-imap4-get-session spec) "expunge")))
1426
1427 (defun elmo-imap4-delete-msg-by-id (spec msgid)
1428   (let ((session (elmo-imap4-get-session spec)))
1429     (elmo-imap4-session-select-mailbox session
1430                                        (elmo-imap4-spec-mailbox spec))
1431     (elmo-imap4-delete-msgs-no-expunge
1432      spec
1433      (elmo-imap4-response-value
1434       (elmo-imap4-send-command-wait session
1435                                     (list
1436                                      (if elmo-imap4-use-uid
1437                                          "uid search header message-id "
1438                                        "search header message-id ")
1439                                      (elmo-imap4-field-body msgid)))
1440       'search))))
1441
1442 (defun elmo-imap4-append-msg-by-id (spec msgid)
1443   (let ((session (elmo-imap4-get-session spec))
1444         send-buf)
1445     (elmo-imap4-session-select-mailbox session
1446                                        (elmo-imap4-spec-mailbox spec))
1447     (setq send-buf (elmo-imap4-setup-send-buffer-from-file
1448                     (elmo-cache-get-path msgid)))
1449     (unwind-protect
1450         (elmo-imap4-send-command-wait
1451          session
1452          (list
1453           "append "
1454           (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec))
1455           " (\\Seen) "
1456           (elmo-imap4-buffer-literal send-buf)))
1457       (kill-buffer send-buf)))
1458   t)
1459
1460 (defun elmo-imap4-append-msg (spec string &optional msg no-see)
1461   (let ((session (elmo-imap4-get-session spec))
1462         send-buf)
1463     (elmo-imap4-session-select-mailbox session
1464                                        (elmo-imap4-spec-mailbox spec))
1465     (setq send-buf (elmo-imap4-setup-send-buffer string))
1466     (unwind-protect
1467         (elmo-imap4-send-command-wait
1468          session
1469          (list
1470           "append "
1471           (elmo-imap4-mailbox (elmo-imap4-spec-mailbox spec))
1472           (if no-see " " " (\\Seen) ")
1473           (elmo-imap4-buffer-literal send-buf)))
1474       (kill-buffer send-buf)))
1475   t)
1476
1477 (defun elmo-imap4-copy-msgs (dst-spec
1478                              msgs src-spec &optional expunge-it same-number)
1479   "Equivalence of hostname, username is assumed."
1480   (let ((session (elmo-imap4-get-session src-spec)))
1481     (elmo-imap4-session-select-mailbox session
1482                                        (elmo-imap4-spec-mailbox src-spec))
1483     (while msgs
1484       (elmo-imap4-send-command-wait session
1485                                     (list
1486                                      (format
1487                                       (if elmo-imap4-use-uid
1488                                           "uid copy %s "
1489                                         "copy %s ")
1490                                       (car msgs))
1491                                      (elmo-imap4-mailbox
1492                                       (elmo-imap4-spec-mailbox dst-spec))))
1493       (setq msgs (cdr msgs)))
1494     (when expunge-it
1495       (elmo-imap4-send-command-wait session "expunge"))
1496     t))
1497
1498 (defun elmo-imap4-server-diff-async-callback-1 (status data)
1499   (funcall elmo-imap4-server-diff-async-callback
1500            (cons (elmo-imap4-response-value status 'unseen)
1501                  (elmo-imap4-response-value status 'messages))
1502            data))
1503
1504 (defun elmo-imap4-server-diff-async (spec)
1505   (let ((session (elmo-imap4-get-session spec)))
1506     ;; commit.
1507     ;; (elmo-imap4-commit spec)
1508     (with-current-buffer (elmo-network-session-buffer session)
1509       (setq elmo-imap4-status-callback
1510             'elmo-imap4-server-diff-async-callback-1)
1511       (setq elmo-imap4-status-callback-data
1512             elmo-imap4-server-diff-async-callback-data))
1513     (elmo-imap4-send-command session
1514                              (list
1515                               "status "
1516                               (elmo-imap4-mailbox
1517                                (elmo-imap4-spec-mailbox spec))
1518                               " (unseen messages)"))))
1519
1520 (defun elmo-imap4-server-diff (spec)
1521   "Get server status"
1522   (let ((session (elmo-imap4-get-session spec))
1523         response)
1524     ;; commit.
1525 ;;; (elmo-imap4-commit spec)
1526     (with-current-buffer (elmo-network-session-buffer session)
1527       (setq elmo-imap4-status-callback nil)
1528       (setq elmo-imap4-status-callback-data nil))
1529     (setq response
1530           (elmo-imap4-send-command-wait session
1531                                         (list
1532                                          "status "
1533                                          (elmo-imap4-mailbox
1534                                           (elmo-imap4-spec-mailbox spec))
1535                                          " (unseen messages)")))
1536     (setq response (elmo-imap4-response-value response 'status))
1537     (cons (elmo-imap4-response-value response 'unseen)
1538           (elmo-imap4-response-value response 'messages))))
1539
1540 (defun elmo-imap4-use-cache-p (spec number)
1541   elmo-imap4-use-cache)
1542
1543 (defun elmo-imap4-local-file-p (spec number)
1544   nil)
1545
1546 (defun elmo-imap4-port-label (spec)
1547   (concat "imap4"
1548           (if (elmo-imap4-spec-stream-type spec)
1549               (concat "!" (symbol-name
1550                            (elmo-network-stream-type-symbol
1551                             (elmo-imap4-spec-stream-type spec)))))))
1552
1553
1554 (defsubst elmo-imap4-portinfo (spec)
1555   (list (elmo-imap4-spec-hostname spec) (elmo-imap4-spec-port spec)))
1556
1557 (defun elmo-imap4-plugged-p (spec)
1558   (apply 'elmo-plugged-p
1559          (append (elmo-imap4-portinfo spec)
1560                  (list nil (quote (elmo-imap4-port-label spec))))))
1561
1562 (defun elmo-imap4-set-plugged (spec plugged add)
1563   (apply 'elmo-set-plugged plugged
1564          (append (elmo-imap4-portinfo spec)
1565                  (list nil nil (quote (elmo-imap4-port-label spec)) add))))
1566
1567 (defalias 'elmo-imap4-sync-number-alist 'elmo-generic-sync-number-alist)
1568
1569 ;;; IMAP parser.
1570
1571 (defvar elmo-imap4-server-eol "\r\n"
1572   "The EOL string sent from the server.")
1573
1574 (defvar elmo-imap4-client-eol "\r\n"
1575   "The EOL string we send to the server.")
1576
1577 (defun elmo-imap4-find-next-line ()
1578   "Return point at end of current line, taking into account literals.
1579 Return nil if no complete line has arrived."
1580   (when (re-search-forward (concat elmo-imap4-server-eol "\\|{\\([0-9]+\\)}"
1581                                    elmo-imap4-server-eol)
1582                            nil t)
1583     (if (match-string 1)
1584         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1585             nil
1586           (goto-char (+ (point) (string-to-number (match-string 1))))
1587           (elmo-imap4-find-next-line))
1588       (point))))
1589
1590 (defun elmo-imap4-sentinel (process string)
1591   (delete-process process))
1592
1593 (defun elmo-imap4-arrival-filter (proc string)
1594   "IMAP process filter."
1595   (with-current-buffer (process-buffer proc)
1596     (elmo-imap4-debug "-> %s" string)
1597     (goto-char (point-max))
1598     (insert string)
1599     (let (end)
1600       (goto-char (point-min))
1601       (while (setq end (elmo-imap4-find-next-line))
1602         (save-restriction
1603           (narrow-to-region (point-min) end)
1604           (delete-backward-char (length elmo-imap4-server-eol))
1605           (goto-char (point-min))
1606           (unwind-protect
1607               (cond ((eq elmo-imap4-status 'initial)
1608                      (setq elmo-imap4-current-response
1609                            (list
1610                             (list 'greeting (elmo-imap4-parse-greeting)))))
1611                     ((or (eq elmo-imap4-status 'auth)
1612                          (eq elmo-imap4-status 'nonauth)
1613                          (eq elmo-imap4-status 'selected)
1614                          (eq elmo-imap4-status 'examine))
1615                      (setq elmo-imap4-current-response
1616                            (cons
1617                             (elmo-imap4-parse-response)
1618                             elmo-imap4-current-response)))
1619                     (t
1620                      (message "Unknown state %s in arrival filter"
1621                               elmo-imap4-status))))
1622           (delete-region (point-min) (point-max)))))))
1623
1624 ;; IMAP parser.
1625
1626 (defsubst elmo-imap4-forward ()
1627   (or (eobp) (forward-char 1)))
1628
1629 (defsubst elmo-imap4-parse-number ()
1630   (when (looking-at "[0-9]+")
1631     (prog1
1632         (string-to-number (match-string 0))
1633       (goto-char (match-end 0)))))
1634
1635 (defsubst elmo-imap4-parse-literal ()
1636   (when (looking-at "{\\([0-9]+\\)}\r\n")
1637     (let ((pos (match-end 0))
1638           (len (string-to-number (match-string 1))))
1639       (if (< (point-max) (+ pos len))
1640           nil
1641         (goto-char (+ pos len))
1642         (buffer-substring pos (+ pos len))))))
1643 ;;;     (list ' pos (+ pos len))))))
1644
1645 (defsubst elmo-imap4-parse-string ()
1646   (cond ((eq (char-after (point)) ?\")
1647          (forward-char 1)
1648          (let ((p (point)) (name ""))
1649            (skip-chars-forward "^\"\\\\")
1650            (setq name (buffer-substring p (point)))
1651            (while (eq (char-after (point)) ?\\)
1652              (setq p (1+ (point)))
1653              (forward-char 2)
1654              (skip-chars-forward "^\"\\\\")
1655              (setq name (concat name (buffer-substring p (point)))))
1656            (forward-char 1)
1657            name))
1658         ((eq (char-after (point)) ?{)
1659          (elmo-imap4-parse-literal))))
1660
1661 (defsubst elmo-imap4-parse-nil ()
1662   (if (looking-at "NIL")
1663       (goto-char (match-end 0))))
1664
1665 (defsubst elmo-imap4-parse-nstring ()
1666   (or (elmo-imap4-parse-string)
1667       (and (elmo-imap4-parse-nil)
1668            nil)))
1669
1670 (defsubst elmo-imap4-parse-astring ()
1671   (or (elmo-imap4-parse-string)
1672       (buffer-substring (point)
1673                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1674                             (goto-char (1- (match-end 0)))
1675                           (end-of-line)
1676                           (point)))))
1677
1678 (defsubst elmo-imap4-parse-address ()
1679   (let (address)
1680     (when (eq (char-after (point)) ?\()
1681       (elmo-imap4-forward)
1682       (setq address (vector (prog1 (elmo-imap4-parse-nstring)
1683                               (elmo-imap4-forward))
1684                             (prog1 (elmo-imap4-parse-nstring)
1685                               (elmo-imap4-forward))
1686                             (prog1 (elmo-imap4-parse-nstring)
1687                               (elmo-imap4-forward))
1688                             (elmo-imap4-parse-nstring)))
1689       (when (eq (char-after (point)) ?\))
1690         (elmo-imap4-forward)
1691         address))))
1692
1693 (defsubst elmo-imap4-parse-address-list ()
1694   (if (eq (char-after (point)) ?\()
1695       (let (address addresses)
1696         (elmo-imap4-forward)
1697         (while (and (not (eq (char-after (point)) ?\)))
1698                     ;; next line for MS Exchange bug
1699                     (progn (and (eq (char-after (point)) ? ) (elmo-imap4-forward)) t)
1700                     (setq address (elmo-imap4-parse-address)))
1701           (setq addresses (cons address addresses)))
1702         (when (eq (char-after (point)) ?\))
1703           (elmo-imap4-forward)
1704           (nreverse addresses)))
1705     (assert (elmo-imap4-parse-nil))))
1706
1707 (defsubst elmo-imap4-parse-mailbox ()
1708   (let ((mailbox (elmo-imap4-parse-astring)))
1709     (if (string-equal "INBOX" (upcase mailbox))
1710         "INBOX"
1711       mailbox)))
1712
1713 (defun elmo-imap4-parse-greeting ()
1714   "Parse a IMAP greeting."
1715   (cond ((looking-at "\\* OK ")
1716          (setq elmo-imap4-status 'nonauth))
1717         ((looking-at "\\* PREAUTH ")
1718          (setq elmo-imap4-status 'auth))
1719         ((looking-at "\\* BYE ")
1720          (setq elmo-imap4-status 'closed))))
1721
1722 (defun elmo-imap4-parse-response ()
1723   "Parse a IMAP command response."
1724   (let (token)
1725     (case (setq token (elmo-read (current-buffer)))
1726       (+ (progn
1727            (skip-chars-forward " ")
1728            (list 'continue-req (buffer-substring (point) (point-max)))))
1729       (* (case (prog1 (setq token (elmo-read (current-buffer)))
1730                  (elmo-imap4-forward))
1731            (OK         (elmo-imap4-parse-resp-text-code))
1732            (NO         (elmo-imap4-parse-resp-text-code))
1733            (BAD        (elmo-imap4-parse-resp-text-code))
1734            (BYE        (elmo-imap4-parse-bye))
1735            (FLAGS      (list 'flags
1736                              (elmo-imap4-parse-flag-list)))
1737            (LIST       (list 'list (elmo-imap4-parse-data-list)))
1738            (LSUB       (list 'lsub (elmo-imap4-parse-data-list)))
1739            (SEARCH     (list
1740                         'search
1741                         (elmo-read (concat "("
1742                                       (buffer-substring (point) (point-max))
1743                                       ")"))))
1744            (STATUS     (elmo-imap4-parse-status))
1745            ;; Added
1746            (NAMESPACE  (elmo-imap4-parse-namespace))
1747            (CAPABILITY (list 'capability
1748                              (elmo-read
1749                               (concat "(" (downcase (buffer-substring
1750                                                      (point) (point-max)))
1751                                       ")"))))
1752            (ACL        (elmo-imap4-parse-acl))
1753            (t       (case (prog1 (elmo-read (current-buffer))
1754                             (elmo-imap4-forward))
1755                       (EXISTS  (list 'exists token))
1756                       (RECENT  (list 'recent token))
1757                       (EXPUNGE (list 'expunge token))
1758                       (FETCH   (elmo-imap4-parse-fetch token))
1759                       (t       (list 'garbage (buffer-string)))))))
1760       (t (if (not (string-match elmo-imap4-seq-prefix (symbol-name token)))
1761              (list 'garbage (buffer-string))
1762            (case (prog1 (elmo-read (current-buffer))
1763                    (elmo-imap4-forward))
1764              (OK  (progn
1765                     (setq elmo-imap4-parsing nil)
1766                     (setq token (symbol-name token))
1767                     (elmo-unintern token)
1768                     (elmo-imap4-debug "*%s* OK arrived" token)
1769                     (setq elmo-imap4-reached-tag token)
1770                     (list 'ok (elmo-imap4-parse-resp-text-code))))
1771              (NO  (progn
1772                     (setq elmo-imap4-parsing nil)
1773                     (setq token (symbol-name token))
1774                     (elmo-unintern token)
1775                     (elmo-imap4-debug "*%s* NO arrived" token)
1776                     (setq elmo-imap4-reached-tag token)
1777                     (let (code text)
1778                       (when (eq (char-after (point)) ?\[)
1779                         (setq code (buffer-substring (point)
1780                                                      (search-forward "]")))
1781                         (elmo-imap4-forward))
1782                       (setq text (buffer-substring (point) (point-max)))
1783                       (list 'no (list code text)))))
1784              (BAD (progn
1785                     (setq elmo-imap4-parsing nil)
1786                     (elmo-imap4-debug "*%s* BAD arrived" token)
1787                     (setq token (symbol-name token))
1788                     (elmo-unintern token)
1789                     (setq elmo-imap4-reached-tag token)
1790                     (let (code text)
1791                       (when (eq (char-after (point)) ?\[)
1792                         (setq code (buffer-substring (point)
1793                                                      (search-forward "]")))
1794                         (elmo-imap4-forward))
1795                       (setq text (buffer-substring (point) (point-max)))
1796                       (list 'bad (list code text)))))
1797              (t   (list 'garbage (buffer-string)))))))))
1798
1799 (defun elmo-imap4-parse-bye ()
1800   (let (code text)
1801     (when (eq (char-after (point)) ?\[)
1802       (setq code (buffer-substring (point)
1803                                    (search-forward "]")))
1804       (elmo-imap4-forward))
1805     (setq text (buffer-substring (point) (point-max)))
1806     (list 'bye (list code text))))
1807
1808 (defun elmo-imap4-parse-text ()
1809   (goto-char (point-min))
1810   (when (search-forward "[" nil t)
1811     (search-forward "]")
1812     (elmo-imap4-forward))
1813   (list 'text (buffer-substring (point) (point-max))))
1814
1815 (defun elmo-imap4-parse-resp-text-code ()
1816   (when (eq (char-after (point)) ?\[)
1817     (elmo-imap4-forward)
1818     (cond ((search-forward "PERMANENTFLAGS " nil t)
1819            (list 'permanentflags (elmo-imap4-parse-flag-list)))
1820           ((search-forward "UIDNEXT " nil t)
1821            (list 'uidnext (elmo-read (current-buffer))))
1822           ((search-forward "UNSEEN " nil t)
1823            (list 'unseen (elmo-read (current-buffer))))
1824           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
1825            (list 'uidvalidity (match-string 1)))
1826           ((search-forward "READ-ONLY" nil t)
1827            (list 'read-only t))
1828           ((search-forward "READ-WRITE" nil t)
1829            (list 'read-write t))
1830           ((search-forward "NEWNAME " nil t)
1831            (let (oldname newname)
1832              (setq oldname (elmo-imap4-parse-string))
1833              (elmo-imap4-forward)
1834              (setq newname (elmo-imap4-parse-string))
1835              (list 'newname newname oldname)))
1836           ((search-forward "TRYCREATE" nil t)
1837            (list 'trycreate t))
1838           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
1839            (list 'appenduid
1840                  (list (match-string 1)
1841                        (string-to-number (match-string 2)))))
1842           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
1843            (list 'copyuid (list (match-string 1)
1844                                 (match-string 2)
1845                                 (match-string 3))))
1846           ((search-forward "ALERT] " nil t)
1847            (message "IMAP server information: %s"
1848                     (buffer-substring (point) (point-max))))
1849           (t (list 'unknown)))))
1850
1851 (defun elmo-imap4-parse-data-list ()
1852   (let (flags delimiter mailbox)
1853     (setq flags (elmo-imap4-parse-flag-list))
1854     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
1855       (setq delimiter (match-string 1))
1856       (goto-char (1+ (match-end 0)))
1857       (when (setq mailbox (elmo-imap4-parse-mailbox))
1858         (list mailbox flags delimiter)))))
1859
1860 (defsubst elmo-imap4-parse-header-list ()
1861   (when (eq (char-after (point)) ?\()
1862     (let (strlist)
1863       (while (not (eq (char-after (point)) ?\)))
1864         (elmo-imap4-forward)
1865         (push (elmo-imap4-parse-astring) strlist))
1866       (elmo-imap4-forward)
1867       (nreverse strlist))))
1868
1869 (defsubst elmo-imap4-parse-fetch-body-section ()
1870   (let ((section
1871          (buffer-substring (point)
1872                            (1-
1873                             (progn (re-search-forward "[] ]" nil t)
1874                                    (point))))))
1875     (if (eq (char-before) ? )
1876         (prog1
1877             (mapconcat 'identity
1878                        (cons section (elmo-imap4-parse-header-list)) " ")
1879           (search-forward "]" nil t))
1880       section)))
1881
1882 (defun elmo-imap4-parse-fetch (response)
1883   (when (eq (char-after (point)) ?\()
1884     (let (element list)
1885       (while (not (eq (char-after (point)) ?\)))
1886         (elmo-imap4-forward)
1887         (let ((token (elmo-imap4-fetch-read (current-buffer))))
1888           (elmo-imap4-forward)
1889           (setq element
1890                 (cond ((eq token 'UID)
1891                        (list 'uid (condition-case nil
1892                                       (elmo-read (current-buffer))
1893                                     (error nil))))
1894                       ((eq token 'FLAGS)
1895                        (list 'flags (elmo-imap4-parse-flag-list)))
1896                       ((eq token 'ENVELOPE)
1897                        (list 'envelope (elmo-imap4-parse-envelope)))
1898                       ((eq token 'INTERNALDATE)
1899                        (list 'internaldate (elmo-imap4-parse-string)))
1900                       ((eq token 'RFC822)
1901                        (list 'rfc822 (elmo-imap4-parse-nstring)))
1902                       ((eq token (intern elmo-imap4-rfc822-header))
1903                        (list 'rfc822header (elmo-imap4-parse-nstring)))
1904                       ((eq token (intern elmo-imap4-rfc822-text))
1905                        (list 'rfc822text (elmo-imap4-parse-nstring)))
1906                       ((eq token (intern elmo-imap4-rfc822-size))
1907                        (list 'rfc822size (elmo-read (current-buffer))))
1908                       ((eq token 'BODY)
1909                        (if (eq (char-before) ?\[)
1910                            (list
1911                             'bodydetail
1912                             (upcase (elmo-imap4-parse-fetch-body-section))
1913                             (and
1914                              (eq (char-after (point)) ?<)
1915                              (buffer-substring (1+ (point))
1916                                                (progn
1917                                                  (search-forward ">" nil t)
1918                                                  (point))))
1919                             (progn (elmo-imap4-forward)
1920                                    (elmo-imap4-parse-nstring)))
1921                          (list 'body (elmo-imap4-parse-body))))
1922                       ((eq token 'BODYSTRUCTURE)
1923                        (list 'bodystructure (elmo-imap4-parse-body)))))
1924           (setq list (cons element list))))
1925       (and elmo-imap4-fetch-callback
1926            (elmo-imap4-fetch-callback list elmo-imap4-fetch-callback-data))
1927       (list 'fetch list))))
1928
1929 (defun elmo-imap4-parse-status ()
1930   (let ((mailbox (elmo-imap4-parse-mailbox))
1931         status)
1932     (when (and mailbox (search-forward "(" nil t))
1933       (while (not (eq (char-after (point)) ?\)))
1934         (setq status
1935               (cons
1936                (let ((token (elmo-read (current-buffer))))
1937                  (cond ((eq token 'MESSAGES)
1938                         (list 'messages (elmo-read (current-buffer))))
1939                        ((eq token 'RECENT)
1940                         (list 'recent (elmo-read (current-buffer))))
1941                        ((eq token 'UIDNEXT)
1942                         (list 'uidnext (elmo-read (current-buffer))))
1943                        ((eq token 'UIDVALIDITY)
1944                         (and (looking-at " \\([0-9]+\\)")
1945                              (prog1 (list 'uidvalidity (match-string 1))
1946                                (goto-char (match-end 1)))))
1947                        ((eq token 'UNSEEN)
1948                         (list 'unseen (elmo-read (current-buffer))))
1949                        (t
1950                         (message
1951                          "Unknown status data %s in mailbox %s ignored"
1952                          token mailbox))))
1953                status))))
1954     (and elmo-imap4-status-callback
1955          (funcall elmo-imap4-status-callback
1956                   status
1957                   elmo-imap4-status-callback-data))
1958     (list 'status status)))
1959
1960
1961 (defmacro elmo-imap4-value (value)
1962   (` (if (eq (, value) 'NIL) nil
1963        (, value))))
1964
1965 (defmacro elmo-imap4-nth (pos list)
1966   (` (let ((value (nth (, pos) (, list))))
1967        (elmo-imap4-value value))))
1968
1969 (defun elmo-imap4-parse-namespace ()
1970   (list 'namespace
1971         (nconc
1972          (copy-sequence elmo-imap4-extra-namespace-alist)
1973          (elmo-imap4-parse-namespace-subr
1974           (elmo-read (concat "(" (buffer-substring
1975                                   (point) (point-max))
1976                              ")"))))))
1977
1978 (defun elmo-imap4-parse-namespace-subr (ns)
1979   (let (prefix delim namespace-alist default-delim)
1980     ;; 0: personal, 1: other, 2: shared
1981     (dotimes (i 3)
1982       (setq namespace-alist
1983             (nconc namespace-alist
1984                    (delq nil
1985                          (mapcar
1986                           (lambda (namespace)
1987                             (setq prefix (elmo-imap4-nth 0 namespace)
1988                                   delim (elmo-imap4-nth 1 namespace))
1989                             (if (and prefix delim
1990                                      (string-match
1991                                       (concat (regexp-quote delim) "\\'")
1992                                       prefix))
1993                                 (setq prefix (substring prefix 0
1994                                                         (match-beginning 0))))
1995                             (if (eq (length prefix) 0)
1996                                 (progn (setq default-delim delim) nil)
1997                               (cons
1998                                (concat "^"
1999                                        (if (string= (downcase prefix) "inbox")
2000                                            "[Ii][Nn][Bb][Oo][Xx]"
2001                                          (regexp-quote prefix))
2002                                        ".*$")
2003                                delim)))
2004                           (elmo-imap4-nth i ns))))))
2005     (if default-delim
2006         (setq namespace-alist
2007               (nconc namespace-alist
2008                      (list (cons "^.*$" default-delim)))))
2009     namespace-alist))
2010
2011 (defun elmo-imap4-parse-acl ()
2012   (let ((mailbox (elmo-imap4-parse-mailbox))
2013         identifier rights acl)
2014     (while (eq (char-after (point)) ?\ )
2015       (elmo-imap4-forward)
2016       (setq identifier (elmo-imap4-parse-astring))
2017       (elmo-imap4-forward)
2018       (setq rights (elmo-imap4-parse-astring))
2019       (setq acl (append acl (list (cons identifier rights)))))
2020     (list 'acl acl mailbox)))
2021
2022 (defun elmo-imap4-parse-flag-list ()
2023   (let ((str (buffer-substring (+ (point) 1)
2024                                (progn (search-forward ")" nil t)
2025                                       (- (point) 1)))))
2026     (unless (eq (length str) 0)
2027       (split-string str))))
2028
2029 (defun elmo-imap4-parse-envelope ()
2030   (when (eq (char-after (point)) ?\()
2031     (elmo-imap4-forward)
2032     (vector (prog1 (elmo-imap4-parse-nstring);; date
2033               (elmo-imap4-forward))
2034             (prog1 (elmo-imap4-parse-nstring);; subject
2035               (elmo-imap4-forward))
2036             (prog1 (elmo-imap4-parse-address-list);; from
2037               (elmo-imap4-forward))
2038             (prog1 (elmo-imap4-parse-address-list);; sender
2039               (elmo-imap4-forward))
2040             (prog1 (elmo-imap4-parse-address-list);; reply-to
2041               (elmo-imap4-forward))
2042             (prog1 (elmo-imap4-parse-address-list);; to
2043               (elmo-imap4-forward))
2044             (prog1 (elmo-imap4-parse-address-list);; cc
2045               (elmo-imap4-forward))
2046             (prog1 (elmo-imap4-parse-address-list);; bcc
2047               (elmo-imap4-forward))
2048             (prog1 (elmo-imap4-parse-nstring);; in-reply-to
2049               (elmo-imap4-forward))
2050             (prog1 (elmo-imap4-parse-nstring);; message-id
2051               (elmo-imap4-forward)))))
2052
2053 (defsubst elmo-imap4-parse-string-list ()
2054   (cond ((eq (char-after (point)) ?\();; body-fld-param
2055          (let (strlist str)
2056            (elmo-imap4-forward)
2057            (while (setq str (elmo-imap4-parse-string))
2058              (push str strlist)
2059              (elmo-imap4-forward))
2060            (nreverse strlist)))
2061         ((elmo-imap4-parse-nil)
2062          nil)))
2063
2064 (defun elmo-imap4-parse-body-extension ()
2065   (if (eq (char-after (point)) ?\()
2066       (let (b-e)
2067         (elmo-imap4-forward)
2068         (push (elmo-imap4-parse-body-extension) b-e)
2069         (while (eq (char-after (point)) ?\ )
2070           (elmo-imap4-forward)
2071           (push (elmo-imap4-parse-body-extension) b-e))
2072         (assert (eq (char-after (point)) ?\)))
2073         (elmo-imap4-forward)
2074         (nreverse b-e))
2075     (or (elmo-imap4-parse-number)
2076         (elmo-imap4-parse-nstring))))
2077
2078 (defsubst elmo-imap4-parse-body-ext ()
2079   (let (ext)
2080     (when (eq (char-after (point)) ?\ );; body-fld-dsp
2081       (elmo-imap4-forward)
2082       (let (dsp)
2083         (if (eq (char-after (point)) ?\()
2084             (progn
2085               (elmo-imap4-forward)
2086               (push (elmo-imap4-parse-string) dsp)
2087               (elmo-imap4-forward)
2088               (push (elmo-imap4-parse-string-list) dsp)
2089               (elmo-imap4-forward))
2090           (assert (elmo-imap4-parse-nil)))
2091         (push (nreverse dsp) ext))
2092       (when (eq (char-after (point)) ?\ );; body-fld-lang
2093         (elmo-imap4-forward)
2094         (if (eq (char-after (point)) ?\()
2095             (push (elmo-imap4-parse-string-list) ext)
2096           (push (elmo-imap4-parse-nstring) ext))
2097         (while (eq (char-after (point)) ?\ );; body-extension
2098           (elmo-imap4-forward)
2099           (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
2100     ext))
2101
2102 (defun elmo-imap4-parse-body ()
2103   (let (body)
2104     (when (eq (char-after (point)) ?\()
2105       (elmo-imap4-forward)
2106       (if (eq (char-after (point)) ?\()
2107           (let (subbody)
2108             (while (and (eq (char-after (point)) ?\()
2109                         (setq subbody (elmo-imap4-parse-body)))
2110               (push subbody body))
2111             (elmo-imap4-forward)
2112             (push (elmo-imap4-parse-string) body);; media-subtype
2113             (when (eq (char-after (point)) ?\ );; body-ext-mpart:
2114               (elmo-imap4-forward)
2115               (if (eq (char-after (point)) ?\();; body-fld-param
2116                   (push (elmo-imap4-parse-string-list) body)
2117                 (push (and (elmo-imap4-parse-nil) nil) body))
2118               (setq body
2119                     (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
2120             (assert (eq (char-after (point)) ?\)))
2121             (elmo-imap4-forward)
2122             (nreverse body))
2123
2124         (push (elmo-imap4-parse-string) body);; media-type
2125         (elmo-imap4-forward)
2126         (push (elmo-imap4-parse-string) body);; media-subtype
2127         (elmo-imap4-forward)
2128         ;; next line for Sun SIMS bug
2129         (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
2130         (if (eq (char-after (point)) ?\();; body-fld-param
2131             (push (elmo-imap4-parse-string-list) body)
2132           (push (and (elmo-imap4-parse-nil) nil) body))
2133         (elmo-imap4-forward)
2134         (push (elmo-imap4-parse-nstring) body);; body-fld-id
2135         (elmo-imap4-forward)
2136         (push (elmo-imap4-parse-nstring) body);; body-fld-desc
2137         (elmo-imap4-forward)
2138         (push (elmo-imap4-parse-string) body);; body-fld-enc
2139         (elmo-imap4-forward)
2140         (push (elmo-imap4-parse-number) body);; body-fld-octets
2141
2142         ;; ok, we're done parsing the required parts, what comes now is one
2143         ;; of three things:
2144         ;;
2145         ;; envelope       (then we're parsing body-type-msg)
2146         ;; body-fld-lines (then we're parsing body-type-text)
2147         ;; body-ext-1part (then we're parsing body-type-basic)
2148         ;;
2149         ;; the problem is that the two first are in turn optionally followed
2150         ;; by the third.  So we parse the first two here (if there are any)...
2151
2152         (when (eq (char-after (point)) ?\ )
2153           (elmo-imap4-forward)
2154           (let (lines)
2155             (cond ((eq (char-after (point)) ?\();; body-type-msg:
2156                    (push (elmo-imap4-parse-envelope) body);; envelope
2157                    (elmo-imap4-forward)
2158                    (push (elmo-imap4-parse-body) body);; body
2159                    (elmo-imap4-forward)
2160                    (push (elmo-imap4-parse-number) body));; body-fld-lines
2161                   ((setq lines (elmo-imap4-parse-number));; body-type-text:
2162                    (push lines body));; body-fld-lines
2163                   (t
2164                    (backward-char)))));; no match...
2165
2166         ;; ...and then parse the third one here...
2167
2168         (when (eq (char-after (point)) ?\ );; body-ext-1part:
2169           (elmo-imap4-forward)
2170           (push (elmo-imap4-parse-nstring) body);; body-fld-md5
2171           (setq body
2172                 (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part..
2173
2174         (assert (eq (char-after (point)) ?\)))
2175         (elmo-imap4-forward)
2176         (nreverse body)))))
2177
2178 (require 'product)
2179 (product-provide (provide 'elmo-imap4) (require 'elmo-version))
2180
2181 ;;; elmo-imap4.el ends here