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