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