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