git.chise.org Git - elisp/gnus.git-/blob - lisp/imap.el

   1 ;;; imap.el --- imap library
   2 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Simon Josefsson <jas@pdc.kth.se>
   6 ;; Keywords: mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; imap.el is a elisp library providing an interface for talking to
  28 ;; IMAP servers.
  29 ;;
  30 ;; imap.el is roughly divided in two parts, one that parses IMAP
  31 ;; responses from the server and storing data into buffer-local
  32 ;; variables, and one for utility functions which send commands to
  33 ;; server, waits for an answer, and return information.  The latter
  34 ;; part is layered on top of the previous.
  35 ;;
  36 ;; The imap.el API consist of the following functions, other functions
  37 ;; in this file should not be called directly and the result of doing
  38 ;; so are at best undefined.
  39 ;;
  40 ;; Global commands:
  41 ;;
  42 ;; imap-open,       imap-opened,    imap-authenticate, imap-close,
  43 ;; imap-capability, imap-namespace, imap-error-text
  44 ;;
  45 ;; Mailbox commands:
  46 ;;
  47 ;; imap-mailbox-get,       imap-mailbox-map,         imap-current-mailbox,
  48 ;; imap-current-mailbox-p, imap-search,              imap-mailbox-select,
  49 ;; imap-mailbox-examine,   imap-mailbox-unselect,    imap-mailbox-expunge
  50 ;; imap-mailbox-close,     imap-mailbox-create,      imap-mailbox-delete
  51 ;; imap-mailbox-rename,    imap-mailbox-lsub,        imap-mailbox-list
  52 ;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status
  53 ;; imap-mailbox-acl-get,   imap-mailbox-acl-set,     imap-mailbox-acl-delete
  54 ;;
  55 ;; Message commands:
  56 ;;
  57 ;; imap-fetch-asynch,                 imap-fetch,
  58 ;; imap-current-message,              imap-list-to-message-set,
  59 ;; imap-message-get,                  imap-message-map
  60 ;; imap-message-envelope-date,        imap-message-envelope-subject,
  61 ;; imap-message-envelope-from,        imap-message-envelope-sender,
  62 ;; imap-message-envelope-reply-to,    imap-message-envelope-to,
  63 ;; imap-message-envelope-cc,          imap-message-envelope-bcc
  64 ;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id
  65 ;; imap-message-body,                 imap-message-flag-permanent-p
  66 ;; imap-message-flags-set,            imap-message-flags-del
  67 ;; imap-message-flags-add,            imap-message-copyuid
  68 ;; imap-message-copy,                 imap-message-appenduid
  69 ;; imap-message-append,               imap-envelope-from
  70 ;; imap-body-lines
  71 ;;
  72 ;; It is my hope that these commands should be pretty self
  73 ;; explanatory for someone that know IMAP.  All functions have
  74 ;; additional documentation on how to invoke them.
  75 ;;
  76 ;; imap.el support RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1), implemented
  77 ;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
  78 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
  79 ;; LOGINDISABLED) (with use of external library starttls.el and
  80 ;; program starttls), and the GSSAPI / kerberos V4 sections of RFC1731
  81 ;; (with use of external program `imtest'), RFC2971 (ID).  It also
  82 ;; take advantage the UNSELECT extension in Cyrus IMAPD.
  83 ;;
  84 ;; Without the work of John McClary Prevost and Jim Radford this library
  85 ;; would not have seen the light of day.  Many thanks.
  86 ;;
  87 ;; This is a transcript of short interactive session for demonstration
  88 ;; purposes.
  89 ;;
  90 ;; (imap-open "my.mail.server")
  91 ;; => " *imap* my.mail.server:0"
  92 ;;
  93 ;; The rest are invoked with current buffer as the buffer returned by
  94 ;; `imap-open'.  It is possible to do all without this, but it would
  95 ;; look ugly here since `buffer' is always the last argument for all
  96 ;; imap.el API functions.
  97 ;;
  98 ;; (imap-authenticate "myusername" "mypassword")
  99 ;; => auth
 100 ;;
 101 ;; (imap-mailbox-lsub "*")
 102 ;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam")
 103 ;;
 104 ;; (imap-mailbox-list "INBOX.n%")
 105 ;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq")
 106 ;;
 107 ;; (imap-mailbox-select "INBOX.nnimap")
 108 ;; => "INBOX.nnimap"
 109 ;;
 110 ;; (imap-mailbox-get 'exists)
 111 ;; => 166
 112 ;;
 113 ;; (imap-mailbox-get 'uidvalidity)
 114 ;; => "908992622"
 115 ;;
 116 ;; (imap-search "FLAGGED SINCE 18-DEC-98")
 117 ;; => (235 236)
 118 ;;
 119 ;; (imap-fetch 235 "RFC822.PEEK" 'RFC822)
 120 ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...."
 121 ;;
 122 ;; Todo:
 123 ;;
 124 ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow.
 125 ;; o Don't use `read' at all (important places already fixed)
 126 ;; o Accept list of articles instead of message set string in most
 127 ;;   imap-message-* functions.
 128 ;; o Send strings as literal if they contain, e.g., ".
 129 ;;
 130 ;; Revision history:
 131 ;;
 132 ;;  - 19991218 added starttls/digest-md5 patch,
 133 ;;             by Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
 134 ;;             NB! you need SLIM for starttls.el and digest-md5.el
 135 ;;  - 19991023 commited to pgnus
 136 ;;
 137
 138 ;;; Code:
 139
 140 (eval-when-compile (require 'cl))
 141 (eval-and-compile
 142   (autoload 'starttls-open-stream "starttls")
 143   (autoload 'starttls-negotiate "starttls")
 144   (autoload 'sasl-find-mechanism "sasl")
 145   (autoload 'digest-md5-parse-digest-challenge "digest-md5")
 146   (autoload 'digest-md5-digest-response "digest-md5")
 147   (autoload 'digest-md5-digest-uri "digest-md5")
 148   (autoload 'digest-md5-challenge "digest-md5")
 149   (autoload 'rfc2104-hash "rfc2104")
 150   (autoload 'utf7-encode "utf7")
 151   (autoload 'utf7-decode "utf7")
 152   (autoload 'format-spec "format-spec")
 153   (autoload 'format-spec-make "format-spec")
 154   (autoload 'open-tls-stream "tls"))
 155
 156 ;; User variables.
 157
 158 (defgroup imap nil
 159   "Low-level IMAP issues."
 160   :version "21.1"
 161   :group 'mail)
 162
 163 (defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
 164                                     "imtest -kp %s %p")
 165   "List of strings containing commands for Kerberos 4 authentication.
 166 %s is replaced with server hostname, %p with port to connect to, and
 167 %l with the value of `imap-default-user'.  The program should accept
 168 IMAP commands on stdin and return responses to stdout.  Each entry in
 169 the list is tried until a successful connection is made."
 170   :group 'imap
 171   :type '(repeat string))
 172
 173 (defcustom imap-gssapi-program (list
 174                                 (concat "gsasl --client --connect %s:%p "
 175                                         "--imap --application-data "
 176                                         "--mechanism GSSAPI "
 177                                         "--authentication-id %l")
 178                                 "imtest -m gssapi -u %l -p %p %s")
 179   "List of strings containing commands for GSSAPI (krb5) authentication.
 180 %s is replaced with server hostname, %p with port to connect to, and
 181 %l with the value of `imap-default-user'.  The program should accept
 182 IMAP commands on stdin and return responses to stdout.  Each entry in
 183 the list is tried until a successful connection is made."
 184   :group 'imap
 185   :type '(repeat string))
 186
 187 (defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p"
 188                               "openssl s_client -quiet -ssl2 -connect %s:%p"
 189                               "s_client -quiet -ssl3 -connect %s:%p"
 190                               "s_client -quiet -ssl2 -connect %s:%p")
 191   "A string, or list of strings, containing commands for SSL connections.
 192 Within a string, %s is replaced with the server address and %p with
 193 port number on server.  The program should accept IMAP commands on
 194 stdin and return responses to stdout.  Each entry in the list is tried
 195 until a successful connection is made."
 196   :group 'imap
 197   :type '(choice string
 198                  (repeat string)))
 199
 200 (defcustom imap-shell-program '("ssh %s imapd"
 201                                 "rsh %s imapd"
 202                                 "ssh %g ssh %s imapd"
 203                                 "rsh %g rsh %s imapd")
 204   "A list of strings, containing commands for IMAP connection.
 205 Within a string, %s is replaced with the server address, %p with port
 206 number on server, %g with `imap-shell-host', and %l with
 207 `imap-default-user'.  The program should read IMAP commands from stdin
 208 and write IMAP response to stdout. Each entry in the list is tried
 209 until a successful connection is made."
 210   :group 'imap
 211   :type '(repeat string))
 212
 213 (defcustom imap-process-connection-type nil
 214   "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL.
 215 The `process-connection-type' variable control type of device
 216 used to communicate with subprocesses.  Values are nil to use a
 217 pipe, or t or `pty' to use a pty.  The value has no effect if the
 218 system has no ptys or if all ptys are busy: then a pipe is used
 219 in any case.  The value takes effect when a IMAP server is
 220 opened, changing it after that has no effect."
 221   :version "22.1"
 222   :group 'imap
 223   :type 'boolean)
 224
 225 (defcustom imap-use-utf7 t
 226   "If non-nil, do utf7 encoding/decoding of mailbox names.
 227 Since the UTF7 decoding currently only decodes into ISO-8859-1
 228 characters, you may disable this decoding if you need to access UTF7
 229 encoded mailboxes which doesn't translate into ISO-8859-1."
 230   :group 'imap
 231   :type 'boolean)
 232
 233 (defcustom imap-log nil
 234   "If non-nil, a imap session trace is placed in *imap-log* buffer.
 235 Note that username, passwords and other privacy sensitive
 236 information (such as e-mail) may be stored in the *imap-log*
 237 buffer.  It is not written to disk, however.  Do not enable this
 238 variable unless you are comfortable with that."
 239   :group 'imap
 240   :type 'boolean)
 241
 242 (defcustom imap-debug nil
 243   "If non-nil, random debug spews are placed in *imap-debug* buffer.
 244 Note that username, passwords and other privacy sensitive
 245 information (such as e-mail) may be stored in the *imap-debug*
 246 buffer.  It is not written to disk, however.  Do not enable this
 247 variable unless you are comfortable with that."
 248   :group 'imap
 249   :type 'boolean)
 250
 251 (defcustom imap-shell-host "gateway"
 252   "Hostname of rlogin proxy."
 253   :group 'imap
 254   :type 'string)
 255
 256 (defcustom imap-default-user (user-login-name)
 257   "Default username to use."
 258   :group 'imap
 259   :type 'string)
 260
 261 (defcustom imap-read-timeout (if (string-match
 262                                   "windows-nt\\|os/2\\|emx\\|cygwin"
 263                                   (symbol-name system-type))
 264                                  1.0
 265                                0.1)
 266   "*How long to wait between checking for the end of output.
 267 Shorter values mean quicker response, but is more CPU intensive."
 268   :type 'number
 269   :group 'imap)
 270
 271 (defcustom imap-store-password nil
 272   "If non-nil, store session password without promting."
 273   :group 'imap
 274   :type 'boolean)
 275
 276 ;; Various variables.
 277
 278 (defvar imap-fetch-data-hook nil
 279   "Hooks called after receiving each FETCH response.")
 280
 281 (defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell)
 282   "Priority of streams to consider when opening connection to server.")
 283
 284 (defvar imap-stream-alist
 285   '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
 286     (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
 287     (tls       imap-tls-p              imap-tls-open)
 288     (ssl       imap-ssl-p              imap-ssl-open)
 289     (network   imap-network-p          imap-network-open)
 290     (shell     imap-shell-p            imap-shell-open)
 291     (starttls  imap-starttls-p         imap-starttls-open))
 292   "Definition of network streams.
 293
 294 \(NAME CHECK OPEN)
 295
 296 NAME names the stream, CHECK is a function returning non-nil if the
 297 server support the stream and OPEN is a function for opening the
 298 stream.")
 299
 300 (defvar imap-authenticators '(gssapi
 301                               kerberos4
 302                               digest-md5
 303                               cram-md5
 304                               ;;sasl
 305                               login
 306                               anonymous)
 307   "Priority of authenticators to consider when authenticating to server.")
 308
 309 (defvar imap-authenticator-alist
 310   '((gssapi     imap-gssapi-auth-p    imap-gssapi-auth)
 311     (kerberos4  imap-kerberos4-auth-p imap-kerberos4-auth)
 312     (sasl       imap-sasl-auth-p      imap-sasl-auth)
 313     (cram-md5   imap-cram-md5-p       imap-cram-md5-auth)
 314     (login      imap-login-p          imap-login-auth)
 315     (anonymous  imap-anonymous-p      imap-anonymous-auth)
 316     (digest-md5 imap-digest-md5-p     imap-digest-md5-auth))
 317   "Definition of authenticators.
 318
 319 \(NAME CHECK AUTHENTICATE)
 320
 321 NAME names the authenticator.  CHECK is a function returning non-nil if
 322 the server support the authenticator and AUTHENTICATE is a function
 323 for doing the actual authentication.")
 324
 325 (defvar imap-error nil
 326   "Error codes from the last command.")
 327
 328 ;; Internal constants.  Change these and die.
 329
 330 (defconst imap-default-port 143)
 331 (defconst imap-default-ssl-port 993)
 332 (defconst imap-default-tls-port 993)
 333 (defconst imap-default-stream 'network)
 334 (defconst imap-coding-system-for-read 'binary)
 335 (defconst imap-coding-system-for-write 'binary)
 336 (defconst imap-local-variables '(imap-server
 337                                  imap-port
 338                                  imap-client-eol
 339                                  imap-server-eol
 340                                  imap-auth
 341                                  imap-stream
 342                                  imap-username
 343                                  imap-password
 344                                  imap-current-mailbox
 345                                  imap-current-target-mailbox
 346                                  imap-message-data
 347                                  imap-capability
 348                                  imap-id
 349                                  imap-namespace
 350                                  imap-state
 351                                  imap-reached-tag
 352                                  imap-failed-tags
 353                                  imap-tag
 354                                  imap-process
 355                                  imap-calculate-literal-size-first
 356                                  imap-mailbox-data))
 357 (defconst imap-log-buffer "*imap-log*")
 358 (defconst imap-debug-buffer "*imap-debug*")
 359
 360 ;; Internal variables.
 361
 362 (defvar imap-stream nil)
 363 (defvar imap-auth nil)
 364 (defvar imap-server nil)
 365 (defvar imap-port nil)
 366 (defvar imap-username nil)
 367 (defvar imap-password nil)
 368 (defvar imap-calculate-literal-size-first nil)
 369 (defvar imap-state 'closed
 370   "IMAP state.
 371 Valid states are `closed', `initial', `nonauth', `auth', `selected'
 372 and `examine'.")
 373
 374 (defvar imap-server-eol "\r\n"
 375   "The EOL string sent from the server.")
 376
 377 (defvar imap-client-eol "\r\n"
 378   "The EOL string we send to the server.")
 379
 380 (defvar imap-current-mailbox nil
 381   "Current mailbox name.")
 382
 383 (defvar imap-current-target-mailbox nil
 384   "Current target mailbox for COPY and APPEND commands.")
 385
 386 (defvar imap-mailbox-data nil
 387   "Obarray with mailbox data.")
 388
 389 (defvar imap-mailbox-prime 997
 390   "Length of imap-mailbox-data.")
 391
 392 (defvar imap-current-message nil
 393   "Current message number.")
 394
 395 (defvar imap-message-data nil
 396   "Obarray with message data.")
 397
 398 (defvar imap-message-prime 997
 399   "Length of imap-message-data.")
 400
 401 (defvar imap-capability nil
 402   "Capability for server.")
 403
 404 (defvar imap-id nil
 405   "Identity of server.
 406 See RFC 2971.")
 407
 408 (defvar imap-namespace nil
 409   "Namespace for current server.")
 410
 411 (defvar imap-reached-tag 0
 412   "Lower limit on command tags that have been parsed.")
 413
 414 (defvar imap-failed-tags nil
 415   "Alist of tags that failed.
 416 Each element is a list with four elements; tag (a integer), response
 417 state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
 418 human readable response text (a string).")
 419
 420 (defvar imap-tag 0
 421   "Command tag number.")
 422
 423 (defvar imap-process nil
 424   "Process.")
 425
 426 (defvar imap-continuation nil
 427   "Non-nil indicates that the server emitted a continuation request.
 428 The actual value is really the text on the continuation line.")
 429
 430 (defvar imap-callbacks nil
 431   "List of response tags and callbacks, on the form `(number . function)'.
 432 The function should take two arguments, the first the IMAP tag and the
 433 second the status (OK, NO, BAD etc) of the command.")
 434
 435 \f
 436 ;; Utility functions:
 437
 438 (defun imap-remassoc (key alist)
 439   "Delete by side effect any elements of LIST whose car is `equal' to KEY.
 440 The modified LIST is returned.  If the first member
 441 of LIST has a car that is `equal' to KEY, there is no way to remove it
 442 by side effect; therefore, write `(setq foo (remassoc key foo))' to be
 443 sure of changing the value of `foo'."
 444   (when alist
 445     (if (equal key (caar alist))
 446         (cdr alist)
 447       (setcdr alist (imap-remassoc key (cdr alist)))
 448       alist)))
 449
 450 (defsubst imap-disable-multibyte ()
 451   "Enable multibyte in the current buffer."
 452   (when (fboundp 'set-buffer-multibyte)
 453     (set-buffer-multibyte nil)))
 454
 455 (defsubst imap-utf7-encode (string)
 456   (if imap-use-utf7
 457       (and string
 458            (condition-case ()
 459                (utf7-encode string t)
 460              (error (message
 461                      "imap: Could not UTF7 encode `%s', using it unencoded..."
 462                      string)
 463                     string)))
 464     string))
 465
 466 (defsubst imap-utf7-decode (string)
 467   (if imap-use-utf7
 468       (and string
 469            (condition-case ()
 470                (utf7-decode string t)
 471              (error (message
 472                      "imap: Could not UTF7 decode `%s', using it undecoded..."
 473                      string)
 474                     string)))
 475     string))
 476
 477 (defsubst imap-ok-p (status)
 478   (if (eq status 'OK)
 479       t
 480     (setq imap-error status)
 481     nil))
 482
 483 (defun imap-error-text (&optional buffer)
 484   (with-current-buffer (or buffer (current-buffer))
 485     (nth 3 (car imap-failed-tags))))
 486
 487 \f
 488 ;; Server functions; stream stuff:
 489
 490 (defun imap-kerberos4-stream-p (buffer)
 491   (imap-capability 'AUTH=KERBEROS_V4 buffer))
 492
 493 (defun imap-kerberos4-open (name buffer server port)
 494   (let ((cmds imap-kerberos4-program)
 495         cmd done)
 496     (while (and (not done) (setq cmd (pop cmds)))
 497       (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
 498       (erase-buffer)
 499       (let* ((port (or port imap-default-port))
 500              (coding-system-for-read imap-coding-system-for-read)
 501              (coding-system-for-write imap-coding-system-for-write)
 502              (process-connection-type imap-process-connection-type)
 503              (process (start-process
 504                        name buffer shell-file-name shell-command-switch
 505                        (format-spec
 506                         cmd
 507                         (format-spec-make
 508                          ?s server
 509                          ?p (number-to-string port)
 510                          ?l imap-default-user))))
 511              response)
 512         (when process
 513           (with-current-buffer buffer
 514             (setq imap-client-eol "\n"
 515                   imap-calculate-literal-size-first t)
 516             (while (and (memq (process-status process) '(open run))
 517                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 518                         (goto-char (point-min))
 519                         ;; Athena IMTEST can output SSL verify errors
 520                         (or (while (looking-at "^verify error:num=")
 521                               (forward-line))
 522                             t)
 523                         (or (while (looking-at "^TLS connection established")
 524                               (forward-line))
 525                             t)
 526                         ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 527                         (or (while (looking-at "^C:")
 528                               (forward-line))
 529                             t)
 530                         ;; cyrus 1.6 imtest print "S: " before server greeting
 531                         (or (not (looking-at "S: "))
 532                             (forward-char 3)
 533                             t)
 534                         (not (and (imap-parse-greeting)
 535                                   ;; success in imtest < 1.6:
 536                                   (or (re-search-forward
 537                                        "^__\\(.*\\)__\n" nil t)
 538                                       ;; success in imtest 1.6:
 539                                       (re-search-forward
 540                                        "^\\(Authenticat.*\\)" nil t))
 541                                   (setq response (match-string 1)))))
 542               (accept-process-output process 1)
 543               (sit-for 1))
 544             (and imap-log
 545                  (with-current-buffer (get-buffer-create imap-log-buffer)
 546                    (imap-disable-multibyte)
 547                    (buffer-disable-undo)
 548                    (goto-char (point-max))
 549                    (insert-buffer-substring buffer)))
 550             (erase-buffer)
 551             (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
 552                      (if response (concat "done, " response) "failed"))
 553             (if (and response (let ((case-fold-search nil))
 554                                 (not (string-match "failed" response))))
 555                 (setq done process)
 556               (if (memq (process-status process) '(open run))
 557                   (imap-send-command "LOGOUT"))
 558               (delete-process process)
 559               nil)))))
 560     done))
 561
 562 (defun imap-gssapi-stream-p (buffer)
 563   (imap-capability 'AUTH=GSSAPI buffer))
 564
 565 (defun imap-gssapi-open (name buffer server port)
 566   (let ((cmds imap-gssapi-program)
 567         cmd done)
 568     (while (and (not done) (setq cmd (pop cmds)))
 569       (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
 570       (erase-buffer)
 571       (let* ((port (or port imap-default-port))
 572              (coding-system-for-read imap-coding-system-for-read)
 573              (coding-system-for-write imap-coding-system-for-write)
 574              (process-connection-type imap-process-connection-type)
 575              (process (start-process
 576                        name buffer shell-file-name shell-command-switch
 577                        (format-spec
 578                         cmd
 579                         (format-spec-make
 580                          ?s server
 581                          ?p (number-to-string port)
 582                          ?l imap-default-user))))
 583              response)
 584         (when process
 585           (with-current-buffer buffer
 586             (setq imap-client-eol "\n"
 587                   imap-calculate-literal-size-first t)
 588             (while (and (memq (process-status process) '(open run))
 589                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 590                         (goto-char (point-min))
 591                         ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
 592                         (or (while (looking-at "^C:")
 593                               (forward-line))
 594                             t)
 595                         ;; cyrus 1.6 imtest print "S: " before server greeting
 596                         (or (not (looking-at "S: "))
 597                             (forward-char 3)
 598                             t)
 599                         (not (and (imap-parse-greeting)
 600                                   ;; success in imtest 1.6:
 601                                   (re-search-forward
 602                                    (concat "^\\(\\(Authenticat.*\\)\\|\\("
 603                                            "Client authentication "
 604                                            "finished.*\\)\\)")
 605                                    nil t)
 606                                   (setq response (match-string 1)))))
 607               (accept-process-output process 1)
 608               (sit-for 1))
 609             (and imap-log
 610                  (with-current-buffer (get-buffer-create imap-log-buffer)
 611                    (imap-disable-multibyte)
 612                    (buffer-disable-undo)
 613                    (goto-char (point-max))
 614                    (insert-buffer-substring buffer)))
 615             (erase-buffer)
 616             (message "GSSAPI IMAP connection: %s" (or response "failed"))
 617             (if (and response (let ((case-fold-search nil))
 618                                 (not (string-match "failed" response))))
 619                 (setq done process)
 620               (if (memq (process-status process) '(open run))
 621                   (imap-send-command "LOGOUT"))
 622               (delete-process process)
 623               nil)))))
 624     done))
 625
 626 (defun imap-ssl-p (buffer)
 627   nil)
 628
 629 (defun imap-ssl-open (name buffer server port)
 630   "Open a SSL connection to server."
 631   (let ((cmds (if (listp imap-ssl-program) imap-ssl-program
 632                 (list imap-ssl-program)))
 633         cmd done)
 634     (while (and (not done) (setq cmd (pop cmds)))
 635       (message "imap: Opening SSL connection with `%s'..." cmd)
 636       (erase-buffer)
 637       (let* ((port (or port imap-default-ssl-port))
 638              (coding-system-for-read imap-coding-system-for-read)
 639              (coding-system-for-write imap-coding-system-for-write)
 640              (process-connection-type imap-process-connection-type)
 641              process)
 642         (when (progn
 643                 (setq process (start-process
 644                                name buffer shell-file-name
 645                                shell-command-switch
 646                                (format-spec cmd
 647                                             (format-spec-make
 648                                              ?s server
 649                                              ?p (number-to-string port)))))
 650                 (process-kill-without-query process)
 651                 process)
 652           (with-current-buffer buffer
 653             (goto-char (point-min))
 654             (while (and (memq (process-status process) '(open run))
 655                         (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 656                         (goto-char (point-max))
 657                         (forward-line -1)
 658                         (not (imap-parse-greeting)))
 659               (accept-process-output process 1)
 660               (sit-for 1))
 661             (and imap-log
 662                  (with-current-buffer (get-buffer-create imap-log-buffer)
 663                    (imap-disable-multibyte)
 664                    (buffer-disable-undo)
 665                    (goto-char (point-max))
 666                    (insert-buffer-substring buffer)))
 667             (erase-buffer)
 668             (when (memq (process-status process) '(open run))
 669               (setq done process))))))
 670     (if done
 671         (progn
 672           (message "imap: Opening SSL connection with `%s'...done" cmd)
 673           done)
 674       (message "imap: Opening SSL connection with `%s'...failed" cmd)
 675       nil)))
 676
 677 (defun imap-tls-p (buffer)
 678   nil)
 679
 680 (defun imap-tls-open (name buffer server port)
 681   (let* ((port (or port imap-default-tls-port))
 682          (coding-system-for-read imap-coding-system-for-read)
 683          (coding-system-for-write imap-coding-system-for-write)
 684          (process (open-tls-stream name buffer server port)))
 685     (when process
 686       (while (and (memq (process-status process) '(open run))
 687                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 688                   (goto-char (point-max))
 689                   (forward-line -1)
 690                   (not (imap-parse-greeting)))
 691         (accept-process-output process 1)
 692         (sit-for 1))
 693       (and imap-log
 694            (with-current-buffer (get-buffer-create imap-log-buffer)
 695              (imap-disable-multibyte)
 696              (buffer-disable-undo)
 697              (goto-char (point-max))
 698              (insert-buffer-substring buffer)))
 699       (when (memq (process-status process) '(open run))
 700         process))))
 701
 702 (defun imap-network-p (buffer)
 703   t)
 704
 705 (defun imap-network-open (name buffer server port)
 706   (let* ((port (or port imap-default-port))
 707          (coding-system-for-read imap-coding-system-for-read)
 708          (coding-system-for-write imap-coding-system-for-write)
 709          (process (open-network-stream name buffer server port)))
 710     (when process
 711       (while (and (memq (process-status process) '(open run))
 712                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 713                   (goto-char (point-min))
 714                   (not (imap-parse-greeting)))
 715         (accept-process-output process 1)
 716         (sit-for 1))
 717       (and imap-log
 718            (with-current-buffer (get-buffer-create imap-log-buffer)
 719              (imap-disable-multibyte)
 720              (buffer-disable-undo)
 721              (goto-char (point-max))
 722              (insert-buffer-substring buffer)))
 723       (when (memq (process-status process) '(open run))
 724         process))))
 725
 726 (defun imap-shell-p (buffer)
 727   nil)
 728
 729 (defun imap-shell-open (name buffer server port)
 730   (let ((cmds (if (listp imap-shell-program) imap-shell-program
 731                 (list imap-shell-program)))
 732         cmd done)
 733     (while (and (not done) (setq cmd (pop cmds)))
 734       (message "imap: Opening IMAP connection with `%s'..." cmd)
 735       (setq imap-client-eol "\n")
 736       (let* ((port (or port imap-default-port))
 737              (coding-system-for-read imap-coding-system-for-read)
 738              (coding-system-for-write imap-coding-system-for-write)
 739              (process (start-process
 740                        name buffer shell-file-name shell-command-switch
 741                        (format-spec
 742                         cmd
 743                         (format-spec-make
 744                          ?s server
 745                          ?g imap-shell-host
 746                          ?p (number-to-string port)
 747                          ?l imap-default-user)))))
 748         (when process
 749           (while (and (memq (process-status process) '(open run))
 750                       (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 751                       (goto-char (point-max))
 752                       (forward-line -1)
 753                       (not (imap-parse-greeting)))
 754             (accept-process-output process 1)
 755             (sit-for 1))
 756           (and imap-log
 757                (with-current-buffer (get-buffer-create imap-log-buffer)
 758                  (imap-disable-multibyte)
 759                  (buffer-disable-undo)
 760                  (goto-char (point-max))
 761                  (insert-buffer-substring buffer)))
 762           (erase-buffer)
 763           (when (memq (process-status process) '(open run))
 764             (setq done process)))))
 765     (if done
 766         (progn
 767           (message "imap: Opening IMAP connection with `%s'...done" cmd)
 768           done)
 769       (message "imap: Opening IMAP connection with `%s'...failed" cmd)
 770       nil)))
 771
 772 (defun imap-starttls-p (buffer)
 773   (imap-capability 'STARTTLS buffer))
 774
 775 (defun imap-starttls-open (name buffer server port)
 776   (let* ((port (or port imap-default-port))
 777          (coding-system-for-read imap-coding-system-for-read)
 778          (coding-system-for-write imap-coding-system-for-write)
 779          (process (starttls-open-stream name buffer server port))
 780          done tls-info)
 781     (message "imap: Connecting with STARTTLS...")
 782     (when process
 783       (while (and (memq (process-status process) '(open run))
 784                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 785                   (goto-char (point-max))
 786                   (forward-line -1)
 787                   (not (imap-parse-greeting)))
 788         (accept-process-output process 1)
 789         (sit-for 1))
 790       (imap-send-command "STARTTLS")
 791       (while (and (memq (process-status process) '(open run))
 792                   (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
 793                   (goto-char (point-max))
 794                   (forward-line -1)
 795                   (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
 796         (accept-process-output process 1)
 797         (sit-for 1))
 798       (and imap-log
 799            (with-current-buffer (get-buffer-create imap-log-buffer)
 800              (buffer-disable-undo)
 801              (goto-char (point-max))
 802              (insert-buffer-substring buffer)))
 803       (when (and (setq tls-info (starttls-negotiate process))
 804                  (memq (process-status process) '(open run)))
 805         (setq done process)))
 806     (if (stringp tls-info)
 807         (message "imap: STARTTLS info: %s" tls-info))
 808     (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
 809     done))
 810
 811 ;; Server functions; authenticator stuff:
 812
 813 (defun imap-interactive-login (buffer loginfunc)
 814   "Login to server in BUFFER.
 815 LOGINFUNC is passed a username and a password, it should return t if
 816 it where successful authenticating itself to the server, nil otherwise.
 817 Returns t if login was successful, nil otherwise."
 818   (with-current-buffer buffer
 819     (make-local-variable 'imap-username)
 820     (make-local-variable 'imap-password)
 821     (let (user passwd ret)
 822       ;;      (condition-case ()
 823       (while (or (not user) (not passwd))
 824         (setq user (or imap-username
 825                        (read-from-minibuffer
 826                         (concat "IMAP username for " imap-server
 827                                 " (using stream `" (symbol-name imap-stream)
 828                                 "'): ")
 829                         (or user imap-default-user))))
 830         (setq passwd (or imap-password
 831                          (read-passwd
 832                           (concat "IMAP password for " user "@"
 833                                   imap-server " (using authenticator `"
 834                                   (symbol-name imap-auth) "'): "))))
 835         (when (and user passwd)
 836           (if (funcall loginfunc user passwd)
 837               (progn
 838                 (setq ret t
 839                       imap-username user)
 840                 (when (and (not imap-password)
 841                            (or imap-store-password
 842                                (y-or-n-p "Store password for this session? ")))
 843                   (setq imap-password passwd)))
 844             (message "Login failed...")
 845             (setq passwd nil)
 846             (setq imap-password nil)
 847             (sit-for 1))))
 848       ;;        (quit (with-current-buffer buffer
 849       ;;                (setq user nil
 850       ;;                      passwd nil)))
 851       ;;        (error (with-current-buffer buffer
 852       ;;                 (setq user nil
 853       ;;                       passwd nil))))
 854       ret)))
 855
 856 (defun imap-gssapi-auth-p (buffer)
 857   (eq imap-stream 'gssapi))
 858
 859 (defun imap-gssapi-auth (buffer)
 860   (message "imap: Authenticating using GSSAPI...%s"
 861            (if (eq imap-stream 'gssapi) "done" "failed"))
 862   (eq imap-stream 'gssapi))
 863
 864 (defun imap-kerberos4-auth-p (buffer)
 865   (and (imap-capability 'AUTH=KERBEROS_V4 buffer)
 866        (eq imap-stream 'kerberos4)))
 867
 868 (defun imap-kerberos4-auth (buffer)
 869   (message "imap: Authenticating using Kerberos 4...%s"
 870            (if (eq imap-stream 'kerberos4) "done" "failed"))
 871   (eq imap-stream 'kerberos4))
 872
 873 (defun imap-cram-md5-p (buffer)
 874   (imap-capability 'AUTH=CRAM-MD5 buffer))
 875
 876 (defun imap-cram-md5-auth (buffer)
 877   "Login to server using the AUTH CRAM-MD5 method."
 878   (message "imap: Authenticating using CRAM-MD5...")
 879   (let ((done (imap-interactive-login
 880                buffer
 881                (lambda (user passwd)
 882                  (imap-ok-p
 883                   (imap-send-command-wait
 884                    (list
 885                     "AUTHENTICATE CRAM-MD5"
 886                     (lambda (challenge)
 887                       (let* ((decoded (base64-decode-string challenge))
 888                              (hash (rfc2104-hash 'md5 64 16 passwd decoded))
 889                              (response (concat user " " hash))
 890                              (encoded (base64-encode-string response)))
 891                         encoded)))))))))
 892     (if done
 893         (message "imap: Authenticating using CRAM-MD5...done")
 894       (message "imap: Authenticating using CRAM-MD5...failed"))))
 895
 896 (defun imap-login-p (buffer)
 897   (and (not (imap-capability 'LOGINDISABLED buffer))
 898        (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
 899
 900 (defun imap-login-auth (buffer)
 901   "Login to server using the LOGIN command."
 902   (message "imap: Plaintext authentication...")
 903   (imap-interactive-login buffer
 904                           (lambda (user passwd)
 905                             (imap-ok-p (imap-send-command-wait
 906                                         (concat "LOGIN \"" user "\" \""
 907                                                 passwd "\""))))))
 908
 909 (defun imap-anonymous-p (buffer)
 910   t)
 911
 912 (defun imap-anonymous-auth (buffer)
 913   (message "imap: Logging in anonymously...")
 914   (with-current-buffer buffer
 915     (imap-ok-p (imap-send-command-wait
 916                 (concat "LOGIN anonymous \"" (concat (user-login-name) "@"
 917                                                      (system-name)) "\"")))))
 918
 919 ;;; Compiler directives.
 920
 921 (defvar imap-sasl-client)
 922 (defvar imap-sasl-step)
 923
 924 (defun imap-sasl-make-mechanisms (buffer)
 925   (let ((mecs '()))
 926     (mapc (lambda (sym)
 927             (let ((name (symbol-name sym)))
 928               (if (and (> (length name) 5)
 929                        (string-equal "AUTH=" (substring name 0 5 )))
 930                   (setq mecs (cons (substring name 5) mecs)))))
 931           (imap-capability nil buffer))
 932     mecs))
 933
 934 (defun imap-sasl-auth-p (buffer)
 935   (and (condition-case ()
 936            (require 'sasl)
 937          (error nil))
 938        (sasl-find-mechanism (imap-sasl-make-mechanisms buffer))))
 939
 940 (defun imap-sasl-auth (buffer)
 941   "Login to server using the SASL method."
 942   (message "imap: Authenticating using SASL...")
 943   (with-current-buffer buffer
 944     (make-local-variable 'imap-username)
 945     (make-local-variable 'imap-sasl-client)
 946     (make-local-variable 'imap-sasl-step)
 947     (let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))
 948           logged user)
 949       (while (not logged)
 950         (setq user (or imap-username
 951                        (read-from-minibuffer
 952                         (concat "IMAP username for " imap-server " using SASL "
 953                                 (sasl-mechanism-name mechanism) ": ")
 954                         (or user imap-default-user))))
 955         (when user
 956           (setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server)
 957                 imap-sasl-step (sasl-next-step imap-sasl-client nil))
 958           (let ((tag (imap-send-command
 959                       (if (sasl-step-data imap-sasl-step)
 960                           (format "AUTHENTICATE %s %s"
 961                                   (sasl-mechanism-name mechanism)
 962                                   (sasl-step-data imap-sasl-step))
 963                         (format "AUTHENTICATE %s" (sasl-mechanism-name mechanism)))
 964                       buffer)))
 965             (while (eq (imap-wait-for-tag tag) 'INCOMPLETE)
 966               (sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation))
 967               (setq imap-continuation nil
 968                     imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step))
 969               (imap-send-command-1 (if (sasl-step-data imap-sasl-step)
 970                                        (base64-encode-string (sasl-step-data imap-sasl-step) t)
 971                                      "")))
 972             (if (imap-ok-p (imap-wait-for-tag tag))
 973                 (setq imap-username user
 974                       logged t)
 975               (message "Login failed...")
 976               (sit-for 1)))))
 977       logged)))
 978
 979 (defun imap-digest-md5-p (buffer)
 980   (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
 981        (condition-case ()
 982            (require 'digest-md5)
 983          (error nil))))
 984
 985 (defun imap-digest-md5-auth (buffer)
 986   "Login to server using the AUTH DIGEST-MD5 method."
 987   (message "imap: Authenticating using DIGEST-MD5...")
 988   (imap-interactive-login
 989    buffer
 990    (lambda (user passwd)
 991      (let ((tag
 992             (imap-send-command
 993              (list
 994               "AUTHENTICATE DIGEST-MD5"
 995               (lambda (challenge)
 996                 (digest-md5-parse-digest-challenge
 997                  (base64-decode-string challenge))
 998                 (let* ((digest-uri
 999                         (digest-md5-digest-uri
1000                          "imap" (digest-md5-challenge 'realm)))
1001                        (response
1002                         (digest-md5-digest-response
1003                          user passwd digest-uri)))
1004                   (base64-encode-string response 'no-line-break))))
1005              )))
1006        (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1007            nil
1008          (setq imap-continuation nil)
1009          (imap-send-command-1 "")
1010          (imap-ok-p (imap-wait-for-tag tag)))))))
1011
1012 ;; Server functions:
1013
1014 (defun imap-open-1 (buffer)
1015   (with-current-buffer buffer
1016     (erase-buffer)
1017     (setq imap-current-mailbox nil
1018           imap-current-message nil
1019           imap-state 'initial
1020           imap-process (condition-case ()
1021                            (funcall (nth 2 (assq imap-stream
1022                                                  imap-stream-alist))
1023                                     "imap" buffer imap-server imap-port)
1024                          ((error quit) nil)))
1025     (when imap-process
1026       (set-process-filter imap-process 'imap-arrival-filter)
1027       (set-process-sentinel imap-process 'imap-sentinel)
1028       (while (and (eq imap-state 'initial)
1029                   (memq (process-status imap-process) '(open run)))
1030         (message "Waiting for response from %s..." imap-server)
1031         (accept-process-output imap-process 1))
1032       (message "Waiting for response from %s...done" imap-server)
1033       (and (memq (process-status imap-process) '(open run))
1034            imap-process))))
1035
1036 (defun imap-open (server &optional port stream auth buffer)
1037   "Open a IMAP connection to host SERVER at PORT returning a buffer.
1038 If PORT is unspecified, a default value is used (143 except
1039 for SSL which use 993).
1040 STREAM indicates the stream to use, see `imap-streams' for available
1041 streams.  If nil, it choices the best stream the server is capable of.
1042 AUTH indicates authenticator to use, see `imap-authenticators' for
1043 available authenticators.  If nil, it choices the best stream the
1044 server is capable of.
1045 BUFFER can be a buffer or a name of a buffer, which is created if
1046 necessary.  If nil, the buffer name is generated."
1047   (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0))))
1048   (with-current-buffer (get-buffer-create buffer)
1049     (if (imap-opened buffer)
1050         (imap-close buffer))
1051     (mapcar 'make-local-variable imap-local-variables)
1052     (imap-disable-multibyte)
1053     (buffer-disable-undo)
1054     (setq imap-server (or server imap-server))
1055     (setq imap-port (or port imap-port))
1056     (setq imap-auth (or auth imap-auth))
1057     (setq imap-stream (or stream imap-stream))
1058     (message "imap: Connecting to %s..." imap-server)
1059     (if (null (let ((imap-stream (or imap-stream imap-default-stream)))
1060                 (imap-open-1 buffer)))
1061         (progn
1062           (message "imap: Connecting to %s...failed" imap-server)
1063           nil)
1064       (when (null imap-stream)
1065         ;; Need to choose stream.
1066         (let ((streams imap-streams))
1067           (while (setq stream (pop streams))
1068             ;; OK to use this stream?
1069             (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
1070               ;; Stream changed?
1071               (if (not (eq imap-default-stream stream))
1072                   (with-current-buffer (get-buffer-create
1073                                         (generate-new-buffer-name " *temp*"))
1074                     (mapcar 'make-local-variable imap-local-variables)
1075                     (imap-disable-multibyte)
1076                     (buffer-disable-undo)
1077                     (setq imap-server (or server imap-server))
1078                     (setq imap-port (or port imap-port))
1079                     (setq imap-auth (or auth imap-auth))
1080                     (message "imap: Reconnecting with stream `%s'..." stream)
1081                     (if (null (let ((imap-stream stream))
1082                                 (imap-open-1 (current-buffer))))
1083                         (progn
1084                           (kill-buffer (current-buffer))
1085                           (message
1086                            "imap: Reconnecting with stream `%s'...failed"
1087                            stream))
1088                       ;; We're done, kill the first connection
1089                       (imap-close buffer)
1090                       (kill-buffer buffer)
1091                       (rename-buffer buffer)
1092                       (message "imap: Reconnecting with stream `%s'...done"
1093                                stream)
1094                       (setq imap-stream stream)
1095                       (setq imap-capability nil)
1096                       (setq streams nil)))
1097                 ;; We're done
1098                 (message "imap: Connecting to %s...done" imap-server)
1099                 (setq imap-stream stream)
1100                 (setq imap-capability nil)
1101                 (setq streams nil))))))
1102       (when (imap-opened buffer)
1103         (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
1104       (when imap-stream
1105         buffer))))
1106
1107 (defun imap-opened (&optional buffer)
1108   "Return non-nil if connection to imap server in BUFFER is open.
1109 If BUFFER is nil then the current buffer is used."
1110   (and (setq buffer (get-buffer (or buffer (current-buffer))))
1111        (buffer-live-p buffer)
1112        (with-current-buffer buffer
1113          (and imap-process
1114               (memq (process-status imap-process) '(open run))))))
1115
1116 (defun imap-authenticate (&optional user passwd buffer)
1117   "Authenticate to server in BUFFER, using current buffer if nil.
1118 It uses the authenticator specified when opening the server.  If the
1119 authenticator requires username/passwords, they are queried from the
1120 user and optionally stored in the buffer.  If USER and/or PASSWD is
1121 specified, the user will not be questioned and the username and/or
1122 password is remembered in the buffer."
1123   (with-current-buffer (or buffer (current-buffer))
1124     (if (not (eq imap-state 'nonauth))
1125         (or (eq imap-state 'auth)
1126             (eq imap-state 'selected)
1127             (eq imap-state 'examine))
1128       (make-local-variable 'imap-username)
1129       (make-local-variable 'imap-password)
1130       (if user (setq imap-username user))
1131       (if passwd (setq imap-password passwd))
1132       (if imap-auth
1133           (and (funcall (nth 2 (assq imap-auth
1134                                      imap-authenticator-alist)) buffer)
1135                (setq imap-state 'auth))
1136         ;; Choose authenticator.
1137         (let ((auths imap-authenticators)
1138               auth)
1139           (while (setq auth (pop auths))
1140             ;; OK to use authenticator?
1141             (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer)
1142               (message "imap: Authenticating to `%s' using `%s'..."
1143                        imap-server auth)
1144               (setq imap-auth auth)
1145               (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer)
1146                   (progn
1147                     (message "imap: Authenticating to `%s' using `%s'...done"
1148                              imap-server auth)
1149                     (setq auths nil))
1150                 (message "imap: Authenticating to `%s' using `%s'...failed"
1151                          imap-server auth)))))
1152         imap-state))))
1153
1154 (defun imap-close (&optional buffer)
1155   "Close connection to server in BUFFER.
1156 If BUFFER is nil, the current buffer is used."
1157   (with-current-buffer (or buffer (current-buffer))
1158     (when (imap-opened)
1159       (condition-case nil
1160           (imap-send-command-wait "LOGOUT")
1161         (quit nil)))
1162     (when (and imap-process
1163                (memq (process-status imap-process) '(open run)))
1164       (delete-process imap-process))
1165     (setq imap-current-mailbox nil
1166           imap-current-message nil
1167           imap-process nil)
1168     (erase-buffer)
1169     t))
1170
1171 (defun imap-capability (&optional identifier buffer)
1172   "Return a list of identifiers which server in BUFFER support.
1173 If IDENTIFIER, return non-nil if it's among the servers capabilities.
1174 If BUFFER is nil, the current buffer is assumed."
1175   (with-current-buffer (or buffer (current-buffer))
1176     (unless imap-capability
1177       (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
1178         (setq imap-capability '(IMAP2))))
1179     (if identifier
1180         (memq (intern (upcase (symbol-name identifier))) imap-capability)
1181       imap-capability)))
1182
1183 (defun imap-id (&optional list-of-values buffer)
1184   "Identify client to server in BUFFER, and return server identity.
1185 LIST-OF-VALUES is nil, or a plist with identifier and value
1186 strings to send to the server to identify the client.
1187
1188 Return a list of identifiers which server in BUFFER support, or
1189 nil if it doesn't support ID or returns no information.
1190
1191 If BUFFER is nil, the current buffer is assumed."
1192   (with-current-buffer (or buffer (current-buffer))
1193     (when (and (imap-capability 'ID)
1194                (imap-ok-p (imap-send-command-wait
1195                            (if (null list-of-values)
1196                                "ID NIL"
1197                              (concat "ID (" (mapconcat (lambda (el)
1198                                                          (concat "\"" el "\""))
1199                                                        list-of-values
1200                                                        " ") ")")))))
1201       imap-id)))
1202
1203 (defun imap-namespace (&optional buffer)
1204   "Return a namespace hierarchy at server in BUFFER.
1205 If BUFFER is nil, the current buffer is assumed."
1206   (with-current-buffer (or buffer (current-buffer))
1207     (unless imap-namespace
1208       (when (imap-capability 'NAMESPACE)
1209         (imap-send-command-wait "NAMESPACE")))
1210     imap-namespace))
1211
1212 (defun imap-send-command-wait (command &optional buffer)
1213   (imap-wait-for-tag (imap-send-command command buffer) buffer))
1214
1215 \f
1216 ;; Mailbox functions:
1217
1218 (defun imap-mailbox-put (propname value &optional mailbox buffer)
1219   (with-current-buffer (or buffer (current-buffer))
1220     (if imap-mailbox-data
1221         (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
1222              propname value)
1223       (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
1224              propname value mailbox (current-buffer)))
1225     t))
1226
1227 (defsubst imap-mailbox-get-1 (propname &optional mailbox)
1228   (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
1229        propname))
1230
1231 (defun imap-mailbox-get (propname &optional mailbox buffer)
1232   (let ((mailbox (imap-utf7-encode mailbox)))
1233     (with-current-buffer (or buffer (current-buffer))
1234       (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
1235
1236 (defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
1237   (with-current-buffer (or buffer (current-buffer))
1238     (let (result)
1239       (mapatoms
1240        (lambda (s)
1241          (push (funcall func (if mailbox-decoder
1242                                  (funcall mailbox-decoder (symbol-name s))
1243                                (symbol-name s))) result))
1244        imap-mailbox-data)
1245       result)))
1246
1247 (defun imap-mailbox-map (func &optional buffer)
1248   "Map a function across each mailbox in `imap-mailbox-data', returning a list.
1249 Function should take a mailbox name (a string) as
1250 the only argument."
1251   (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
1252
1253 (defun imap-current-mailbox (&optional buffer)
1254   (with-current-buffer (or buffer (current-buffer))
1255     (imap-utf7-decode imap-current-mailbox)))
1256
1257 (defun imap-current-mailbox-p-1 (mailbox &optional examine)
1258   (and (string= mailbox imap-current-mailbox)
1259        (or (and examine
1260                 (eq imap-state 'examine))
1261            (and (not examine)
1262                 (eq imap-state 'selected)))))
1263
1264 (defun imap-current-mailbox-p (mailbox &optional examine buffer)
1265   (with-current-buffer (or buffer (current-buffer))
1266     (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine)))
1267
1268 (defun imap-mailbox-select-1 (mailbox &optional examine)
1269   "Select MAILBOX on server in BUFFER.
1270 If EXAMINE is non-nil, do a read-only select."
1271   (if (imap-current-mailbox-p-1 mailbox examine)
1272       imap-current-mailbox
1273     (setq imap-current-mailbox mailbox)
1274     (if (imap-ok-p (imap-send-command-wait
1275                     (concat (if examine "EXAMINE" "SELECT") " \""
1276                             mailbox "\"")))
1277         (progn
1278           (setq imap-message-data (make-vector imap-message-prime 0)
1279                 imap-state (if examine 'examine 'selected))
1280           imap-current-mailbox)
1281       ;; Failed SELECT/EXAMINE unselects current mailbox
1282       (setq imap-current-mailbox nil))))
1283
1284 (defun imap-mailbox-select (mailbox &optional examine buffer)
1285   (with-current-buffer (or buffer (current-buffer))
1286     (imap-utf7-decode
1287      (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
1288
1289 (defun imap-mailbox-examine-1 (mailbox &optional buffer)
1290   (with-current-buffer (or buffer (current-buffer))
1291     (imap-mailbox-select-1 mailbox 'examine)))
1292
1293 (defun imap-mailbox-examine (mailbox &optional buffer)
1294   "Examine MAILBOX on server in BUFFER."
1295   (imap-mailbox-select mailbox 'examine buffer))
1296
1297 (defun imap-mailbox-unselect (&optional buffer)
1298   "Close current folder in BUFFER, without expunging articles."
1299   (with-current-buffer (or buffer (current-buffer))
1300     (when (or (eq imap-state 'auth)
1301               (and (imap-capability 'UNSELECT)
1302                    (imap-ok-p (imap-send-command-wait "UNSELECT")))
1303               (and (imap-ok-p
1304                     (imap-send-command-wait (concat "EXAMINE \""
1305                                                     imap-current-mailbox
1306                                                     "\"")))
1307                    (imap-ok-p (imap-send-command-wait "CLOSE"))))
1308       (setq imap-current-mailbox nil
1309             imap-message-data nil
1310             imap-state 'auth)
1311       t)))
1312
1313 (defun imap-mailbox-expunge (&optional asynch buffer)
1314   "Expunge articles in current folder in BUFFER.
1315 If ASYNCH, do not wait for succesful completion of the command.
1316 If BUFFER is nil the current buffer is assumed."
1317   (with-current-buffer (or buffer (current-buffer))
1318     (when (and imap-current-mailbox (not (eq imap-state 'examine)))
1319       (if asynch
1320           (imap-send-command "EXPUNGE")
1321       (imap-ok-p (imap-send-command-wait "EXPUNGE"))))))
1322
1323 (defun imap-mailbox-close (&optional asynch buffer)
1324   "Expunge articles and close current folder in BUFFER.
1325 If ASYNCH, do not wait for succesful completion of the command.
1326 If BUFFER is nil the current buffer is assumed."
1327   (with-current-buffer (or buffer (current-buffer))
1328     (when imap-current-mailbox
1329       (if asynch
1330           (imap-add-callback (imap-send-command "CLOSE")
1331                              `(lambda (tag status)
1332                                 (message "IMAP mailbox `%s' closed... %s"
1333                                          imap-current-mailbox status)
1334                                 (when (eq ,imap-current-mailbox
1335                                           imap-current-mailbox)
1336                                   ;; Don't wipe out data if another mailbox
1337                                   ;; was selected...
1338                                   (setq imap-current-mailbox nil
1339                                         imap-message-data nil
1340                                         imap-state 'auth))))
1341         (when (imap-ok-p (imap-send-command-wait "CLOSE"))
1342           (setq imap-current-mailbox nil
1343                 imap-message-data nil
1344                 imap-state 'auth)))
1345       t)))
1346
1347 (defun imap-mailbox-create-1 (mailbox)
1348   (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\""))))
1349
1350 (defun imap-mailbox-create (mailbox &optional buffer)
1351   "Create MAILBOX on server in BUFFER.
1352 If BUFFER is nil the current buffer is assumed."
1353   (with-current-buffer (or buffer (current-buffer))
1354     (imap-mailbox-create-1 (imap-utf7-encode mailbox))))
1355
1356 (defun imap-mailbox-delete (mailbox &optional buffer)
1357   "Delete MAILBOX on server in BUFFER.
1358 If BUFFER is nil the current buffer is assumed."
1359   (let ((mailbox (imap-utf7-encode mailbox)))
1360     (with-current-buffer (or buffer (current-buffer))
1361       (imap-ok-p
1362        (imap-send-command-wait (list "DELETE \"" mailbox "\""))))))
1363
1364 (defun imap-mailbox-rename (oldname newname &optional buffer)
1365   "Rename mailbox OLDNAME to NEWNAME on server in BUFFER.
1366 If BUFFER is nil the current buffer is assumed."
1367   (let ((oldname (imap-utf7-encode oldname))
1368         (newname (imap-utf7-encode newname)))
1369     (with-current-buffer (or buffer (current-buffer))
1370       (imap-ok-p
1371        (imap-send-command-wait (list "RENAME \"" oldname "\" "
1372                                      "\"" newname "\""))))))
1373
1374 (defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
1375   "Return a list of subscribed mailboxes on server in BUFFER.
1376 If ROOT is non-nil, only list matching mailboxes.  If ADD-DELIMITER is
1377 non-nil, a hierarchy delimiter is added to root.  REFERENCE is a
1378 implementation-specific string that has to be passed to lsub command."
1379   (with-current-buffer (or buffer (current-buffer))
1380     ;; Make sure we know the hierarchy separator for root's hierarchy
1381     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1382       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1383                                       (imap-utf7-encode root) "\"")))
1384     ;; clear list data (NB not delimiter and other stuff)
1385     (imap-mailbox-map-1 (lambda (mailbox)
1386                           (imap-mailbox-put 'lsub nil mailbox)))
1387     (when (imap-ok-p
1388            (imap-send-command-wait
1389             (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root)
1390                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1391                     "%\"")))
1392       (let (out)
1393         (imap-mailbox-map-1 (lambda (mailbox)
1394                               (when (imap-mailbox-get-1 'lsub mailbox)
1395                                 (push (imap-utf7-decode mailbox) out))))
1396         (nreverse out)))))
1397
1398 (defun imap-mailbox-list (root &optional reference add-delimiter buffer)
1399   "Return a list of mailboxes matching ROOT on server in BUFFER.
1400 If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
1401 root.  REFERENCE is a implementation-specific string that has to be
1402 passed to list command."
1403   (with-current-buffer (or buffer (current-buffer))
1404     ;; Make sure we know the hierarchy separator for root's hierarchy
1405     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1406       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1407                                       (imap-utf7-encode root) "\"")))
1408     ;; clear list data (NB not delimiter and other stuff)
1409     (imap-mailbox-map-1 (lambda (mailbox)
1410                           (imap-mailbox-put 'list nil mailbox)))
1411     (when (imap-ok-p
1412            (imap-send-command-wait
1413             (concat "LIST \"" reference "\" \"" (imap-utf7-encode root)
1414                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1415                     "%\"")))
1416       (let (out)
1417         (imap-mailbox-map-1 (lambda (mailbox)
1418                               (when (imap-mailbox-get-1 'list mailbox)
1419                                 (push (imap-utf7-decode mailbox) out))))
1420         (nreverse out)))))
1421
1422 (defun imap-mailbox-subscribe (mailbox &optional buffer)
1423   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1424 Returns non-nil if successful."
1425   (with-current-buffer (or buffer (current-buffer))
1426     (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
1427                                                (imap-utf7-encode mailbox)
1428                                                "\"")))))
1429
1430 (defun imap-mailbox-unsubscribe (mailbox &optional buffer)
1431   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1432 Returns non-nil if successful."
1433   (with-current-buffer (or buffer (current-buffer))
1434     (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
1435                                                (imap-utf7-encode mailbox)
1436                                                "\"")))))
1437
1438 (defun imap-mailbox-status (mailbox items &optional buffer)
1439   "Get status items ITEM in MAILBOX from server in BUFFER.
1440 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1441 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1442 or 'unseen.  If ITEMS is a list of symbols, a list of values is
1443 returned, if ITEMS is a symbol only its value is returned."
1444   (with-current-buffer (or buffer (current-buffer))
1445     (when (imap-ok-p
1446            (imap-send-command-wait (list "STATUS \""
1447                                          (imap-utf7-encode mailbox)
1448                                          "\" "
1449                                          (upcase
1450                                           (format "%s"
1451                                                   (if (listp items)
1452                                                       items
1453                                                     (list items)))))))
1454       (if (listp items)
1455           (mapcar (lambda (item)
1456                     (imap-mailbox-get item mailbox))
1457                   items)
1458         (imap-mailbox-get items mailbox)))))
1459
1460 (defun imap-mailbox-status-asynch (mailbox items &optional buffer)
1461   "Send status item request ITEM on MAILBOX to server in BUFFER.
1462 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1463 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1464 or 'unseen.  The IMAP command tag is returned."
1465   (with-current-buffer (or buffer (current-buffer))
1466     (imap-send-command (list "STATUS \""
1467                              (imap-utf7-encode mailbox)
1468                              "\" "
1469                              (format "%s"
1470                                      (if (listp items)
1471                                          items
1472                                        (list items)))))))
1473
1474 (defun imap-mailbox-acl-get (&optional mailbox buffer)
1475   "Get ACL on mailbox from server in BUFFER."
1476   (let ((mailbox (imap-utf7-encode mailbox)))
1477     (with-current-buffer (or buffer (current-buffer))
1478       (when (imap-ok-p
1479              (imap-send-command-wait (list "GETACL \""
1480                                            (or mailbox imap-current-mailbox)
1481                                            "\"")))
1482         (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox))))))
1483
1484 (defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer)
1485   "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER."
1486   (let ((mailbox (imap-utf7-encode mailbox)))
1487     (with-current-buffer (or buffer (current-buffer))
1488       (imap-ok-p
1489        (imap-send-command-wait (list "SETACL \""
1490                                      (or mailbox imap-current-mailbox)
1491                                      "\" "
1492                                      identifier
1493                                      " "
1494                                      rights))))))
1495
1496 (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
1497   "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER."
1498   (let ((mailbox (imap-utf7-encode mailbox)))
1499     (with-current-buffer (or buffer (current-buffer))
1500       (imap-ok-p
1501        (imap-send-command-wait (list "DELETEACL \""
1502                                      (or mailbox imap-current-mailbox)
1503                                      "\" "
1504                                      identifier))))))
1505
1506 \f
1507 ;; Message functions:
1508
1509 (defun imap-current-message (&optional buffer)
1510   (with-current-buffer (or buffer (current-buffer))
1511     imap-current-message))
1512
1513 (defun imap-list-to-message-set (list)
1514   (mapconcat (lambda (item)
1515                (number-to-string item))
1516              (if (listp list)
1517                  list
1518                (list list))
1519              ","))
1520
1521 (defun imap-range-to-message-set (range)
1522   (mapconcat
1523    (lambda (item)
1524      (if (consp item)
1525          (format "%d:%d"
1526                  (car item) (cdr item))
1527        (format "%d" item)))
1528    (if (and (listp range) (not (listp (cdr range))))
1529        (list range) ;; make (1 . 2) into ((1 . 2))
1530      range)
1531    ","))
1532
1533 (defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
1534   (with-current-buffer (or buffer (current-buffer))
1535     (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1536                                (if (listp uids)
1537                                    (imap-list-to-message-set uids)
1538                                  uids)
1539                                props))))
1540
1541 (defun imap-fetch (uids props &optional receive nouidfetch buffer)
1542   "Fetch properties PROPS from message set UIDS from server in BUFFER.
1543 UIDS can be a string, number or a list of numbers.  If RECEIVE
1544 is non-nil return these properties."
1545   (with-current-buffer (or buffer (current-buffer))
1546     (when (imap-ok-p (imap-send-command-wait
1547                       (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1548                               (if (listp uids)
1549                                   (imap-list-to-message-set uids)
1550                                 uids)
1551                               props)))
1552       (if (or (null receive) (stringp uids))
1553           t
1554         (if (listp uids)
1555             (mapcar (lambda (uid)
1556                       (if (listp receive)
1557                           (mapcar (lambda (prop)
1558                                     (imap-message-get uid prop))
1559                                   receive)
1560                         (imap-message-get uid receive)))
1561                     uids)
1562           (imap-message-get uids receive))))))
1563
1564 (defun imap-message-put (uid propname value &optional buffer)
1565   (with-current-buffer (or buffer (current-buffer))
1566     (if imap-message-data
1567         (put (intern (number-to-string uid) imap-message-data)
1568              propname value)
1569       (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
1570              uid propname value (current-buffer)))
1571     t))
1572
1573 (defun imap-message-get (uid propname &optional buffer)
1574   (with-current-buffer (or buffer (current-buffer))
1575     (get (intern-soft (number-to-string uid) imap-message-data)
1576          propname)))
1577
1578 (defun imap-message-map (func propname &optional buffer)
1579   "Map a function across each mailbox in `imap-message-data', returning a list."
1580   (with-current-buffer (or buffer (current-buffer))
1581     (let (result)
1582       (mapatoms
1583        (lambda (s)
1584          (push (funcall func (get s 'UID) (get s propname)) result))
1585        imap-message-data)
1586       result)))
1587
1588 (defmacro imap-message-envelope-date (uid &optional buffer)
1589   `(with-current-buffer (or ,buffer (current-buffer))
1590      (elt (imap-message-get ,uid 'ENVELOPE) 0)))
1591
1592 (defmacro imap-message-envelope-subject (uid &optional buffer)
1593   `(with-current-buffer (or ,buffer (current-buffer))
1594      (elt (imap-message-get ,uid 'ENVELOPE) 1)))
1595
1596 (defmacro imap-message-envelope-from (uid &optional buffer)
1597   `(with-current-buffer (or ,buffer (current-buffer))
1598      (elt (imap-message-get ,uid 'ENVELOPE) 2)))
1599
1600 (defmacro imap-message-envelope-sender (uid &optional buffer)
1601   `(with-current-buffer (or ,buffer (current-buffer))
1602      (elt (imap-message-get ,uid 'ENVELOPE) 3)))
1603
1604 (defmacro imap-message-envelope-reply-to (uid &optional buffer)
1605   `(with-current-buffer (or ,buffer (current-buffer))
1606      (elt (imap-message-get ,uid 'ENVELOPE) 4)))
1607
1608 (defmacro imap-message-envelope-to (uid &optional buffer)
1609   `(with-current-buffer (or ,buffer (current-buffer))
1610      (elt (imap-message-get ,uid 'ENVELOPE) 5)))
1611
1612 (defmacro imap-message-envelope-cc (uid &optional buffer)
1613   `(with-current-buffer (or ,buffer (current-buffer))
1614      (elt (imap-message-get ,uid 'ENVELOPE) 6)))
1615
1616 (defmacro imap-message-envelope-bcc (uid &optional buffer)
1617   `(with-current-buffer (or ,buffer (current-buffer))
1618      (elt (imap-message-get ,uid 'ENVELOPE) 7)))
1619
1620 (defmacro imap-message-envelope-in-reply-to (uid &optional buffer)
1621   `(with-current-buffer (or ,buffer (current-buffer))
1622      (elt (imap-message-get ,uid 'ENVELOPE) 8)))
1623
1624 (defmacro imap-message-envelope-message-id (uid &optional buffer)
1625   `(with-current-buffer (or ,buffer (current-buffer))
1626      (elt (imap-message-get ,uid 'ENVELOPE) 9)))
1627
1628 (defmacro imap-message-body (uid &optional buffer)
1629   `(with-current-buffer (or ,buffer (current-buffer))
1630      (imap-message-get ,uid 'BODY)))
1631
1632 (defun imap-search (predicate &optional buffer)
1633   (with-current-buffer (or buffer (current-buffer))
1634     (imap-mailbox-put 'search 'dummy)
1635     (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
1636       (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
1637           (progn
1638             (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...")
1639             nil)
1640         (imap-mailbox-get-1 'search imap-current-mailbox)))))
1641
1642 (defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
1643   "Return t iff FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
1644   (with-current-buffer (or buffer (current-buffer))
1645     (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
1646         (member flag (imap-mailbox-get 'permanentflags mailbox)))))
1647
1648 (defun imap-message-flags-set (articles flags &optional silent buffer)
1649   (when (and articles flags)
1650     (with-current-buffer (or buffer (current-buffer))
1651       (imap-ok-p (imap-send-command-wait
1652                   (concat "UID STORE " articles
1653                           " FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1654
1655 (defun imap-message-flags-del (articles flags &optional silent buffer)
1656   (when (and articles flags)
1657     (with-current-buffer (or buffer (current-buffer))
1658       (imap-ok-p (imap-send-command-wait
1659                   (concat "UID STORE " articles
1660                           " -FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1661
1662 (defun imap-message-flags-add (articles flags &optional silent buffer)
1663   (when (and articles flags)
1664     (with-current-buffer (or buffer (current-buffer))
1665       (imap-ok-p (imap-send-command-wait
1666                   (concat "UID STORE " articles
1667                           " +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1668
1669 (defun imap-message-copyuid-1 (mailbox)
1670   (if (imap-capability 'UIDPLUS)
1671       (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
1672             (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
1673     (let ((old-mailbox imap-current-mailbox)
1674           (state imap-state)
1675           (imap-message-data (make-vector 2 0)))
1676       (when (imap-mailbox-examine-1 mailbox)
1677         (prog1
1678             (and (imap-fetch "*" "UID")
1679                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
1680                        (apply 'max (imap-message-map
1681                                     (lambda (uid prop) uid) 'UID))))
1682           (if old-mailbox
1683               (imap-mailbox-select old-mailbox (eq state 'examine))
1684             (imap-mailbox-unselect)))))))
1685
1686 (defun imap-message-copyuid (mailbox &optional buffer)
1687   (with-current-buffer (or buffer (current-buffer))
1688     (imap-message-copyuid-1 (imap-utf7-decode mailbox))))
1689
1690 (defun imap-message-copy (articles mailbox
1691                                    &optional dont-create no-copyuid buffer)
1692   "Copy ARTICLES (a string message set) to MAILBOX on server in
1693 BUFFER, creating mailbox if it doesn't exist.  If dont-create is
1694 non-nil, it will not create a mailbox.  On success, return a list with
1695 the UIDVALIDITY of the mailbox the article(s) was copied to as the
1696 first element, rest of list contain the saved articles' UIDs."
1697   (when articles
1698     (with-current-buffer (or buffer (current-buffer))
1699       (let ((mailbox (imap-utf7-encode mailbox)))
1700         (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\""))
1701                   (imap-current-target-mailbox mailbox))
1702               (if (imap-ok-p (imap-send-command-wait cmd))
1703                   t
1704                 (when (and (not dont-create)
1705                            ;; removed because of buggy Oracle server
1706                            ;; that doesn't send TRYCREATE tags (which
1707                            ;; is a MUST according to specifications):
1708                            ;;(imap-mailbox-get-1 'trycreate mailbox)
1709                            (imap-mailbox-create-1 mailbox))
1710                   (imap-ok-p (imap-send-command-wait cmd)))))
1711             (or no-copyuid
1712                 (imap-message-copyuid-1 mailbox)))))))
1713
1714 (defun imap-message-appenduid-1 (mailbox)
1715   (if (imap-capability 'UIDPLUS)
1716       (imap-mailbox-get-1 'appenduid mailbox)
1717     (let ((old-mailbox imap-current-mailbox)
1718           (state imap-state)
1719           (imap-message-data (make-vector 2 0)))
1720       (when (imap-mailbox-examine-1 mailbox)
1721         (prog1
1722             (and (imap-fetch "*" "UID")
1723                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
1724                        (apply 'max (imap-message-map
1725                                     (lambda (uid prop) uid) 'UID))))
1726           (if old-mailbox
1727               (imap-mailbox-select old-mailbox (eq state 'examine))
1728             (imap-mailbox-unselect)))))))
1729
1730 (defun imap-message-appenduid (mailbox &optional buffer)
1731   (with-current-buffer (or buffer (current-buffer))
1732     (imap-message-appenduid-1 (imap-utf7-encode mailbox))))
1733
1734 (defun imap-message-append (mailbox article &optional flags date-time buffer)
1735   "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER.
1736 FLAGS and DATE-TIME is currently not used.  Return a cons holding
1737 uidvalidity of MAILBOX and UID the newly created article got, or nil
1738 on failure."
1739   (let ((mailbox (imap-utf7-encode mailbox)))
1740     (with-current-buffer (or buffer (current-buffer))
1741       (and (let ((imap-current-target-mailbox mailbox))
1742              (imap-ok-p
1743               (imap-send-command-wait
1744                (list "APPEND \"" mailbox "\" "  article))))
1745            (imap-message-appenduid-1 mailbox)))))
1746
1747 (defun imap-body-lines (body)
1748   "Return number of lines in article by looking at the mime bodystructure BODY."
1749   (if (listp body)
1750       (if (stringp (car body))
1751           (cond ((and (string= (upcase (car body)) "TEXT")
1752                       (numberp (nth 7 body)))
1753                  (nth 7 body))
1754                 ((and (string= (upcase (car body)) "MESSAGE")
1755                       (numberp (nth 9 body)))
1756                  (nth 9 body))
1757                 (t 0))
1758         (apply '+ (mapcar 'imap-body-lines body)))
1759     0))
1760
1761 (defun imap-envelope-from (from)
1762   "Return a from string line."
1763   (and from
1764        (concat (aref from 0)
1765                (if (aref from 0) " <")
1766                (aref from 2)
1767                "@"
1768                (aref from 3)
1769                (if (aref from 0) ">"))))
1770
1771 \f
1772 ;; Internal functions.
1773
1774 (defun imap-add-callback (tag func)
1775   (setq imap-callbacks (append (list (cons tag func)) imap-callbacks)))
1776
1777 (defun imap-send-command-1 (cmdstr)
1778   (setq cmdstr (concat cmdstr imap-client-eol))
1779   (and imap-log
1780        (with-current-buffer (get-buffer-create imap-log-buffer)
1781          (imap-disable-multibyte)
1782          (buffer-disable-undo)
1783          (goto-char (point-max))
1784          (insert cmdstr)))
1785   (process-send-string imap-process cmdstr))
1786
1787 (defun imap-send-command (command &optional buffer)
1788   (with-current-buffer (or buffer (current-buffer))
1789     (if (not (listp command)) (setq command (list command)))
1790     (let ((tag (setq imap-tag (1+ imap-tag)))
1791           cmd cmdstr)
1792       (setq cmdstr (concat (number-to-string imap-tag) " "))
1793       (while (setq cmd (pop command))
1794         (cond ((stringp cmd)
1795                (setq cmdstr (concat cmdstr cmd)))
1796               ((bufferp cmd)
1797                (let ((eol imap-client-eol)
1798                      (calcfirst imap-calculate-literal-size-first)
1799                      size)
1800                  (with-current-buffer cmd
1801                    (if calcfirst
1802                        (setq size (buffer-size)))
1803                    (when (not (equal eol "\r\n"))
1804                      ;; XXX modifies buffer!
1805                      (goto-char (point-min))
1806                      (while (search-forward "\r\n" nil t)
1807                        (replace-match eol)))
1808                    (if (not calcfirst)
1809                        (setq size (buffer-size))))
1810                  (setq cmdstr
1811                        (concat cmdstr (format "{%d}" size))))
1812                (unwind-protect
1813                    (progn
1814                      (imap-send-command-1 cmdstr)
1815                      (setq cmdstr nil)
1816                      (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1817                          (setq command nil) ;; abort command if no cont-req
1818                        (let ((process imap-process)
1819                              (stream imap-stream)
1820                              (eol imap-client-eol))
1821                          (with-current-buffer cmd
1822                            (and imap-log
1823                                 (with-current-buffer (get-buffer-create
1824                                                       imap-log-buffer)
1825                                   (imap-disable-multibyte)
1826                                   (buffer-disable-undo)
1827                                   (goto-char (point-max))
1828                                   (insert-buffer-substring cmd)))
1829                            (process-send-region process (point-min)
1830                                                 (point-max)))
1831                          (process-send-string process imap-client-eol))))
1832                  (setq imap-continuation nil)))
1833               ((functionp cmd)
1834                (imap-send-command-1 cmdstr)
1835                (setq cmdstr nil)
1836                (unwind-protect
1837                    (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1838                        (setq command nil) ;; abort command if no cont-req
1839                      (setq command (cons (funcall cmd imap-continuation)
1840                                          command)))
1841                  (setq imap-continuation nil)))
1842               (t
1843                (error "Unknown command type"))))
1844       (if cmdstr
1845           (imap-send-command-1 cmdstr))
1846       tag)))
1847
1848 (defun imap-wait-for-tag (tag &optional buffer)
1849   (with-current-buffer (or buffer (current-buffer))
1850     (let (imap-have-messaged)
1851       (while (and (null imap-continuation)
1852                   (memq (process-status imap-process) '(open run))
1853                   (< imap-reached-tag tag))
1854         (let ((len (/ (point-max) 1024))
1855               message-log-max)
1856           (unless (< len 10)
1857             (setq imap-have-messaged t)
1858             (message "imap read: %dk" len))
1859           (accept-process-output imap-process
1860                                  (truncate imap-read-timeout)
1861                                  (truncate (* (- imap-read-timeout
1862                                                  (truncate imap-read-timeout))
1863                                               1000)))))
1864       ;; A process can die _before_ we have processed everything it
1865       ;; has to say.  Moreover, this can happen in between the call to
1866       ;; accept-process-output and the call to process-status in an
1867       ;; iteration of the loop above.
1868       (when (and (null imap-continuation)
1869                  (< imap-reached-tag tag))
1870         (accept-process-output imap-process 0 0))
1871       (when imap-have-messaged
1872         (message ""))
1873       (and (memq (process-status imap-process) '(open run))
1874            (or (assq tag imap-failed-tags)
1875                (if imap-continuation
1876                    'INCOMPLETE
1877                  'OK))))))
1878
1879 (defun imap-sentinel (process string)
1880   (delete-process process))
1881
1882 (defun imap-find-next-line ()
1883   "Return point at end of current line, taking into account literals.
1884 Return nil if no complete line has arrived."
1885   (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}"
1886                                    imap-server-eol)
1887                            nil t)
1888     (if (match-string 1)
1889         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1890             nil
1891           (goto-char (+ (point) (string-to-number (match-string 1))))
1892           (imap-find-next-line))
1893       (point))))
1894
1895 (defun imap-arrival-filter (proc string)
1896   "IMAP process filter."
1897   ;; Sometimes, we are called even though the process has died.
1898   ;; Better abstain from doing stuff in that case.
1899   (when (buffer-name (process-buffer proc))
1900     (with-current-buffer (process-buffer proc)
1901       (goto-char (point-max))
1902       (insert string)
1903       (and imap-log
1904            (with-current-buffer (get-buffer-create imap-log-buffer)
1905              (imap-disable-multibyte)
1906              (buffer-disable-undo)
1907              (goto-char (point-max))
1908              (insert string)))
1909       (let (end)
1910         (goto-char (point-min))
1911         (while (setq end (imap-find-next-line))
1912           (save-restriction
1913             (narrow-to-region (point-min) end)
1914             (delete-backward-char (length imap-server-eol))
1915             (goto-char (point-min))
1916             (unwind-protect
1917                 (cond ((eq imap-state 'initial)
1918                        (imap-parse-greeting))
1919                       ((or (eq imap-state 'auth)
1920                            (eq imap-state 'nonauth)
1921                            (eq imap-state 'selected)
1922                            (eq imap-state 'examine))
1923                        (imap-parse-response))
1924                       (t
1925                        (message "Unknown state %s in arrival filter"
1926                                 imap-state)))
1927               (delete-region (point-min) (point-max)))))))))
1928
1929 \f
1930 ;; Imap parser.
1931
1932 (defsubst imap-forward ()
1933   (or (eobp) (forward-char)))
1934
1935 ;;   number          = 1*DIGIT
1936 ;;                       ; Unsigned 32-bit integer
1937 ;;                       ; (0 <= n < 4,294,967,296)
1938
1939 (defsubst imap-parse-number ()
1940   (when (looking-at "[0-9]+")
1941     (prog1
1942         (string-to-number (match-string 0))
1943       (goto-char (match-end 0)))))
1944
1945 ;;   literal         = "{" number "}" CRLF *CHAR8
1946 ;;                       ; Number represents the number of CHAR8s
1947
1948 (defsubst imap-parse-literal ()
1949   (when (looking-at "{\\([0-9]+\\)}\r\n")
1950     (let ((pos (match-end 0))
1951           (len (string-to-number (match-string 1))))
1952       (if (< (point-max) (+ pos len))
1953           nil
1954         (goto-char (+ pos len))
1955         (buffer-substring pos (+ pos len))))))
1956
1957 ;;   string          = quoted / literal
1958 ;;
1959 ;;   quoted          = DQUOTE *QUOTED-CHAR DQUOTE
1960 ;;
1961 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
1962 ;;                     "\" quoted-specials
1963 ;;
1964 ;;   quoted-specials = DQUOTE / "\"
1965 ;;
1966 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
1967
1968 (defsubst imap-parse-string ()
1969   (cond ((eq (char-after) ?\")
1970          (forward-char 1)
1971          (let ((p (point)) (name ""))
1972            (skip-chars-forward "^\"\\\\")
1973            (setq name (buffer-substring p (point)))
1974            (while (eq (char-after) ?\\)
1975              (setq p (1+ (point)))
1976              (forward-char 2)
1977              (skip-chars-forward "^\"\\\\")
1978              (setq name (concat name (buffer-substring p (point)))))
1979            (forward-char 1)
1980            name))
1981         ((eq (char-after) ?{)
1982          (imap-parse-literal))))
1983
1984 ;;   nil             = "NIL"
1985
1986 (defsubst imap-parse-nil ()
1987   (if (looking-at "NIL")
1988       (goto-char (match-end 0))))
1989
1990 ;;   nstring         = string / nil
1991
1992 (defsubst imap-parse-nstring ()
1993   (or (imap-parse-string)
1994       (and (imap-parse-nil)
1995            nil)))
1996
1997 ;;   astring         = atom / string
1998 ;;
1999 ;;   atom            = 1*ATOM-CHAR
2000 ;;
2001 ;;   ATOM-CHAR       = <any CHAR except atom-specials>
2002 ;;
2003 ;;   atom-specials   = "(" / ")" / "{" / SP / CTL / list-wildcards /
2004 ;;                     quoted-specials
2005 ;;
2006 ;;   list-wildcards  = "%" / "*"
2007 ;;
2008 ;;   quoted-specials = DQUOTE / "\"
2009
2010 (defsubst imap-parse-astring ()
2011   (or (imap-parse-string)
2012       (buffer-substring (point)
2013                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
2014                             (goto-char (1- (match-end 0)))
2015                           (end-of-line)
2016                           (point)))))
2017
2018 ;;   address         = "(" addr-name SP addr-adl SP addr-mailbox SP
2019 ;;                      addr-host ")"
2020 ;;
2021 ;;   addr-adl        = nstring
2022 ;;                       ; Holds route from [RFC-822] route-addr if
2023 ;;                       ; non-nil
2024 ;;
2025 ;;   addr-host       = nstring
2026 ;;                       ; nil indicates [RFC-822] group syntax.
2027 ;;                       ; Otherwise, holds [RFC-822] domain name
2028 ;;
2029 ;;   addr-mailbox    = nstring
2030 ;;                       ; nil indicates end of [RFC-822] group; if
2031 ;;                       ; non-nil and addr-host is nil, holds
2032 ;;                       ; [RFC-822] group name.
2033 ;;                       ; Otherwise, holds [RFC-822] local-part
2034 ;;                       ; after removing [RFC-822] quoting
2035 ;;
2036 ;;   addr-name       = nstring
2037 ;;                       ; If non-nil, holds phrase from [RFC-822]
2038 ;;                       ; mailbox after removing [RFC-822] quoting
2039 ;;
2040
2041 (defsubst imap-parse-address ()
2042   (let (address)
2043     (when (eq (char-after) ?\()
2044       (imap-forward)
2045       (setq address (vector (prog1 (imap-parse-nstring)
2046                               (imap-forward))
2047                             (prog1 (imap-parse-nstring)
2048                               (imap-forward))
2049                             (prog1 (imap-parse-nstring)
2050                               (imap-forward))
2051                             (imap-parse-nstring)))
2052       (when (eq (char-after) ?\))
2053         (imap-forward)
2054         address))))
2055
2056 ;;   address-list    = "(" 1*address ")" / nil
2057 ;;
2058 ;;   nil             = "NIL"
2059
2060 (defsubst imap-parse-address-list ()
2061   (if (eq (char-after) ?\()
2062       (let (address addresses)
2063         (imap-forward)
2064         (while (and (not (eq (char-after) ?\)))
2065                     ;; next line for MS Exchange bug
2066                     (progn (and (eq (char-after) ? ) (imap-forward)) t)
2067                     (setq address (imap-parse-address)))
2068           (setq addresses (cons address addresses)))
2069         (when (eq (char-after) ?\))
2070           (imap-forward)
2071           (nreverse addresses)))
2072     ;; With assert, the code might not be eval'd.
2073     ;; (assert (imap-parse-nil) t "In imap-parse-address-list")
2074     (imap-parse-nil)))
2075
2076 ;;   mailbox         = "INBOX" / astring
2077 ;;                       ; INBOX is case-insensitive.  All case variants of
2078 ;;                       ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX
2079 ;;                       ; not as an astring.  An astring which consists of
2080 ;;                       ; the case-insensitive sequence "I" "N" "B" "O" "X"
2081 ;;                       ; is considered to be INBOX and not an astring.
2082 ;;                       ;  Refer to section 5.1 for further
2083 ;;                       ; semantic details of mailbox names.
2084
2085 (defsubst imap-parse-mailbox ()
2086   (let ((mailbox (imap-parse-astring)))
2087     (if (string-equal "INBOX" (upcase mailbox))
2088         "INBOX"
2089       mailbox)))
2090
2091 ;;   greeting        = "*" SP (resp-cond-auth / resp-cond-bye) CRLF
2092 ;;
2093 ;;   resp-cond-auth  = ("OK" / "PREAUTH") SP resp-text
2094 ;;                       ; Authentication condition
2095 ;;
2096 ;;   resp-cond-bye   = "BYE" SP resp-text
2097
2098 (defun imap-parse-greeting ()
2099   "Parse a IMAP greeting."
2100   (cond ((looking-at "\\* OK ")
2101          (setq imap-state 'nonauth))
2102         ((looking-at "\\* PREAUTH ")
2103          (setq imap-state 'auth))
2104         ((looking-at "\\* BYE ")
2105          (setq imap-state 'closed))))
2106
2107 ;;   response        = *(continue-req / response-data) response-done
2108 ;;
2109 ;;   continue-req    = "+" SP (resp-text / base64) CRLF
2110 ;;
2111 ;;   response-data   = "*" SP (resp-cond-state / resp-cond-bye /
2112 ;;                     mailbox-data / message-data / capability-data) CRLF
2113 ;;
2114 ;;   response-done   = response-tagged / response-fatal
2115 ;;
2116 ;;   response-fatal  = "*" SP resp-cond-bye CRLF
2117 ;;                       ; Server closes connection immediately
2118 ;;
2119 ;;   response-tagged = tag SP resp-cond-state CRLF
2120 ;;
2121 ;;   resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text
2122 ;;                       ; Status condition
2123 ;;
2124 ;;   resp-cond-bye   = "BYE" SP resp-text
2125 ;;
2126 ;;   mailbox-data    =  "FLAGS" SP flag-list /
2127 ;;                      "LIST" SP mailbox-list /
2128 ;;                      "LSUB" SP mailbox-list /
2129 ;;                      "SEARCH" *(SP nz-number) /
2130 ;;                      "STATUS" SP mailbox SP "("
2131 ;;                            [status-att SP number *(SP status-att SP number)] ")" /
2132 ;;                      number SP "EXISTS" /
2133 ;;                      number SP "RECENT"
2134 ;;
2135 ;;   message-data    = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att))
2136 ;;
2137 ;;   capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1"
2138 ;;                     *(SP capability)
2139 ;;                       ; IMAP4rev1 servers which offer RFC 1730
2140 ;;                       ; compatibility MUST list "IMAP4" as the first
2141 ;;                       ; capability.
2142
2143 (defun imap-parse-response ()
2144   "Parse a IMAP command response."
2145   (let (token)
2146     (case (setq token (read (current-buffer)))
2147       (+ (setq imap-continuation
2148                (or (buffer-substring (min (point-max) (1+ (point)))
2149                                      (point-max))
2150                    t)))
2151       (* (case (prog1 (setq token (read (current-buffer)))
2152                  (imap-forward))
2153            (OK         (imap-parse-resp-text))
2154            (NO         (imap-parse-resp-text))
2155            (BAD        (imap-parse-resp-text))
2156            (BYE        (imap-parse-resp-text))
2157            (FLAGS      (imap-mailbox-put 'flags (imap-parse-flag-list)))
2158            (LIST       (imap-parse-data-list 'list))
2159            (LSUB       (imap-parse-data-list 'lsub))
2160            (SEARCH     (imap-mailbox-put
2161                         'search
2162                         (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
2163            (STATUS     (imap-parse-status))
2164            (CAPABILITY (setq imap-capability
2165                                (read (concat "(" (upcase (buffer-substring
2166                                                           (point) (point-max)))
2167                                              ")"))))
2168            (ID         (setq imap-id (read (buffer-substring (point)
2169                                                              (point-max)))))
2170            (ACL        (imap-parse-acl))
2171            (t       (case (prog1 (read (current-buffer))
2172                             (imap-forward))
2173                       (EXISTS  (imap-mailbox-put 'exists token))
2174                       (RECENT  (imap-mailbox-put 'recent token))
2175                       (EXPUNGE t)
2176                       (FETCH   (imap-parse-fetch token))
2177                       (t       (message "Garbage: %s" (buffer-string)))))))
2178       (t (let (status)
2179            (if (not (integerp token))
2180                (message "Garbage: %s" (buffer-string))
2181              (case (prog1 (setq status (read (current-buffer)))
2182                      (imap-forward))
2183                (OK  (progn
2184                       (setq imap-reached-tag (max imap-reached-tag token))
2185                       (imap-parse-resp-text)))
2186                (NO  (progn
2187                       (setq imap-reached-tag (max imap-reached-tag token))
2188                       (save-excursion
2189                         (imap-parse-resp-text))
2190                       (let (code text)
2191                         (when (eq (char-after) ?\[)
2192                           (setq code (buffer-substring (point)
2193                                                        (search-forward "]")))
2194                           (imap-forward))
2195                         (setq text (buffer-substring (point) (point-max)))
2196                         (push (list token status code text)
2197                               imap-failed-tags))))
2198                (BAD (progn
2199                       (setq imap-reached-tag (max imap-reached-tag token))
2200                       (save-excursion
2201                         (imap-parse-resp-text))
2202                       (let (code text)
2203                         (when (eq (char-after) ?\[)
2204                           (setq code (buffer-substring (point)
2205                                                        (search-forward "]")))
2206                           (imap-forward))
2207                         (setq text (buffer-substring (point) (point-max)))
2208                         (push (list token status code text) imap-failed-tags)
2209                         (error "Internal error, tag %s status %s code %s text %s"
2210                                token status code text))))
2211                (t   (message "Garbage: %s" (buffer-string))))
2212              (when (assq token imap-callbacks)
2213                (funcall (cdr (assq token imap-callbacks)) token status)
2214                (setq imap-callbacks
2215                      (imap-remassoc token imap-callbacks)))))))))
2216
2217 ;;   resp-text       = ["[" resp-text-code "]" SP] text
2218 ;;
2219 ;;   text            = 1*TEXT-CHAR
2220 ;;
2221 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
2222
2223 (defun imap-parse-resp-text ()
2224   (imap-parse-resp-text-code))
2225
2226 ;;   resp-text-code  = "ALERT" /
2227 ;;                     "BADCHARSET [SP "(" astring *(SP astring) ")" ] /
2228 ;;                     "NEWNAME" SP string SP string /
2229 ;;                     "PARSE" /
2230 ;;                     "PERMANENTFLAGS" SP "("
2231 ;;                               [flag-perm *(SP flag-perm)] ")" /
2232 ;;                     "READ-ONLY" /
2233 ;;                     "READ-WRITE" /
2234 ;;                     "TRYCREATE" /
2235 ;;                     "UIDNEXT" SP nz-number /
2236 ;;                     "UIDVALIDITY" SP nz-number /
2237 ;;                     "UNSEEN" SP nz-number /
2238 ;;                     resp-text-atom [SP 1*<any TEXT-CHAR except "]">]
2239 ;;
2240 ;;   resp_code_apnd  = "APPENDUID" SPACE nz_number SPACE uniqueid
2241 ;;
2242 ;;   resp_code_copy  = "COPYUID" SPACE nz_number SPACE set SPACE set
2243 ;;
2244 ;;   set             = sequence-num / (sequence-num ":" sequence-num) /
2245 ;;                        (set "," set)
2246 ;;                          ; Identifies a set of messages.  For message
2247 ;;                          ; sequence numbers, these are consecutive
2248 ;;                          ; numbers from 1 to the number of messages in
2249 ;;                          ; the mailbox
2250 ;;                          ; Comma delimits individual numbers, colon
2251 ;;                          ; delimits between two numbers inclusive.
2252 ;;                          ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13,
2253 ;;                          ; 14,15 for a mailbox with 15 messages.
2254 ;;
2255 ;;   sequence-num    = nz-number / "*"
2256 ;;                          ; * is the largest number in use.  For message
2257 ;;                          ; sequence numbers, it is the number of messages
2258 ;;                          ; in the mailbox.  For unique identifiers, it is
2259 ;;                          ; the unique identifier of the last message in
2260 ;;                          ; the mailbox.
2261 ;;
2262 ;;   flag-perm       = flag / "\*"
2263 ;;
2264 ;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
2265 ;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
2266 ;;                       ; Does not include "\Recent"
2267 ;;
2268 ;;   flag-extension  = "\" atom
2269 ;;                       ; Future expansion.  Client implementations
2270 ;;                       ; MUST accept flag-extension flags.  Server
2271 ;;                       ; implementations MUST NOT generate
2272 ;;                       ; flag-extension flags except as defined by
2273 ;;                       ; future standard or standards-track
2274 ;;                       ; revisions of this specification.
2275 ;;
2276 ;;   flag-keyword    = atom
2277 ;;
2278 ;;   resp-text-atom  = 1*<any ATOM-CHAR except "]">
2279
2280 (defun imap-parse-resp-text-code ()
2281   ;; xxx next line for stalker communigate pro 3.3.1 bug
2282   (when (looking-at " \\[")
2283     (imap-forward))
2284   (when (eq (char-after) ?\[)
2285     (imap-forward)
2286     (cond ((search-forward "PERMANENTFLAGS " nil t)
2287            (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))
2288           ((search-forward "UIDNEXT \\([0-9]+\\)" nil t)
2289            (imap-mailbox-put 'uidnext (match-string 1)))
2290           ((search-forward "UNSEEN " nil t)
2291            (imap-mailbox-put 'first-unseen (read (current-buffer))))
2292           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
2293            (imap-mailbox-put 'uidvalidity (match-string 1)))
2294           ((search-forward "READ-ONLY" nil t)
2295            (imap-mailbox-put 'read-only t))
2296           ((search-forward "NEWNAME " nil t)
2297            (let (oldname newname)
2298              (setq oldname (imap-parse-string))
2299              (imap-forward)
2300              (setq newname (imap-parse-string))
2301              (imap-mailbox-put 'newname newname oldname)))
2302           ((search-forward "TRYCREATE" nil t)
2303            (imap-mailbox-put 'trycreate t imap-current-target-mailbox))
2304           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
2305            (imap-mailbox-put 'appenduid
2306                              (list (match-string 1)
2307                                    (string-to-number (match-string 2)))
2308                              imap-current-target-mailbox))
2309           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
2310            (imap-mailbox-put 'copyuid (list (match-string 1)
2311                                             (match-string 2)
2312                                             (match-string 3))
2313                              imap-current-target-mailbox))
2314           ((search-forward "ALERT] " nil t)
2315            (message "Imap server %s information: %s" imap-server
2316                     (buffer-substring (point) (point-max)))))))
2317
2318 ;;   mailbox-list    = "(" [mbx-list-flags] ")" SP
2319 ;;                      (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox
2320 ;;
2321 ;;   mbx-list-flags  = *(mbx-list-oflag SP) mbx-list-sflag
2322 ;;                     *(SP mbx-list-oflag) /
2323 ;;                     mbx-list-oflag *(SP mbx-list-oflag)
2324 ;;
2325 ;;   mbx-list-oflag  = "\Noinferiors" / flag-extension
2326 ;;                       ; Other flags; multiple possible per LIST response
2327 ;;
2328 ;;   mbx-list-sflag  = "\Noselect" / "\Marked" / "\Unmarked"
2329 ;;                       ; Selectability flags; only one per LIST response
2330 ;;
2331 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
2332 ;;                     "\" quoted-specials
2333 ;;
2334 ;;   quoted-specials = DQUOTE / "\"
2335
2336 (defun imap-parse-data-list (type)
2337   (let (flags delimiter mailbox)
2338     (setq flags (imap-parse-flag-list))
2339     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
2340       (setq delimiter (match-string 1))
2341       (goto-char (1+ (match-end 0)))
2342       (when (setq mailbox (imap-parse-mailbox))
2343         (imap-mailbox-put type t mailbox)
2344         (imap-mailbox-put 'list-flags flags mailbox)
2345         (imap-mailbox-put 'delimiter delimiter mailbox)))))
2346
2347 ;;  msg_att         ::= "(" 1#("ENVELOPE" SPACE envelope /
2348 ;;                      "FLAGS" SPACE "(" #(flag / "\Recent") ")" /
2349 ;;                      "INTERNALDATE" SPACE date_time /
2350 ;;                      "RFC822" [".HEADER" / ".TEXT"] SPACE nstring /
2351 ;;                      "RFC822.SIZE" SPACE number /
2352 ;;                      "BODY" ["STRUCTURE"] SPACE body /
2353 ;;                      "BODY" section ["<" number ">"] SPACE nstring /
2354 ;;                      "UID" SPACE uniqueid) ")"
2355 ;;
2356 ;;  date_time       ::= <"> date_day_fixed "-" date_month "-" date_year
2357 ;;                      SPACE time SPACE zone <">
2358 ;;
2359 ;;  section         ::= "[" [section_text / (nz_number *["." nz_number]
2360 ;;                      ["." (section_text / "MIME")])] "]"
2361 ;;
2362 ;;  section_text    ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
2363 ;;                      SPACE header_list / "TEXT"
2364 ;;
2365 ;;  header_fld_name ::= astring
2366 ;;
2367 ;;  header_list     ::= "(" 1#header_fld_name ")"
2368
2369 (defsubst imap-parse-header-list ()
2370   (when (eq (char-after) ?\()
2371     (let (strlist)
2372       (while (not (eq (char-after) ?\)))
2373         (imap-forward)
2374         (push (imap-parse-astring) strlist))
2375       (imap-forward)
2376       (nreverse strlist))))
2377
2378 (defsubst imap-parse-fetch-body-section ()
2379   (let ((section
2380          (buffer-substring (point) (1- (re-search-forward "[] ]" nil t)))))
2381     (if (eq (char-before) ? )
2382         (prog1
2383             (mapconcat 'identity (cons section (imap-parse-header-list)) " ")
2384           (search-forward "]" nil t))
2385       section)))
2386
2387 (defun imap-parse-fetch (response)
2388   (when (eq (char-after) ?\()
2389     (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
2390               rfc822size body bodydetail bodystructure flags-empty)
2391       (while (not (eq (char-after) ?\)))
2392         (imap-forward)
2393         (let ((token (read (current-buffer))))
2394           (imap-forward)
2395           (cond ((eq token 'UID)
2396                  (setq uid (condition-case ()
2397                                (read (current-buffer))
2398                              (error))))
2399                 ((eq token 'FLAGS)
2400                  (setq flags (imap-parse-flag-list))
2401                  (if (not flags)
2402                      (setq flags-empty 't)))
2403                 ((eq token 'ENVELOPE)
2404                  (setq envelope (imap-parse-envelope)))
2405                 ((eq token 'INTERNALDATE)
2406                  (setq internaldate (imap-parse-string)))
2407                 ((eq token 'RFC822)
2408                  (setq rfc822 (imap-parse-nstring)))
2409                 ((eq token 'RFC822.HEADER)
2410                  (setq rfc822header (imap-parse-nstring)))
2411                 ((eq token 'RFC822.TEXT)
2412                  (setq rfc822text (imap-parse-nstring)))
2413                 ((eq token 'RFC822.SIZE)
2414                  (setq rfc822size (read (current-buffer))))
2415                 ((eq token 'BODY)
2416                  (if (eq (char-before) ?\[)
2417                      (push (list
2418                             (upcase (imap-parse-fetch-body-section))
2419                             (and (eq (char-after) ?<)
2420                                  (buffer-substring (1+ (point))
2421                                                    (search-forward ">" nil t)))
2422                             (progn (imap-forward)
2423                                    (imap-parse-nstring)))
2424                            bodydetail)
2425                    (setq body (imap-parse-body))))
2426                 ((eq token 'BODYSTRUCTURE)
2427                  (setq bodystructure (imap-parse-body))))))
2428       (when uid
2429         (setq imap-current-message uid)
2430         (imap-message-put uid 'UID uid)
2431         (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags))
2432         (and envelope (imap-message-put uid 'ENVELOPE envelope))
2433         (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))
2434         (and rfc822 (imap-message-put uid 'RFC822 rfc822))
2435         (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header))
2436         (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text))
2437         (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size))
2438         (and body (imap-message-put uid 'BODY body))
2439         (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail))
2440         (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure))
2441         (run-hooks 'imap-fetch-data-hook)))))
2442
2443 ;;   mailbox-data    =  ...
2444 ;;                      "STATUS" SP mailbox SP "("
2445 ;;                            [status-att SP number
2446 ;;                            *(SP status-att SP number)] ")"
2447 ;;                      ...
2448 ;;
2449 ;;   status-att      = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" /
2450 ;;                     "UNSEEN"
2451
2452 (defun imap-parse-status ()
2453   (let ((mailbox (imap-parse-mailbox)))
2454     (if (eq (char-after) ? )
2455         (forward-char))
2456     (when (and mailbox (eq (char-after) ?\())
2457       (while (and (not (eq (char-after) ?\)))
2458                   (or (forward-char) t)
2459                   (looking-at "\\([A-Za-z]+\\) "))
2460         (let ((token (match-string 1)))
2461           (goto-char (match-end 0))
2462           (cond ((string= token "MESSAGES")
2463                  (imap-mailbox-put 'messages (read (current-buffer)) mailbox))
2464                 ((string= token "RECENT")
2465                  (imap-mailbox-put 'recent (read (current-buffer)) mailbox))
2466                 ((string= token "UIDNEXT")
2467                  (and (looking-at "[0-9]+")
2468                       (imap-mailbox-put 'uidnext (match-string 0) mailbox)
2469                       (goto-char (match-end 0))))
2470                 ((string= token "UIDVALIDITY")
2471                  (and (looking-at "[0-9]+")
2472                       (imap-mailbox-put 'uidvalidity (match-string 0) mailbox)
2473                       (goto-char (match-end 0))))
2474                 ((string= token "UNSEEN")
2475                  (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))
2476                 (t
2477                  (message "Unknown status data %s in mailbox %s ignored"
2478                           token mailbox)
2479                  (read (current-buffer)))))))))
2480
2481 ;;   acl_data        ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
2482 ;;                        rights)
2483 ;;
2484 ;;   identifier      ::= astring
2485 ;;
2486 ;;   rights          ::= astring
2487
2488 (defun imap-parse-acl ()
2489   (let ((mailbox (imap-parse-mailbox))
2490         identifier rights acl)
2491     (while (eq (char-after) ?\ )
2492       (imap-forward)
2493       (setq identifier (imap-parse-astring))
2494       (imap-forward)
2495       (setq rights (imap-parse-astring))
2496       (setq acl (append acl (list (cons identifier rights)))))
2497     (imap-mailbox-put 'acl acl mailbox)))
2498
2499 ;;   flag-list       = "(" [flag *(SP flag)] ")"
2500 ;;
2501 ;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
2502 ;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
2503 ;;                       ; Does not include "\Recent"
2504 ;;
2505 ;;   flag-keyword    = atom
2506 ;;
2507 ;;   flag-extension  = "\" atom
2508 ;;                       ; Future expansion.  Client implementations
2509 ;;                       ; MUST accept flag-extension flags.  Server
2510 ;;                       ; implementations MUST NOT generate
2511 ;;                       ; flag-extension flags except as defined by
2512 ;;                       ; future standard or standards-track
2513 ;;                       ; revisions of this specification.
2514
2515 (defun imap-parse-flag-list ()
2516   (let (flag-list start)
2517     (assert (eq (char-after) ?\() nil "In imap-parse-flag-list")
2518     (while (and (not (eq (char-after) ?\)))
2519                 (setq start (progn
2520                               (imap-forward)
2521                               ;; next line for Courier IMAP bug.
2522                               (skip-chars-forward " ")
2523                               (point)))
2524                 (> (skip-chars-forward "^ )" (point-at-eol)) 0))
2525       (push (buffer-substring start (point)) flag-list))
2526     (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list")
2527     (imap-forward)
2528     (nreverse flag-list)))
2529
2530 ;;   envelope        = "(" env-date SP env-subject SP env-from SP env-sender SP
2531 ;;                     env-reply-to SP env-to SP env-cc SP env-bcc SP
2532 ;;                     env-in-reply-to SP env-message-id ")"
2533 ;;
2534 ;;   env-bcc         = "(" 1*address ")" / nil
2535 ;;
2536 ;;   env-cc          = "(" 1*address ")" / nil
2537 ;;
2538 ;;   env-date        = nstring
2539 ;;
2540 ;;   env-from        = "(" 1*address ")" / nil
2541 ;;
2542 ;;   env-in-reply-to = nstring
2543 ;;
2544 ;;   env-message-id  = nstring
2545 ;;
2546 ;;   env-reply-to    = "(" 1*address ")" / nil
2547 ;;
2548 ;;   env-sender      = "(" 1*address ")" / nil
2549 ;;
2550 ;;   env-subject     = nstring
2551 ;;
2552 ;;   env-to          = "(" 1*address ")" / nil
2553
2554 (defun imap-parse-envelope ()
2555   (when (eq (char-after) ?\()
2556     (imap-forward)
2557     (vector (prog1 (imap-parse-nstring) ;; date
2558               (imap-forward))
2559             (prog1 (imap-parse-nstring) ;; subject
2560               (imap-forward))
2561             (prog1 (imap-parse-address-list) ;; from
2562               (imap-forward))
2563             (prog1 (imap-parse-address-list) ;; sender
2564               (imap-forward))
2565             (prog1 (imap-parse-address-list) ;; reply-to
2566               (imap-forward))
2567             (prog1 (imap-parse-address-list) ;; to
2568               (imap-forward))
2569             (prog1 (imap-parse-address-list) ;; cc
2570               (imap-forward))
2571             (prog1 (imap-parse-address-list) ;; bcc
2572               (imap-forward))
2573             (prog1 (imap-parse-nstring) ;; in-reply-to
2574               (imap-forward))
2575             (prog1 (imap-parse-nstring) ;; message-id
2576               (imap-forward)))))
2577
2578 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2579
2580 (defsubst imap-parse-string-list ()
2581   (cond ((eq (char-after) ?\() ;; body-fld-param
2582          (let (strlist str)
2583            (imap-forward)
2584            (while (setq str (imap-parse-string))
2585              (push str strlist)
2586              ;; buggy stalker communigate pro 3.0 doesn't print SPC
2587              ;; between body-fld-param's sometimes
2588              (or (eq (char-after) ?\")
2589                  (imap-forward)))
2590            (nreverse strlist)))
2591         ((imap-parse-nil)
2592          nil)))
2593
2594 ;;   body-extension  = nstring / number /
2595 ;;                      "(" body-extension *(SP body-extension) ")"
2596 ;;                       ; Future expansion.  Client implementations
2597 ;;                       ; MUST accept body-extension fields.  Server
2598 ;;                       ; implementations MUST NOT generate
2599 ;;                       ; body-extension fields except as defined by
2600 ;;                       ; future standard or standards-track
2601 ;;                       ; revisions of this specification.
2602
2603 (defun imap-parse-body-extension ()
2604   (if (eq (char-after) ?\()
2605       (let (b-e)
2606         (imap-forward)
2607         (push (imap-parse-body-extension) b-e)
2608         (while (eq (char-after) ?\ )
2609           (imap-forward)
2610           (push (imap-parse-body-extension) b-e))
2611         (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension")
2612         (imap-forward)
2613         (nreverse b-e))
2614     (or (imap-parse-number)
2615         (imap-parse-nstring))))
2616
2617 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2618 ;;                     *(SP body-extension)]]
2619 ;;                       ; MUST NOT be returned on non-extensible
2620 ;;                       ; "BODY" fetch
2621 ;;
2622 ;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2623 ;;                     *(SP body-extension)]]
2624 ;;                       ; MUST NOT be returned on non-extensible
2625 ;;                       ; "BODY" fetch
2626
2627 (defsubst imap-parse-body-ext ()
2628   (let (ext)
2629     (when (eq (char-after) ?\ ) ;; body-fld-dsp
2630       (imap-forward)
2631       (let (dsp)
2632         (if (eq (char-after) ?\()
2633             (progn
2634               (imap-forward)
2635               (push (imap-parse-string) dsp)
2636               (imap-forward)
2637               (push (imap-parse-string-list) dsp)
2638               (imap-forward))
2639           ;; With assert, the code might not be eval'd.
2640           ;; (assert (imap-parse-nil) t "In imap-parse-body-ext")
2641           (imap-parse-nil))
2642         (push (nreverse dsp) ext))
2643       (when (eq (char-after) ?\ ) ;; body-fld-lang
2644         (imap-forward)
2645         (if (eq (char-after) ?\()
2646             (push (imap-parse-string-list) ext)
2647           (push (imap-parse-nstring) ext))
2648         (while (eq (char-after) ?\ ) ;; body-extension
2649           (imap-forward)
2650           (setq ext (append (imap-parse-body-extension) ext)))))
2651     ext))
2652
2653 ;;   body            = "(" body-type-1part / body-type-mpart ")"
2654 ;;
2655 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2656 ;;                     *(SP body-extension)]]
2657 ;;                       ; MUST NOT be returned on non-extensible
2658 ;;                       ; "BODY" fetch
2659 ;;
2660 ;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2661 ;;                     *(SP body-extension)]]
2662 ;;                       ; MUST NOT be returned on non-extensible
2663 ;;                       ; "BODY" fetch
2664 ;;
2665 ;;   body-fields     = body-fld-param SP body-fld-id SP body-fld-desc SP
2666 ;;                     body-fld-enc SP body-fld-octets
2667 ;;
2668 ;;   body-fld-desc   = nstring
2669 ;;
2670 ;;   body-fld-dsp    = "(" string SP body-fld-param ")" / nil
2671 ;;
2672 ;;   body-fld-enc    = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
2673 ;;                     "QUOTED-PRINTABLE") DQUOTE) / string
2674 ;;
2675 ;;   body-fld-id     = nstring
2676 ;;
2677 ;;   body-fld-lang   = nstring / "(" string *(SP string) ")"
2678 ;;
2679 ;;   body-fld-lines  = number
2680 ;;
2681 ;;   body-fld-md5    = nstring
2682 ;;
2683 ;;   body-fld-octets = number
2684 ;;
2685 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2686 ;;
2687 ;;   body-type-1part = (body-type-basic / body-type-msg / body-type-text)
2688 ;;                     [SP body-ext-1part]
2689 ;;
2690 ;;   body-type-basic = media-basic SP body-fields
2691 ;;                       ; MESSAGE subtype MUST NOT be "RFC822"
2692 ;;
2693 ;;   body-type-msg   = media-message SP body-fields SP envelope
2694 ;;                     SP body SP body-fld-lines
2695 ;;
2696 ;;   body-type-text  = media-text SP body-fields SP body-fld-lines
2697 ;;
2698 ;;   body-type-mpart = 1*body SP media-subtype
2699 ;;                     [SP body-ext-mpart]
2700 ;;
2701 ;;   media-basic     = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
2702 ;;                     "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
2703 ;;                       ; Defined in [MIME-IMT]
2704 ;;
2705 ;;   media-message   = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
2706 ;;                      ; Defined in [MIME-IMT]
2707 ;;
2708 ;;   media-subtype   = string
2709 ;;                       ; Defined in [MIME-IMT]
2710 ;;
2711 ;;   media-text      = DQUOTE "TEXT" DQUOTE SP media-subtype
2712 ;;                       ; Defined in [MIME-IMT]
2713
2714 (defun imap-parse-body ()
2715   (let (body)
2716     (when (eq (char-after) ?\()
2717       (imap-forward)
2718       (if (eq (char-after) ?\()
2719           (let (subbody)
2720             (while (and (eq (char-after) ?\()
2721                         (setq subbody (imap-parse-body)))
2722              ;; buggy stalker communigate pro 3.0 insert a SPC between
2723               ;; parts in multiparts
2724               (when (and (eq (char-after) ?\ )
2725                          (eq (char-after (1+ (point))) ?\())
2726                 (imap-forward))
2727               (push subbody body))
2728             (imap-forward)
2729             (push (imap-parse-string) body) ;; media-subtype
2730             (when (eq (char-after) ?\ ) ;; body-ext-mpart:
2731               (imap-forward)
2732               (if (eq (char-after) ?\() ;; body-fld-param
2733                   (push (imap-parse-string-list) body)
2734                 (push (and (imap-parse-nil) nil) body))
2735               (setq body
2736                     (append (imap-parse-body-ext) body))) ;; body-ext-...
2737             (assert (eq (char-after) ?\)) nil "In imap-parse-body")
2738             (imap-forward)
2739             (nreverse body))
2740
2741         (push (imap-parse-string) body) ;; media-type
2742         (imap-forward)
2743         (push (imap-parse-string) body) ;; media-subtype
2744         (imap-forward)
2745         ;; next line for Sun SIMS bug
2746         (and (eq (char-after) ? ) (imap-forward))
2747         (if (eq (char-after) ?\() ;; body-fld-param
2748             (push (imap-parse-string-list) body)
2749           (push (and (imap-parse-nil) nil) body))
2750         (imap-forward)
2751         (push (imap-parse-nstring) body) ;; body-fld-id
2752         (imap-forward)
2753         (push (imap-parse-nstring) body) ;; body-fld-desc
2754         (imap-forward)
2755         ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
2756         ;; nstring and return nil instead of defaulting back to 7BIT
2757         ;; as the standard says.
2758         (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc
2759         (imap-forward)
2760         (push (imap-parse-number) body) ;; body-fld-octets
2761
2762    ;; ok, we're done parsing the required parts, what comes now is one
2763         ;; of three things:
2764         ;;
2765         ;; envelope       (then we're parsing body-type-msg)
2766         ;; body-fld-lines (then we're parsing body-type-text)
2767         ;; body-ext-1part (then we're parsing body-type-basic)
2768         ;;
2769   ;; the problem is that the two first are in turn optionally followed
2770 ;; by the third.  So we parse the first two here (if there are any)...
2771
2772         (when (eq (char-after) ?\ )
2773           (imap-forward)
2774           (let (lines)
2775             (cond ((eq (char-after) ?\() ;; body-type-msg:
2776                    (push (imap-parse-envelope) body) ;; envelope
2777                    (imap-forward)
2778                    (push (imap-parse-body) body) ;; body
2779                    ;; buggy stalker communigate pro 3.0 doesn't print
2780                    ;; number of lines in message/rfc822 attachment
2781                    (if (eq (char-after) ?\))
2782                        (push 0 body)
2783                      (imap-forward)
2784                      (push (imap-parse-number) body))) ;; body-fld-lines
2785                   ((setq lines (imap-parse-number)) ;; body-type-text:
2786                    (push lines body)) ;; body-fld-lines
2787                   (t
2788                    (backward-char))))) ;; no match...
2789
2790         ;; ...and then parse the third one here...
2791
2792         (when (eq (char-after) ?\ ) ;; body-ext-1part:
2793           (imap-forward)
2794           (push (imap-parse-nstring) body) ;; body-fld-md5
2795           (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
2796
2797         (assert (eq (char-after) ?\)) nil "In imap-parse-body 2")
2798         (imap-forward)
2799         (nreverse body)))))
2800
2801 (when imap-debug                        ; (untrace-all)
2802   (require 'trace)
2803   (buffer-disable-undo (get-buffer-create imap-debug-buffer))
2804   (mapcar (lambda (f) (trace-function-background f imap-debug-buffer))
2805           '(
2806             imap-utf7-encode
2807             imap-utf7-decode
2808             imap-error-text
2809             imap-kerberos4s-p
2810             imap-kerberos4-open
2811             imap-ssl-p
2812             imap-ssl-open
2813             imap-network-p
2814             imap-network-open
2815             imap-interactive-login
2816             imap-kerberos4a-p
2817             imap-kerberos4-auth
2818             imap-cram-md5-p
2819             imap-cram-md5-auth
2820             imap-login-p
2821             imap-login-auth
2822             imap-anonymous-p
2823             imap-anonymous-auth
2824             imap-open-1
2825             imap-open
2826             imap-opened
2827             imap-authenticate
2828             imap-close
2829             imap-capability
2830             imap-namespace
2831             imap-send-command-wait
2832             imap-mailbox-put
2833             imap-mailbox-get
2834             imap-mailbox-map-1
2835             imap-mailbox-map
2836             imap-current-mailbox
2837             imap-current-mailbox-p-1
2838             imap-current-mailbox-p
2839             imap-mailbox-select-1
2840             imap-mailbox-select
2841             imap-mailbox-examine-1
2842             imap-mailbox-examine
2843             imap-mailbox-unselect
2844             imap-mailbox-expunge
2845             imap-mailbox-close
2846             imap-mailbox-create-1
2847             imap-mailbox-create
2848             imap-mailbox-delete
2849             imap-mailbox-rename
2850             imap-mailbox-lsub
2851             imap-mailbox-list
2852             imap-mailbox-subscribe
2853             imap-mailbox-unsubscribe
2854             imap-mailbox-status
2855             imap-mailbox-acl-get
2856             imap-mailbox-acl-set
2857             imap-mailbox-acl-delete
2858             imap-current-message
2859             imap-list-to-message-set
2860             imap-fetch-asynch
2861             imap-fetch
2862             imap-message-put
2863             imap-message-get
2864             imap-message-map
2865             imap-search
2866             imap-message-flag-permanent-p
2867             imap-message-flags-set
2868             imap-message-flags-del
2869             imap-message-flags-add
2870             imap-message-copyuid-1
2871             imap-message-copyuid
2872             imap-message-copy
2873             imap-message-appenduid-1
2874             imap-message-appenduid
2875             imap-message-append
2876             imap-body-lines
2877             imap-envelope-from
2878             imap-send-command-1
2879             imap-send-command
2880             imap-wait-for-tag
2881             imap-sentinel
2882             imap-find-next-line
2883             imap-arrival-filter
2884             imap-parse-greeting
2885             imap-parse-response
2886             imap-parse-resp-text
2887             imap-parse-resp-text-code
2888             imap-parse-data-list
2889             imap-parse-fetch
2890             imap-parse-status
2891             imap-parse-acl
2892             imap-parse-flag-list
2893             imap-parse-envelope
2894             imap-parse-body-extension
2895             imap-parse-body
2896             )))
2897
2898 (provide 'imap)
2899
2900 ;;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7
2901 ;;; imap.el ends here