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