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

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