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 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                       (kill-buffer buffer)
1104                       (rename-buffer buffer)
1105                       (message "imap: Reconnecting with stream `%s'...done"
1106                                stream)
1107                       (setq imap-stream stream)
1108                       (setq imap-capability nil)
1109                       (setq streams nil)))
1110                 ;; We're done
1111                 (message "imap: Connecting to %s...done" imap-server)
1112                 (setq imap-stream stream)
1113                 (setq imap-capability nil)
1114                 (setq streams nil))))))
1115       (when (imap-opened buffer)
1116         (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
1117       (when imap-stream
1118         buffer))))
1119
1120 (defun imap-opened (&optional buffer)
1121   "Return non-nil if connection to imap server in BUFFER is open.
1122 If BUFFER is nil then the current buffer is used."
1123   (and (setq buffer (get-buffer (or buffer (current-buffer))))
1124        (buffer-live-p buffer)
1125        (with-current-buffer buffer
1126          (and imap-process
1127               (memq (process-status imap-process) '(open run))))))
1128
1129 (defun imap-authenticate (&optional user passwd buffer)
1130   "Authenticate to server in BUFFER, using current buffer if nil.
1131 It uses the authenticator specified when opening the server.  If the
1132 authenticator requires username/passwords, they are queried from the
1133 user and optionally stored in the buffer.  If USER and/or PASSWD is
1134 specified, the user will not be questioned and the username and/or
1135 password is remembered in the buffer."
1136   (with-current-buffer (or buffer (current-buffer))
1137     (if (not (eq imap-state 'nonauth))
1138         (or (eq imap-state 'auth)
1139             (eq imap-state 'selected)
1140             (eq imap-state 'examine))
1141       (make-local-variable 'imap-username)
1142       (make-local-variable 'imap-password)
1143       (if user (setq imap-username user))
1144       (if passwd (setq imap-password passwd))
1145       (if imap-auth
1146           (and (funcall (nth 2 (assq imap-auth
1147                                      imap-authenticator-alist)) buffer)
1148                (setq imap-state 'auth))
1149         ;; Choose authenticator.
1150         (let ((auths imap-authenticators)
1151               auth)
1152           (while (setq auth (pop auths))
1153             ;; OK to use authenticator?
1154             (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer)
1155               (message "imap: Authenticating to `%s' using `%s'..."
1156                        imap-server auth)
1157               (setq imap-auth auth)
1158               (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer)
1159                   (progn
1160                     (message "imap: Authenticating to `%s' using `%s'...done"
1161                              imap-server auth)
1162                     (setq auths nil))
1163                 (message "imap: Authenticating to `%s' using `%s'...failed"
1164                          imap-server auth)))))
1165         imap-state))))
1166
1167 (defun imap-close (&optional buffer)
1168   "Close connection to server in BUFFER.
1169 If BUFFER is nil, the current buffer is used."
1170   (with-current-buffer (or buffer (current-buffer))
1171     (when (imap-opened)
1172       (condition-case nil
1173           (imap-send-command-wait "LOGOUT")
1174         (quit nil)))
1175     (when (and imap-process
1176                (memq (process-status imap-process) '(open run)))
1177       (delete-process imap-process))
1178     (setq imap-current-mailbox nil
1179           imap-current-message nil
1180           imap-process nil)
1181     (erase-buffer)
1182     t))
1183
1184 (defun imap-capability (&optional identifier buffer)
1185   "Return a list of identifiers which server in BUFFER support.
1186 If IDENTIFIER, return non-nil if it's among the servers capabilities.
1187 If BUFFER is nil, the current buffer is assumed."
1188   (with-current-buffer (or buffer (current-buffer))
1189     (unless imap-capability
1190       (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
1191         (setq imap-capability '(IMAP2))))
1192     (if identifier
1193         (memq (intern (upcase (symbol-name identifier))) imap-capability)
1194       imap-capability)))
1195
1196 (defun imap-id (&optional list-of-values buffer)
1197   "Identify client to server in BUFFER, and return server identity.
1198 LIST-OF-VALUES is nil, or a plist with identifier and value
1199 strings to send to the server to identify the client.
1200
1201 Return a list of identifiers which server in BUFFER support, or
1202 nil if it doesn't support ID or returns no information.
1203
1204 If BUFFER is nil, the current buffer is assumed."
1205   (with-current-buffer (or buffer (current-buffer))
1206     (when (and (imap-capability 'ID)
1207                (imap-ok-p (imap-send-command-wait
1208                            (if (null list-of-values)
1209                                "ID NIL"
1210                              (concat "ID (" (mapconcat (lambda (el)
1211                                                          (concat "\"" el "\""))
1212                                                        list-of-values
1213                                                        " ") ")")))))
1214       imap-id)))
1215
1216 (defun imap-namespace (&optional buffer)
1217   "Return a namespace hierarchy at server in BUFFER.
1218 If BUFFER is nil, the current buffer is assumed."
1219   (with-current-buffer (or buffer (current-buffer))
1220     (unless imap-namespace
1221       (when (imap-capability 'NAMESPACE)
1222         (imap-send-command-wait "NAMESPACE")))
1223     imap-namespace))
1224
1225 (defun imap-send-command-wait (command &optional buffer)
1226   (imap-wait-for-tag (imap-send-command command buffer) buffer))
1227
1228 \f
1229 ;; Mailbox functions:
1230
1231 (defun imap-mailbox-put (propname value &optional mailbox buffer)
1232   (with-current-buffer (or buffer (current-buffer))
1233     (if imap-mailbox-data
1234         (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
1235              propname value)
1236       (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
1237              propname value mailbox (current-buffer)))
1238     t))
1239
1240 (defsubst imap-mailbox-get-1 (propname &optional mailbox)
1241   (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
1242        propname))
1243
1244 (defun imap-mailbox-get (propname &optional mailbox buffer)
1245   (let ((mailbox (imap-utf7-encode mailbox)))
1246     (with-current-buffer (or buffer (current-buffer))
1247       (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
1248
1249 (defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
1250   (with-current-buffer (or buffer (current-buffer))
1251     (let (result)
1252       (mapatoms
1253        (lambda (s)
1254          (push (funcall func (if mailbox-decoder
1255                                  (funcall mailbox-decoder (symbol-name s))
1256                                (symbol-name s))) result))
1257        imap-mailbox-data)
1258       result)))
1259
1260 (defun imap-mailbox-map (func &optional buffer)
1261   "Map a function across each mailbox in `imap-mailbox-data', returning a list.
1262 Function should take a mailbox name (a string) as
1263 the only argument."
1264   (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
1265
1266 (defun imap-current-mailbox (&optional buffer)
1267   (with-current-buffer (or buffer (current-buffer))
1268     (imap-utf7-decode imap-current-mailbox)))
1269
1270 (defun imap-current-mailbox-p-1 (mailbox &optional examine)
1271   (and (string= mailbox imap-current-mailbox)
1272        (or (and examine
1273                 (eq imap-state 'examine))
1274            (and (not examine)
1275                 (eq imap-state 'selected)))))
1276
1277 (defun imap-current-mailbox-p (mailbox &optional examine buffer)
1278   (with-current-buffer (or buffer (current-buffer))
1279     (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine)))
1280
1281 (defun imap-mailbox-select-1 (mailbox &optional examine)
1282   "Select MAILBOX on server in BUFFER.
1283 If EXAMINE is non-nil, do a read-only select."
1284   (if (imap-current-mailbox-p-1 mailbox examine)
1285       imap-current-mailbox
1286     (setq imap-current-mailbox mailbox)
1287     (if (imap-ok-p (imap-send-command-wait
1288                     (concat (if examine "EXAMINE" "SELECT") " \""
1289                             mailbox "\"")))
1290         (progn
1291           (setq imap-message-data (make-vector imap-message-prime 0)
1292                 imap-state (if examine 'examine 'selected))
1293           imap-current-mailbox)
1294       ;; Failed SELECT/EXAMINE unselects current mailbox
1295       (setq imap-current-mailbox nil))))
1296
1297 (defun imap-mailbox-select (mailbox &optional examine buffer)
1298   (with-current-buffer (or buffer (current-buffer))
1299     (imap-utf7-decode
1300      (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
1301
1302 (defun imap-mailbox-examine-1 (mailbox &optional buffer)
1303   (with-current-buffer (or buffer (current-buffer))
1304     (imap-mailbox-select-1 mailbox 'examine)))
1305
1306 (defun imap-mailbox-examine (mailbox &optional buffer)
1307   "Examine MAILBOX on server in BUFFER."
1308   (imap-mailbox-select mailbox 'examine buffer))
1309
1310 (defun imap-mailbox-unselect (&optional buffer)
1311   "Close current folder in BUFFER, without expunging articles."
1312   (with-current-buffer (or buffer (current-buffer))
1313     (when (or (eq imap-state 'auth)
1314               (and (imap-capability 'UNSELECT)
1315                    (imap-ok-p (imap-send-command-wait "UNSELECT")))
1316               (and (imap-ok-p
1317                     (imap-send-command-wait (concat "EXAMINE \""
1318                                                     imap-current-mailbox
1319                                                     "\"")))
1320                    (imap-ok-p (imap-send-command-wait "CLOSE"))))
1321       (setq imap-current-mailbox nil
1322             imap-message-data nil
1323             imap-state 'auth)
1324       t)))
1325
1326 (defun imap-mailbox-expunge (&optional asynch buffer)
1327   "Expunge articles in current folder in BUFFER.
1328 If ASYNCH, do not wait for succesful completion of the command.
1329 If BUFFER is nil the current buffer is assumed."
1330   (with-current-buffer (or buffer (current-buffer))
1331     (when (and imap-current-mailbox (not (eq imap-state 'examine)))
1332       (if asynch
1333           (imap-send-command "EXPUNGE")
1334       (imap-ok-p (imap-send-command-wait "EXPUNGE"))))))
1335
1336 (defun imap-mailbox-close (&optional asynch buffer)
1337   "Expunge articles and close current folder in BUFFER.
1338 If ASYNCH, do not wait for succesful completion of the command.
1339 If BUFFER is nil the current buffer is assumed."
1340   (with-current-buffer (or buffer (current-buffer))
1341     (when imap-current-mailbox
1342       (if asynch
1343           (imap-add-callback (imap-send-command "CLOSE")
1344                              `(lambda (tag status)
1345                                 (message "IMAP mailbox `%s' closed... %s"
1346                                          imap-current-mailbox status)
1347                                 (when (eq ,imap-current-mailbox
1348                                           imap-current-mailbox)
1349                                   ;; Don't wipe out data if another mailbox
1350                                   ;; was selected...
1351                                   (setq imap-current-mailbox nil
1352                                         imap-message-data nil
1353                                         imap-state 'auth))))
1354         (when (imap-ok-p (imap-send-command-wait "CLOSE"))
1355           (setq imap-current-mailbox nil
1356                 imap-message-data nil
1357                 imap-state 'auth)))
1358       t)))
1359
1360 (defun imap-mailbox-create-1 (mailbox)
1361   (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\""))))
1362
1363 (defun imap-mailbox-create (mailbox &optional buffer)
1364   "Create MAILBOX on server in BUFFER.
1365 If BUFFER is nil the current buffer is assumed."
1366   (with-current-buffer (or buffer (current-buffer))
1367     (imap-mailbox-create-1 (imap-utf7-encode mailbox))))
1368
1369 (defun imap-mailbox-delete (mailbox &optional buffer)
1370   "Delete MAILBOX on server in BUFFER.
1371 If BUFFER is nil the current buffer is assumed."
1372   (let ((mailbox (imap-utf7-encode mailbox)))
1373     (with-current-buffer (or buffer (current-buffer))
1374       (imap-ok-p
1375        (imap-send-command-wait (list "DELETE \"" mailbox "\""))))))
1376
1377 (defun imap-mailbox-rename (oldname newname &optional buffer)
1378   "Rename mailbox OLDNAME to NEWNAME on server in BUFFER.
1379 If BUFFER is nil the current buffer is assumed."
1380   (let ((oldname (imap-utf7-encode oldname))
1381         (newname (imap-utf7-encode newname)))
1382     (with-current-buffer (or buffer (current-buffer))
1383       (imap-ok-p
1384        (imap-send-command-wait (list "RENAME \"" oldname "\" "
1385                                      "\"" newname "\""))))))
1386
1387 (defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
1388   "Return a list of subscribed mailboxes on server in BUFFER.
1389 If ROOT is non-nil, only list matching mailboxes.  If ADD-DELIMITER is
1390 non-nil, a hierarchy delimiter is added to root.  REFERENCE is a
1391 implementation-specific string that has to be passed to lsub command."
1392   (with-current-buffer (or buffer (current-buffer))
1393     ;; Make sure we know the hierarchy separator for root's hierarchy
1394     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1395       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1396                                       (imap-utf7-encode root) "\"")))
1397     ;; clear list data (NB not delimiter and other stuff)
1398     (imap-mailbox-map-1 (lambda (mailbox)
1399                           (imap-mailbox-put 'lsub nil mailbox)))
1400     (when (imap-ok-p
1401            (imap-send-command-wait
1402             (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root)
1403                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1404                     "%\"")))
1405       (let (out)
1406         (imap-mailbox-map-1 (lambda (mailbox)
1407                               (when (imap-mailbox-get-1 'lsub mailbox)
1408                                 (push (imap-utf7-decode mailbox) out))))
1409         (nreverse out)))))
1410
1411 (defun imap-mailbox-list (root &optional reference add-delimiter buffer)
1412   "Return a list of mailboxes matching ROOT on server in BUFFER.
1413 If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
1414 root.  REFERENCE is a implementation-specific string that has to be
1415 passed to list command."
1416   (with-current-buffer (or buffer (current-buffer))
1417     ;; Make sure we know the hierarchy separator for root's hierarchy
1418     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1419       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1420                                       (imap-utf7-encode root) "\"")))
1421     ;; clear list data (NB not delimiter and other stuff)
1422     (imap-mailbox-map-1 (lambda (mailbox)
1423                           (imap-mailbox-put 'list nil mailbox)))
1424     (when (imap-ok-p
1425            (imap-send-command-wait
1426             (concat "LIST \"" reference "\" \"" (imap-utf7-encode root)
1427                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1428                     "%\"")))
1429       (let (out)
1430         (imap-mailbox-map-1 (lambda (mailbox)
1431                               (when (imap-mailbox-get-1 'list mailbox)
1432                                 (push (imap-utf7-decode mailbox) out))))
1433         (nreverse out)))))
1434
1435 (defun imap-mailbox-subscribe (mailbox &optional buffer)
1436   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1437 Returns non-nil if successful."
1438   (with-current-buffer (or buffer (current-buffer))
1439     (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
1440                                                (imap-utf7-encode mailbox)
1441                                                "\"")))))
1442
1443 (defun imap-mailbox-unsubscribe (mailbox &optional buffer)
1444   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1445 Returns non-nil if successful."
1446   (with-current-buffer (or buffer (current-buffer))
1447     (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
1448                                                (imap-utf7-encode mailbox)
1449                                                "\"")))))
1450
1451 (defun imap-mailbox-status (mailbox items &optional buffer)
1452   "Get status items ITEM in MAILBOX from server in BUFFER.
1453 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1454 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1455 or 'unseen.  If ITEMS is a list of symbols, a list of values is
1456 returned, if ITEMS is a symbol only its value is returned."
1457   (with-current-buffer (or buffer (current-buffer))
1458     (when (imap-ok-p
1459            (imap-send-command-wait (list "STATUS \""
1460                                          (imap-utf7-encode mailbox)
1461                                          "\" "
1462                                          (upcase
1463                                           (format "%s"
1464                                                   (if (listp items)
1465                                                       items
1466                                                     (list items)))))))
1467       (if (listp items)
1468           (mapcar (lambda (item)
1469                     (imap-mailbox-get item mailbox))
1470                   items)
1471         (imap-mailbox-get items mailbox)))))
1472
1473 (defun imap-mailbox-status-asynch (mailbox items &optional buffer)
1474   "Send status item request ITEM on MAILBOX to server in BUFFER.
1475 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1476 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1477 or 'unseen.  The IMAP command tag is returned."
1478   (with-current-buffer (or buffer (current-buffer))
1479     (imap-send-command (list "STATUS \""
1480                              (imap-utf7-encode mailbox)
1481                              "\" "
1482                              (format "%s"
1483                                      (if (listp items)
1484                                          items
1485                                        (list items)))))))
1486
1487 (defun imap-mailbox-acl-get (&optional mailbox buffer)
1488   "Get ACL on mailbox from server in BUFFER."
1489   (let ((mailbox (imap-utf7-encode mailbox)))
1490     (with-current-buffer (or buffer (current-buffer))
1491       (when (imap-ok-p
1492              (imap-send-command-wait (list "GETACL \""
1493                                            (or mailbox imap-current-mailbox)
1494                                            "\"")))
1495         (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox))))))
1496
1497 (defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer)
1498   "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER."
1499   (let ((mailbox (imap-utf7-encode mailbox)))
1500     (with-current-buffer (or buffer (current-buffer))
1501       (imap-ok-p
1502        (imap-send-command-wait (list "SETACL \""
1503                                      (or mailbox imap-current-mailbox)
1504                                      "\" "
1505                                      identifier
1506                                      " "
1507                                      rights))))))
1508
1509 (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
1510   "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER."
1511   (let ((mailbox (imap-utf7-encode mailbox)))
1512     (with-current-buffer (or buffer (current-buffer))
1513       (imap-ok-p
1514        (imap-send-command-wait (list "DELETEACL \""
1515                                      (or mailbox imap-current-mailbox)
1516                                      "\" "
1517                                      identifier))))))
1518
1519 \f
1520 ;; Message functions:
1521
1522 (defun imap-current-message (&optional buffer)
1523   (with-current-buffer (or buffer (current-buffer))
1524     imap-current-message))
1525
1526 (defun imap-list-to-message-set (list)
1527   (mapconcat (lambda (item)
1528                (number-to-string item))
1529              (if (listp list)
1530                  list
1531                (list list))
1532              ","))
1533
1534 (defun imap-range-to-message-set (range)
1535   (mapconcat
1536    (lambda (item)
1537      (if (consp item)
1538          (format "%d:%d"
1539                  (car item) (cdr item))
1540        (format "%d" item)))
1541    (if (and (listp range) (not (listp (cdr range))))
1542        (list range) ;; make (1 . 2) into ((1 . 2))
1543      range)
1544    ","))
1545
1546 (defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
1547   (with-current-buffer (or buffer (current-buffer))
1548     (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1549                                (if (listp uids)
1550                                    (imap-list-to-message-set uids)
1551                                  uids)
1552                                props))))
1553
1554 (defun imap-fetch (uids props &optional receive nouidfetch buffer)
1555   "Fetch properties PROPS from message set UIDS from server in BUFFER.
1556 UIDS can be a string, number or a list of numbers.  If RECEIVE
1557 is non-nil return these properties."
1558   (with-current-buffer (or buffer (current-buffer))
1559     (when (imap-ok-p (imap-send-command-wait
1560                       (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1561                               (if (listp uids)
1562                                   (imap-list-to-message-set uids)
1563                                 uids)
1564                               props)))
1565       (if (or (null receive) (stringp uids))
1566           t
1567         (if (listp uids)
1568             (mapcar (lambda (uid)
1569                       (if (listp receive)
1570                           (mapcar (lambda (prop)
1571                                     (imap-message-get uid prop))
1572                                   receive)
1573                         (imap-message-get uid receive)))
1574                     uids)
1575           (imap-message-get uids receive))))))
1576
1577 (defun imap-message-put (uid propname value &optional buffer)
1578   (with-current-buffer (or buffer (current-buffer))
1579     (if imap-message-data
1580         (put (intern (number-to-string uid) imap-message-data)
1581              propname value)
1582       (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
1583              uid propname value (current-buffer)))
1584     t))
1585
1586 (defun imap-message-get (uid propname &optional buffer)
1587   (with-current-buffer (or buffer (current-buffer))
1588     (get (intern-soft (number-to-string uid) imap-message-data)
1589          propname)))
1590
1591 (defun imap-message-map (func propname &optional buffer)
1592   "Map a function across each mailbox in `imap-message-data', returning a list."
1593   (with-current-buffer (or buffer (current-buffer))
1594     (let (result)
1595       (mapatoms
1596        (lambda (s)
1597          (push (funcall func (get s 'UID) (get s propname)) result))
1598        imap-message-data)
1599       result)))
1600
1601 (defmacro imap-message-envelope-date (uid &optional buffer)
1602   `(with-current-buffer (or ,buffer (current-buffer))
1603      (elt (imap-message-get ,uid 'ENVELOPE) 0)))
1604
1605 (defmacro imap-message-envelope-subject (uid &optional buffer)
1606   `(with-current-buffer (or ,buffer (current-buffer))
1607      (elt (imap-message-get ,uid 'ENVELOPE) 1)))
1608
1609 (defmacro imap-message-envelope-from (uid &optional buffer)
1610   `(with-current-buffer (or ,buffer (current-buffer))
1611      (elt (imap-message-get ,uid 'ENVELOPE) 2)))
1612
1613 (defmacro imap-message-envelope-sender (uid &optional buffer)
1614   `(with-current-buffer (or ,buffer (current-buffer))
1615      (elt (imap-message-get ,uid 'ENVELOPE) 3)))
1616
1617 (defmacro imap-message-envelope-reply-to (uid &optional buffer)
1618   `(with-current-buffer (or ,buffer (current-buffer))
1619      (elt (imap-message-get ,uid 'ENVELOPE) 4)))
1620
1621 (defmacro imap-message-envelope-to (uid &optional buffer)
1622   `(with-current-buffer (or ,buffer (current-buffer))
1623      (elt (imap-message-get ,uid 'ENVELOPE) 5)))
1624
1625 (defmacro imap-message-envelope-cc (uid &optional buffer)
1626   `(with-current-buffer (or ,buffer (current-buffer))
1627      (elt (imap-message-get ,uid 'ENVELOPE) 6)))
1628
1629 (defmacro imap-message-envelope-bcc (uid &optional buffer)
1630   `(with-current-buffer (or ,buffer (current-buffer))
1631      (elt (imap-message-get ,uid 'ENVELOPE) 7)))
1632
1633 (defmacro imap-message-envelope-in-reply-to (uid &optional buffer)
1634   `(with-current-buffer (or ,buffer (current-buffer))
1635      (elt (imap-message-get ,uid 'ENVELOPE) 8)))
1636
1637 (defmacro imap-message-envelope-message-id (uid &optional buffer)
1638   `(with-current-buffer (or ,buffer (current-buffer))
1639      (elt (imap-message-get ,uid 'ENVELOPE) 9)))
1640
1641 (defmacro imap-message-body (uid &optional buffer)
1642   `(with-current-buffer (or ,buffer (current-buffer))
1643      (imap-message-get ,uid 'BODY)))
1644
1645 (defun imap-search (predicate &optional buffer)
1646   (with-current-buffer (or buffer (current-buffer))
1647     (imap-mailbox-put 'search 'dummy)
1648     (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
1649       (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
1650           (progn
1651             (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...")
1652             nil)
1653         (imap-mailbox-get-1 'search imap-current-mailbox)))))
1654
1655 (defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
1656   "Return t iff FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
1657   (with-current-buffer (or buffer (current-buffer))
1658     (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
1659         (member flag (imap-mailbox-get 'permanentflags mailbox)))))
1660
1661 (defun imap-message-flags-set (articles flags &optional silent buffer)
1662   (when (and articles flags)
1663     (with-current-buffer (or buffer (current-buffer))
1664       (imap-ok-p (imap-send-command-wait
1665                   (concat "UID STORE " articles
1666                           " FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1667
1668 (defun imap-message-flags-del (articles flags &optional silent buffer)
1669   (when (and articles flags)
1670     (with-current-buffer (or buffer (current-buffer))
1671       (imap-ok-p (imap-send-command-wait
1672                   (concat "UID STORE " articles
1673                           " -FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1674
1675 (defun imap-message-flags-add (articles flags &optional silent buffer)
1676   (when (and articles flags)
1677     (with-current-buffer (or buffer (current-buffer))
1678       (imap-ok-p (imap-send-command-wait
1679                   (concat "UID STORE " articles
1680                           " +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1681
1682 (defun imap-message-copyuid-1 (mailbox)
1683   (if (imap-capability 'UIDPLUS)
1684       (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
1685             (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
1686     (let ((old-mailbox imap-current-mailbox)
1687           (state imap-state)
1688           (imap-message-data (make-vector 2 0)))
1689       (when (imap-mailbox-examine-1 mailbox)
1690         (prog1
1691             (and (imap-fetch "*" "UID")
1692                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
1693                        (apply 'max (imap-message-map
1694                                     (lambda (uid prop) uid) 'UID))))
1695           (if old-mailbox
1696               (imap-mailbox-select old-mailbox (eq state 'examine))
1697             (imap-mailbox-unselect)))))))
1698
1699 (defun imap-message-copyuid (mailbox &optional buffer)
1700   (with-current-buffer (or buffer (current-buffer))
1701     (imap-message-copyuid-1 (imap-utf7-decode mailbox))))
1702
1703 (defun imap-message-copy (articles mailbox
1704                                    &optional dont-create no-copyuid buffer)
1705   "Copy ARTICLES (a string message set) to MAILBOX on server in
1706 BUFFER, creating mailbox if it doesn't exist.  If dont-create is
1707 non-nil, it will not create a mailbox.  On success, return a list with
1708 the UIDVALIDITY of the mailbox the article(s) was copied to as the
1709 first element, rest of list contain the saved articles' UIDs."
1710   (when articles
1711     (with-current-buffer (or buffer (current-buffer))
1712       (let ((mailbox (imap-utf7-encode mailbox)))
1713         (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\""))
1714                   (imap-current-target-mailbox mailbox))
1715               (if (imap-ok-p (imap-send-command-wait cmd))
1716                   t
1717                 (when (and (not dont-create)
1718                            ;; removed because of buggy Oracle server
1719                            ;; that doesn't send TRYCREATE tags (which
1720                            ;; is a MUST according to specifications):
1721                            ;;(imap-mailbox-get-1 'trycreate mailbox)
1722                            (imap-mailbox-create-1 mailbox))
1723                   (imap-ok-p (imap-send-command-wait cmd)))))
1724             (or no-copyuid
1725                 (imap-message-copyuid-1 mailbox)))))))
1726
1727 (defun imap-message-appenduid-1 (mailbox)
1728   (if (imap-capability 'UIDPLUS)
1729       (imap-mailbox-get-1 'appenduid mailbox)
1730     (let ((old-mailbox imap-current-mailbox)
1731           (state imap-state)
1732           (imap-message-data (make-vector 2 0)))
1733       (when (imap-mailbox-examine-1 mailbox)
1734         (prog1
1735             (and (imap-fetch "*" "UID")
1736                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
1737                        (apply 'max (imap-message-map
1738                                     (lambda (uid prop) uid) 'UID))))
1739           (if old-mailbox
1740               (imap-mailbox-select old-mailbox (eq state 'examine))
1741             (imap-mailbox-unselect)))))))
1742
1743 (defun imap-message-appenduid (mailbox &optional buffer)
1744   (with-current-buffer (or buffer (current-buffer))
1745     (imap-message-appenduid-1 (imap-utf7-encode mailbox))))
1746
1747 (defun imap-message-append (mailbox article &optional flags date-time buffer)
1748   "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER.
1749 FLAGS and DATE-TIME is currently not used.  Return a cons holding
1750 uidvalidity of MAILBOX and UID the newly created article got, or nil
1751 on failure."
1752   (let ((mailbox (imap-utf7-encode mailbox)))
1753     (with-current-buffer (or buffer (current-buffer))
1754       (and (let ((imap-current-target-mailbox mailbox))
1755              (imap-ok-p
1756               (imap-send-command-wait
1757                (list "APPEND \"" mailbox "\" "  article))))
1758            (imap-message-appenduid-1 mailbox)))))
1759
1760 (defun imap-body-lines (body)
1761   "Return number of lines in article by looking at the mime bodystructure BODY."
1762   (if (listp body)
1763       (if (stringp (car body))
1764           (cond ((and (string= (upcase (car body)) "TEXT")
1765                       (numberp (nth 7 body)))
1766                  (nth 7 body))
1767                 ((and (string= (upcase (car body)) "MESSAGE")
1768                       (numberp (nth 9 body)))
1769                  (nth 9 body))
1770                 (t 0))
1771         (apply '+ (mapcar 'imap-body-lines body)))
1772     0))
1773
1774 (defun imap-envelope-from (from)
1775   "Return a from string line."
1776   (and from
1777        (concat (aref from 0)
1778                (if (aref from 0) " <")
1779                (aref from 2)
1780                "@"
1781                (aref from 3)
1782                (if (aref from 0) ">"))))
1783
1784 \f
1785 ;; Internal functions.
1786
1787 (defun imap-add-callback (tag func)
1788   (setq imap-callbacks (append (list (cons tag func)) imap-callbacks)))
1789
1790 (defun imap-send-command-1 (cmdstr)
1791   (setq cmdstr (concat cmdstr imap-client-eol))
1792   (and imap-log
1793        (with-current-buffer (get-buffer-create imap-log-buffer)
1794          (imap-disable-multibyte)
1795          (buffer-disable-undo)
1796          (goto-char (point-max))
1797          (insert cmdstr)))
1798   (process-send-string imap-process cmdstr))
1799
1800 (defun imap-send-command (command &optional buffer)
1801   (with-current-buffer (or buffer (current-buffer))
1802     (if (not (listp command)) (setq command (list command)))
1803     (let ((tag (setq imap-tag (1+ imap-tag)))
1804           cmd cmdstr)
1805       (setq cmdstr (concat (number-to-string imap-tag) " "))
1806       (while (setq cmd (pop command))
1807         (cond ((stringp cmd)
1808                (setq cmdstr (concat cmdstr cmd)))
1809               ((bufferp cmd)
1810                (let ((eol imap-client-eol)
1811                      (calcfirst imap-calculate-literal-size-first)
1812                      size)
1813                  (with-current-buffer cmd
1814                    (if calcfirst
1815                        (setq size (buffer-size)))
1816                    (when (not (equal eol "\r\n"))
1817                      ;; XXX modifies buffer!
1818                      (goto-char (point-min))
1819                      (while (search-forward "\r\n" nil t)
1820                        (replace-match eol)))
1821                    (if (not calcfirst)
1822                        (setq size (buffer-size))))
1823                  (setq cmdstr
1824                        (concat cmdstr (format "{%d}" size))))
1825                (unwind-protect
1826                    (progn
1827                      (imap-send-command-1 cmdstr)
1828                      (setq cmdstr nil)
1829                      (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1830                          (setq command nil) ;; abort command if no cont-req
1831                        (let ((process imap-process)
1832                              (stream imap-stream)
1833                              (eol imap-client-eol))
1834                          (with-current-buffer cmd
1835                            (and imap-log
1836                                 (with-current-buffer (get-buffer-create
1837                                                       imap-log-buffer)
1838                                   (imap-disable-multibyte)
1839                                   (buffer-disable-undo)
1840                                   (goto-char (point-max))
1841                                   (insert-buffer-substring cmd)))
1842                            (process-send-region process (point-min)
1843                                                 (point-max)))
1844                          (process-send-string process imap-client-eol))))
1845                  (setq imap-continuation nil)))
1846               ((functionp cmd)
1847                (imap-send-command-1 cmdstr)
1848                (setq cmdstr nil)
1849                (unwind-protect
1850                    (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1851                        (setq command nil) ;; abort command if no cont-req
1852                      (setq command (cons (funcall cmd imap-continuation)
1853                                          command)))
1854                  (setq imap-continuation nil)))
1855               (t
1856                (error "Unknown command type"))))
1857       (if cmdstr
1858           (imap-send-command-1 cmdstr))
1859       tag)))
1860
1861 (defun imap-wait-for-tag (tag &optional buffer)
1862   (with-current-buffer (or buffer (current-buffer))
1863     (let (imap-have-messaged)
1864       (while (and (null imap-continuation)
1865                   (memq (process-status imap-process) '(open run))
1866                   (< imap-reached-tag tag))
1867         (let ((len (/ (point-max) 1024))
1868               message-log-max)
1869           (unless (< len 10)
1870             (setq imap-have-messaged t)
1871             (message "imap read: %dk" len))
1872           (accept-process-output imap-process
1873                                  (truncate imap-read-timeout)
1874                                  (truncate (* (- imap-read-timeout
1875                                                  (truncate imap-read-timeout))
1876                                               1000)))))
1877       ;; A process can die _before_ we have processed everything it
1878       ;; has to say.  Moreover, this can happen in between the call to
1879       ;; accept-process-output and the call to process-status in an
1880       ;; iteration of the loop above.
1881       (when (and (null imap-continuation)
1882                  (< imap-reached-tag tag))
1883         (accept-process-output imap-process 0 0))
1884       (when imap-have-messaged
1885         (message ""))
1886       (and (memq (process-status imap-process) '(open run))
1887            (or (assq tag imap-failed-tags)
1888                (if imap-continuation
1889                    'INCOMPLETE
1890                  'OK))))))
1891
1892 (defun imap-sentinel (process string)
1893   (delete-process process))
1894
1895 (defun imap-find-next-line ()
1896   "Return point at end of current line, taking into account literals.
1897 Return nil if no complete line has arrived."
1898   (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}"
1899                                    imap-server-eol)
1900                            nil t)
1901     (if (match-string 1)
1902         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1903             nil
1904           (goto-char (+ (point) (string-to-number (match-string 1))))
1905           (imap-find-next-line))
1906       (point))))
1907
1908 (defun imap-arrival-filter (proc string)
1909   "IMAP process filter."
1910   ;; Sometimes, we are called even though the process has died.
1911   ;; Better abstain from doing stuff in that case.
1912   (when (buffer-name (process-buffer proc))
1913     (with-current-buffer (process-buffer proc)
1914       (goto-char (point-max))
1915       (insert string)
1916       (and imap-log
1917            (with-current-buffer (get-buffer-create imap-log-buffer)
1918              (imap-disable-multibyte)
1919              (buffer-disable-undo)
1920              (goto-char (point-max))
1921              (insert string)))
1922       (let (end)
1923         (goto-char (point-min))
1924         (while (setq end (imap-find-next-line))
1925           (save-restriction
1926             (narrow-to-region (point-min) end)
1927             (delete-backward-char (length imap-server-eol))
1928             (goto-char (point-min))
1929             (unwind-protect
1930                 (cond ((eq imap-state 'initial)
1931                        (imap-parse-greeting))
1932                       ((or (eq imap-state 'auth)
1933                            (eq imap-state 'nonauth)
1934                            (eq imap-state 'selected)
1935                            (eq imap-state 'examine))
1936                        (imap-parse-response))
1937                       (t
1938                        (message "Unknown state %s in arrival filter"
1939                                 imap-state)))
1940               (delete-region (point-min) (point-max)))))))))
1941
1942 \f
1943 ;; Imap parser.
1944
1945 (defsubst imap-forward ()
1946   (or (eobp) (forward-char)))
1947
1948 ;;   number          = 1*DIGIT
1949 ;;                       ; Unsigned 32-bit integer
1950 ;;                       ; (0 <= n < 4,294,967,296)
1951
1952 (defsubst imap-parse-number ()
1953   (when (looking-at "[0-9]+")
1954     (prog1
1955         (string-to-number (match-string 0))
1956       (goto-char (match-end 0)))))
1957
1958 ;;   literal         = "{" number "}" CRLF *CHAR8
1959 ;;                       ; Number represents the number of CHAR8s
1960
1961 (defsubst imap-parse-literal ()
1962   (when (looking-at "{\\([0-9]+\\)}\r\n")
1963     (let ((pos (match-end 0))
1964           (len (string-to-number (match-string 1))))
1965       (if (< (point-max) (+ pos len))
1966           nil
1967         (goto-char (+ pos len))
1968         (buffer-substring pos (+ pos len))))))
1969
1970 ;;   string          = quoted / literal
1971 ;;
1972 ;;   quoted          = DQUOTE *QUOTED-CHAR DQUOTE
1973 ;;
1974 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
1975 ;;                     "\" quoted-specials
1976 ;;
1977 ;;   quoted-specials = DQUOTE / "\"
1978 ;;
1979 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
1980
1981 (defsubst imap-parse-string ()
1982   (cond ((eq (char-after) ?\")
1983          (forward-char 1)
1984          (let ((p (point)) (name ""))
1985            (skip-chars-forward "^\"\\\\")
1986            (setq name (buffer-substring p (point)))
1987            (while (eq (char-after) ?\\)
1988              (setq p (1+ (point)))
1989              (forward-char 2)
1990              (skip-chars-forward "^\"\\\\")
1991              (setq name (concat name (buffer-substring p (point)))))
1992            (forward-char 1)
1993            name))
1994         ((eq (char-after) ?{)
1995          (imap-parse-literal))))
1996
1997 ;;   nil             = "NIL"
1998
1999 (defsubst imap-parse-nil ()
2000   (if (looking-at "NIL")
2001       (goto-char (match-end 0))))
2002
2003 ;;   nstring         = string / nil
2004
2005 (defsubst imap-parse-nstring ()
2006   (or (imap-parse-string)
2007       (and (imap-parse-nil)
2008            nil)))
2009
2010 ;;   astring         = atom / string
2011 ;;
2012 ;;   atom            = 1*ATOM-CHAR
2013 ;;
2014 ;;   ATOM-CHAR       = <any CHAR except atom-specials>
2015 ;;
2016 ;;   atom-specials   = "(" / ")" / "{" / SP / CTL / list-wildcards /
2017 ;;                     quoted-specials
2018 ;;
2019 ;;   list-wildcards  = "%" / "*"
2020 ;;
2021 ;;   quoted-specials = DQUOTE / "\"
2022
2023 (defsubst imap-parse-astring ()
2024   (or (imap-parse-string)
2025       (buffer-substring (point)
2026                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
2027                             (goto-char (1- (match-end 0)))
2028                           (end-of-line)
2029                           (point)))))
2030
2031 ;;   address         = "(" addr-name SP addr-adl SP addr-mailbox SP
2032 ;;                      addr-host ")"
2033 ;;
2034 ;;   addr-adl        = nstring
2035 ;;                       ; Holds route from [RFC-822] route-addr if
2036 ;;                       ; non-nil
2037 ;;
2038 ;;   addr-host       = nstring
2039 ;;                       ; nil indicates [RFC-822] group syntax.
2040 ;;                       ; Otherwise, holds [RFC-822] domain name
2041 ;;
2042 ;;   addr-mailbox    = nstring
2043 ;;                       ; nil indicates end of [RFC-822] group; if
2044 ;;                       ; non-nil and addr-host is nil, holds
2045 ;;                       ; [RFC-822] group name.
2046 ;;                       ; Otherwise, holds [RFC-822] local-part
2047 ;;                       ; after removing [RFC-822] quoting
2048 ;;
2049 ;;   addr-name       = nstring
2050 ;;                       ; If non-nil, holds phrase from [RFC-822]
2051 ;;                       ; mailbox after removing [RFC-822] quoting
2052 ;;
2053
2054 (defsubst imap-parse-address ()
2055   (let (address)
2056     (when (eq (char-after) ?\()
2057       (imap-forward)
2058       (setq address (vector (prog1 (imap-parse-nstring)
2059                               (imap-forward))
2060                             (prog1 (imap-parse-nstring)
2061                               (imap-forward))
2062                             (prog1 (imap-parse-nstring)
2063                               (imap-forward))
2064                             (imap-parse-nstring)))
2065       (when (eq (char-after) ?\))
2066         (imap-forward)
2067         address))))
2068
2069 ;;   address-list    = "(" 1*address ")" / nil
2070 ;;
2071 ;;   nil             = "NIL"
2072
2073 (defsubst imap-parse-address-list ()
2074   (if (eq (char-after) ?\()
2075       (let (address addresses)
2076         (imap-forward)
2077         (while (and (not (eq (char-after) ?\)))
2078                     ;; next line for MS Exchange bug
2079                     (progn (and (eq (char-after) ? ) (imap-forward)) t)
2080                     (setq address (imap-parse-address)))
2081           (setq addresses (cons address addresses)))
2082         (when (eq (char-after) ?\))
2083           (imap-forward)
2084           (nreverse addresses)))
2085     ;; With assert, the code might not be eval'd.
2086     ;; (assert (imap-parse-nil) t "In imap-parse-address-list")
2087     (imap-parse-nil)))
2088
2089 ;;   mailbox         = "INBOX" / astring
2090 ;;                       ; INBOX is case-insensitive.  All case variants of
2091 ;;                       ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX
2092 ;;                       ; not as an astring.  An astring which consists of
2093 ;;                       ; the case-insensitive sequence "I" "N" "B" "O" "X"
2094 ;;                       ; is considered to be INBOX and not an astring.
2095 ;;                       ;  Refer to section 5.1 for further
2096 ;;                       ; semantic details of mailbox names.
2097
2098 (defsubst imap-parse-mailbox ()
2099   (let ((mailbox (imap-parse-astring)))
2100     (if (string-equal "INBOX" (upcase mailbox))
2101         "INBOX"
2102       mailbox)))
2103
2104 ;;   greeting        = "*" SP (resp-cond-auth / resp-cond-bye) CRLF
2105 ;;
2106 ;;   resp-cond-auth  = ("OK" / "PREAUTH") SP resp-text
2107 ;;                       ; Authentication condition
2108 ;;
2109 ;;   resp-cond-bye   = "BYE" SP resp-text
2110
2111 (defun imap-parse-greeting ()
2112   "Parse a IMAP greeting."
2113   (cond ((looking-at "\\* OK ")
2114          (setq imap-state 'nonauth))
2115         ((looking-at "\\* PREAUTH ")
2116          (setq imap-state 'auth))
2117         ((looking-at "\\* BYE ")
2118          (setq imap-state 'closed))))
2119
2120 ;;   response        = *(continue-req / response-data) response-done
2121 ;;
2122 ;;   continue-req    = "+" SP (resp-text / base64) CRLF
2123 ;;
2124 ;;   response-data   = "*" SP (resp-cond-state / resp-cond-bye /
2125 ;;                     mailbox-data / message-data / capability-data) CRLF
2126 ;;
2127 ;;   response-done   = response-tagged / response-fatal
2128 ;;
2129 ;;   response-fatal  = "*" SP resp-cond-bye CRLF
2130 ;;                       ; Server closes connection immediately
2131 ;;
2132 ;;   response-tagged = tag SP resp-cond-state CRLF
2133 ;;
2134 ;;   resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text
2135 ;;                       ; Status condition
2136 ;;
2137 ;;   resp-cond-bye   = "BYE" SP resp-text
2138 ;;
2139 ;;   mailbox-data    =  "FLAGS" SP flag-list /
2140 ;;                      "LIST" SP mailbox-list /
2141 ;;                      "LSUB" SP mailbox-list /
2142 ;;                      "SEARCH" *(SP nz-number) /
2143 ;;                      "STATUS" SP mailbox SP "("
2144 ;;                            [status-att SP number *(SP status-att SP number)] ")" /
2145 ;;                      number SP "EXISTS" /
2146 ;;                      number SP "RECENT"
2147 ;;
2148 ;;   message-data    = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att))
2149 ;;
2150 ;;   capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1"
2151 ;;                     *(SP capability)
2152 ;;                       ; IMAP4rev1 servers which offer RFC 1730
2153 ;;                       ; compatibility MUST list "IMAP4" as the first
2154 ;;                       ; capability.
2155
2156 (defun imap-parse-response ()
2157   "Parse a IMAP command response."
2158   (let (token)
2159     (case (setq token (read (current-buffer)))
2160       (+ (setq imap-continuation
2161                (or (buffer-substring (min (point-max) (1+ (point)))
2162                                      (point-max))
2163                    t)))
2164       (* (case (prog1 (setq token (read (current-buffer)))
2165                  (imap-forward))
2166            (OK         (imap-parse-resp-text))
2167            (NO         (imap-parse-resp-text))
2168            (BAD        (imap-parse-resp-text))
2169            (BYE        (imap-parse-resp-text))
2170            (FLAGS      (imap-mailbox-put 'flags (imap-parse-flag-list)))
2171            (LIST       (imap-parse-data-list 'list))
2172            (LSUB       (imap-parse-data-list 'lsub))
2173            (SEARCH     (imap-mailbox-put
2174                         'search
2175                         (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
2176            (STATUS     (imap-parse-status))
2177            (CAPABILITY (setq imap-capability
2178                                (read (concat "(" (upcase (buffer-substring
2179                                                           (point) (point-max)))
2180                                              ")"))))
2181            (ID         (setq imap-id (read (buffer-substring (point)
2182                                                              (point-max)))))
2183            (ACL        (imap-parse-acl))
2184            (t       (case (prog1 (read (current-buffer))
2185                             (imap-forward))
2186                       (EXISTS  (imap-mailbox-put 'exists token))
2187                       (RECENT  (imap-mailbox-put 'recent token))
2188                       (EXPUNGE t)
2189                       (FETCH   (imap-parse-fetch token))
2190                       (t       (message "Garbage: %s" (buffer-string)))))))
2191       (t (let (status)
2192            (if (not (integerp token))
2193                (message "Garbage: %s" (buffer-string))
2194              (case (prog1 (setq status (read (current-buffer)))
2195                      (imap-forward))
2196                (OK  (progn
2197                       (setq imap-reached-tag (max imap-reached-tag token))
2198                       (imap-parse-resp-text)))
2199                (NO  (progn
2200                       (setq imap-reached-tag (max imap-reached-tag token))
2201                       (save-excursion
2202                         (imap-parse-resp-text))
2203                       (let (code text)
2204                         (when (eq (char-after) ?\[)
2205                           (setq code (buffer-substring (point)
2206                                                        (search-forward "]")))
2207                           (imap-forward))
2208                         (setq text (buffer-substring (point) (point-max)))
2209                         (push (list token status code text)
2210                               imap-failed-tags))))
2211                (BAD (progn
2212                       (setq imap-reached-tag (max imap-reached-tag token))
2213                       (save-excursion
2214                         (imap-parse-resp-text))
2215                       (let (code text)
2216                         (when (eq (char-after) ?\[)
2217                           (setq code (buffer-substring (point)
2218                                                        (search-forward "]")))
2219                           (imap-forward))
2220                         (setq text (buffer-substring (point) (point-max)))
2221                         (push (list token status code text) imap-failed-tags)
2222                         (error "Internal error, tag %s status %s code %s text %s"
2223                                token status code text))))
2224                (t   (message "Garbage: %s" (buffer-string))))
2225              (when (assq token imap-callbacks)
2226                (funcall (cdr (assq token imap-callbacks)) token status)
2227                (setq imap-callbacks
2228                      (imap-remassoc token imap-callbacks)))))))))
2229
2230 ;;   resp-text       = ["[" resp-text-code "]" SP] text
2231 ;;
2232 ;;   text            = 1*TEXT-CHAR
2233 ;;
2234 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
2235
2236 (defun imap-parse-resp-text ()
2237   (imap-parse-resp-text-code))
2238
2239 ;;   resp-text-code  = "ALERT" /
2240 ;;                     "BADCHARSET [SP "(" astring *(SP astring) ")" ] /
2241 ;;                     "NEWNAME" SP string SP string /
2242 ;;                     "PARSE" /
2243 ;;                     "PERMANENTFLAGS" SP "("
2244 ;;                               [flag-perm *(SP flag-perm)] ")" /
2245 ;;                     "READ-ONLY" /
2246 ;;                     "READ-WRITE" /
2247 ;;                     "TRYCREATE" /
2248 ;;                     "UIDNEXT" SP nz-number /
2249 ;;                     "UIDVALIDITY" SP nz-number /
2250 ;;                     "UNSEEN" SP nz-number /
2251 ;;                     resp-text-atom [SP 1*<any TEXT-CHAR except "]">]
2252 ;;
2253 ;;   resp_code_apnd  = "APPENDUID" SPACE nz_number SPACE uniqueid
2254 ;;
2255 ;;   resp_code_copy  = "COPYUID" SPACE nz_number SPACE set SPACE set
2256 ;;
2257 ;;   set             = sequence-num / (sequence-num ":" sequence-num) /
2258 ;;                        (set "," set)
2259 ;;                          ; Identifies a set of messages.  For message
2260 ;;                          ; sequence numbers, these are consecutive
2261 ;;                          ; numbers from 1 to the number of messages in
2262 ;;                          ; the mailbox
2263 ;;                          ; Comma delimits individual numbers, colon
2264 ;;                          ; delimits between two numbers inclusive.
2265 ;;                          ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13,
2266 ;;                          ; 14,15 for a mailbox with 15 messages.
2267 ;;
2268 ;;   sequence-num    = nz-number / "*"
2269 ;;                          ; * is the largest number in use.  For message
2270 ;;                          ; sequence numbers, it is the number of messages
2271 ;;                          ; in the mailbox.  For unique identifiers, it is
2272 ;;                          ; the unique identifier of the last message in
2273 ;;                          ; the mailbox.
2274 ;;
2275 ;;   flag-perm       = flag / "\*"
2276 ;;
2277 ;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
2278 ;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
2279 ;;                       ; Does not include "\Recent"
2280 ;;
2281 ;;   flag-extension  = "\" atom
2282 ;;                       ; Future expansion.  Client implementations
2283 ;;                       ; MUST accept flag-extension flags.  Server
2284 ;;                       ; implementations MUST NOT generate
2285 ;;                       ; flag-extension flags except as defined by
2286 ;;                       ; future standard or standards-track
2287 ;;                       ; revisions of this specification.
2288 ;;
2289 ;;   flag-keyword    = atom
2290 ;;
2291 ;;   resp-text-atom  = 1*<any ATOM-CHAR except "]">
2292
2293 (defun imap-parse-resp-text-code ()
2294   ;; xxx next line for stalker communigate pro 3.3.1 bug
2295   (when (looking-at " \\[")
2296     (imap-forward))
2297   (when (eq (char-after) ?\[)
2298     (imap-forward)
2299     (cond ((search-forward "PERMANENTFLAGS " nil t)
2300            (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))
2301           ((search-forward "UIDNEXT \\([0-9]+\\)" nil t)
2302            (imap-mailbox-put 'uidnext (match-string 1)))
2303           ((search-forward "UNSEEN " nil t)
2304            (imap-mailbox-put 'first-unseen (read (current-buffer))))
2305           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
2306            (imap-mailbox-put 'uidvalidity (match-string 1)))
2307           ((search-forward "READ-ONLY" nil t)
2308            (imap-mailbox-put 'read-only t))
2309           ((search-forward "NEWNAME " nil t)
2310            (let (oldname newname)
2311              (setq oldname (imap-parse-string))
2312              (imap-forward)
2313              (setq newname (imap-parse-string))
2314              (imap-mailbox-put 'newname newname oldname)))
2315           ((search-forward "TRYCREATE" nil t)
2316            (imap-mailbox-put 'trycreate t imap-current-target-mailbox))
2317           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
2318            (imap-mailbox-put 'appenduid
2319                              (list (match-string 1)
2320                                    (string-to-number (match-string 2)))
2321                              imap-current-target-mailbox))
2322           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
2323            (imap-mailbox-put 'copyuid (list (match-string 1)
2324                                             (match-string 2)
2325                                             (match-string 3))
2326                              imap-current-target-mailbox))
2327           ((search-forward "ALERT] " nil t)
2328            (message "Imap server %s information: %s" imap-server
2329                     (buffer-substring (point) (point-max)))))))
2330
2331 ;;   mailbox-list    = "(" [mbx-list-flags] ")" SP
2332 ;;                      (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox
2333 ;;
2334 ;;   mbx-list-flags  = *(mbx-list-oflag SP) mbx-list-sflag
2335 ;;                     *(SP mbx-list-oflag) /
2336 ;;                     mbx-list-oflag *(SP mbx-list-oflag)
2337 ;;
2338 ;;   mbx-list-oflag  = "\Noinferiors" / flag-extension
2339 ;;                       ; Other flags; multiple possible per LIST response
2340 ;;
2341 ;;   mbx-list-sflag  = "\Noselect" / "\Marked" / "\Unmarked"
2342 ;;                       ; Selectability flags; only one per LIST response
2343 ;;
2344 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
2345 ;;                     "\" quoted-specials
2346 ;;
2347 ;;   quoted-specials = DQUOTE / "\"
2348
2349 (defun imap-parse-data-list (type)
2350   (let (flags delimiter mailbox)
2351     (setq flags (imap-parse-flag-list))
2352     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
2353       (setq delimiter (match-string 1))
2354       (goto-char (1+ (match-end 0)))
2355       (when (setq mailbox (imap-parse-mailbox))
2356         (imap-mailbox-put type t mailbox)
2357         (imap-mailbox-put 'list-flags flags mailbox)
2358         (imap-mailbox-put 'delimiter delimiter mailbox)))))
2359
2360 ;;  msg_att         ::= "(" 1#("ENVELOPE" SPACE envelope /
2361 ;;                      "FLAGS" SPACE "(" #(flag / "\Recent") ")" /
2362 ;;                      "INTERNALDATE" SPACE date_time /
2363 ;;                      "RFC822" [".HEADER" / ".TEXT"] SPACE nstring /
2364 ;;                      "RFC822.SIZE" SPACE number /
2365 ;;                      "BODY" ["STRUCTURE"] SPACE body /
2366 ;;                      "BODY" section ["<" number ">"] SPACE nstring /
2367 ;;                      "UID" SPACE uniqueid) ")"
2368 ;;
2369 ;;  date_time       ::= <"> date_day_fixed "-" date_month "-" date_year
2370 ;;                      SPACE time SPACE zone <">
2371 ;;
2372 ;;  section         ::= "[" [section_text / (nz_number *["." nz_number]
2373 ;;                      ["." (section_text / "MIME")])] "]"
2374 ;;
2375 ;;  section_text    ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
2376 ;;                      SPACE header_list / "TEXT"
2377 ;;
2378 ;;  header_fld_name ::= astring
2379 ;;
2380 ;;  header_list     ::= "(" 1#header_fld_name ")"
2381
2382 (defsubst imap-parse-header-list ()
2383   (when (eq (char-after) ?\()
2384     (let (strlist)
2385       (while (not (eq (char-after) ?\)))
2386         (imap-forward)
2387         (push (imap-parse-astring) strlist))
2388       (imap-forward)
2389       (nreverse strlist))))
2390
2391 (defsubst imap-parse-fetch-body-section ()
2392   (let ((section
2393          (buffer-substring (point) (1- (re-search-forward "[] ]" nil t)))))
2394     (if (eq (char-before) ? )
2395         (prog1
2396             (mapconcat 'identity (cons section (imap-parse-header-list)) " ")
2397           (search-forward "]" nil t))
2398       section)))
2399
2400 (defun imap-parse-fetch (response)
2401   (when (eq (char-after) ?\()
2402     (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
2403               rfc822size body bodydetail bodystructure flags-empty)
2404       (while (not (eq (char-after) ?\)))
2405         (imap-forward)
2406         (let ((token (read (current-buffer))))
2407           (imap-forward)
2408           (cond ((eq token 'UID)
2409                  (setq uid (condition-case ()
2410                                (read (current-buffer))
2411                              (error))))
2412                 ((eq token 'FLAGS)
2413                  (setq flags (imap-parse-flag-list))
2414                  (if (not flags)
2415                      (setq flags-empty 't)))
2416                 ((eq token 'ENVELOPE)
2417                  (setq envelope (imap-parse-envelope)))
2418                 ((eq token 'INTERNALDATE)
2419                  (setq internaldate (imap-parse-string)))
2420                 ((eq token 'RFC822)
2421                  (setq rfc822 (imap-parse-nstring)))
2422                 ((eq token 'RFC822.HEADER)
2423                  (setq rfc822header (imap-parse-nstring)))
2424                 ((eq token 'RFC822.TEXT)
2425                  (setq rfc822text (imap-parse-nstring)))
2426                 ((eq token 'RFC822.SIZE)
2427                  (setq rfc822size (read (current-buffer))))
2428                 ((eq token 'BODY)
2429                  (if (eq (char-before) ?\[)
2430                      (push (list
2431                             (upcase (imap-parse-fetch-body-section))
2432                             (and (eq (char-after) ?<)
2433                                  (buffer-substring (1+ (point))
2434                                                    (search-forward ">" nil t)))
2435                             (progn (imap-forward)
2436                                    (imap-parse-nstring)))
2437                            bodydetail)
2438                    (setq body (imap-parse-body))))
2439                 ((eq token 'BODYSTRUCTURE)
2440                  (setq bodystructure (imap-parse-body))))))
2441       (when uid
2442         (setq imap-current-message uid)
2443         (imap-message-put uid 'UID uid)
2444         (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags))
2445         (and envelope (imap-message-put uid 'ENVELOPE envelope))
2446         (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))
2447         (and rfc822 (imap-message-put uid 'RFC822 rfc822))
2448         (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header))
2449         (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text))
2450         (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size))
2451         (and body (imap-message-put uid 'BODY body))
2452         (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail))
2453         (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure))
2454         (run-hooks 'imap-fetch-data-hook)))))
2455
2456 ;;   mailbox-data    =  ...
2457 ;;                      "STATUS" SP mailbox SP "("
2458 ;;                            [status-att SP number
2459 ;;                            *(SP status-att SP number)] ")"
2460 ;;                      ...
2461 ;;
2462 ;;   status-att      = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" /
2463 ;;                     "UNSEEN"
2464
2465 (defun imap-parse-status ()
2466   (let ((mailbox (imap-parse-mailbox)))
2467     (if (eq (char-after) ? )
2468         (forward-char))
2469     (when (and mailbox (eq (char-after) ?\())
2470       (while (and (not (eq (char-after) ?\)))
2471                   (or (forward-char) t)
2472                   (looking-at "\\([A-Za-z]+\\) "))
2473         (let ((token (match-string 1)))
2474           (goto-char (match-end 0))
2475           (cond ((string= token "MESSAGES")
2476                  (imap-mailbox-put 'messages (read (current-buffer)) mailbox))
2477                 ((string= token "RECENT")
2478                  (imap-mailbox-put 'recent (read (current-buffer)) mailbox))
2479                 ((string= token "UIDNEXT")
2480                  (and (looking-at "[0-9]+")
2481                       (imap-mailbox-put 'uidnext (match-string 0) mailbox)
2482                       (goto-char (match-end 0))))
2483                 ((string= token "UIDVALIDITY")
2484                  (and (looking-at "[0-9]+")
2485                       (imap-mailbox-put 'uidvalidity (match-string 0) mailbox)
2486                       (goto-char (match-end 0))))
2487                 ((string= token "UNSEEN")
2488                  (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))
2489                 (t
2490                  (message "Unknown status data %s in mailbox %s ignored"
2491                           token mailbox)
2492                  (read (current-buffer)))))))))
2493
2494 ;;   acl_data        ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
2495 ;;                        rights)
2496 ;;
2497 ;;   identifier      ::= astring
2498 ;;
2499 ;;   rights          ::= astring
2500
2501 (defun imap-parse-acl ()
2502   (let ((mailbox (imap-parse-mailbox))
2503         identifier rights acl)
2504     (while (eq (char-after) ?\ )
2505       (imap-forward)
2506       (setq identifier (imap-parse-astring))
2507       (imap-forward)
2508       (setq rights (imap-parse-astring))
2509       (setq acl (append acl (list (cons identifier rights)))))
2510     (imap-mailbox-put 'acl acl mailbox)))
2511
2512 ;;   flag-list       = "(" [flag *(SP flag)] ")"
2513 ;;
2514 ;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
2515 ;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
2516 ;;                       ; Does not include "\Recent"
2517 ;;
2518 ;;   flag-keyword    = atom
2519 ;;
2520 ;;   flag-extension  = "\" atom
2521 ;;                       ; Future expansion.  Client implementations
2522 ;;                       ; MUST accept flag-extension flags.  Server
2523 ;;                       ; implementations MUST NOT generate
2524 ;;                       ; flag-extension flags except as defined by
2525 ;;                       ; future standard or standards-track
2526 ;;                       ; revisions of this specification.
2527
2528 (defun imap-parse-flag-list ()
2529   (let (flag-list start)
2530     (assert (eq (char-after) ?\() nil "In imap-parse-flag-list")
2531     (while (and (not (eq (char-after) ?\)))
2532                 (setq start (progn
2533                               (imap-forward)
2534                               ;; next line for Courier IMAP bug.
2535                               (skip-chars-forward " ")
2536                               (point)))
2537                 (> (skip-chars-forward "^ )" (point-at-eol)) 0))
2538       (push (buffer-substring start (point)) flag-list))
2539     (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list")
2540     (imap-forward)
2541     (nreverse flag-list)))
2542
2543 ;;   envelope        = "(" env-date SP env-subject SP env-from SP env-sender SP
2544 ;;                     env-reply-to SP env-to SP env-cc SP env-bcc SP
2545 ;;                     env-in-reply-to SP env-message-id ")"
2546 ;;
2547 ;;   env-bcc         = "(" 1*address ")" / nil
2548 ;;
2549 ;;   env-cc          = "(" 1*address ")" / nil
2550 ;;
2551 ;;   env-date        = nstring
2552 ;;
2553 ;;   env-from        = "(" 1*address ")" / nil
2554 ;;
2555 ;;   env-in-reply-to = nstring
2556 ;;
2557 ;;   env-message-id  = nstring
2558 ;;
2559 ;;   env-reply-to    = "(" 1*address ")" / nil
2560 ;;
2561 ;;   env-sender      = "(" 1*address ")" / nil
2562 ;;
2563 ;;   env-subject     = nstring
2564 ;;
2565 ;;   env-to          = "(" 1*address ")" / nil
2566
2567 (defun imap-parse-envelope ()
2568   (when (eq (char-after) ?\()
2569     (imap-forward)
2570     (vector (prog1 (imap-parse-nstring) ;; date
2571               (imap-forward))
2572             (prog1 (imap-parse-nstring) ;; subject
2573               (imap-forward))
2574             (prog1 (imap-parse-address-list) ;; from
2575               (imap-forward))
2576             (prog1 (imap-parse-address-list) ;; sender
2577               (imap-forward))
2578             (prog1 (imap-parse-address-list) ;; reply-to
2579               (imap-forward))
2580             (prog1 (imap-parse-address-list) ;; to
2581               (imap-forward))
2582             (prog1 (imap-parse-address-list) ;; cc
2583               (imap-forward))
2584             (prog1 (imap-parse-address-list) ;; bcc
2585               (imap-forward))
2586             (prog1 (imap-parse-nstring) ;; in-reply-to
2587               (imap-forward))
2588             (prog1 (imap-parse-nstring) ;; message-id
2589               (imap-forward)))))
2590
2591 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2592
2593 (defsubst imap-parse-string-list ()
2594   (cond ((eq (char-after) ?\() ;; body-fld-param
2595          (let (strlist str)
2596            (imap-forward)
2597            (while (setq str (imap-parse-string))
2598              (push str strlist)
2599              ;; buggy stalker communigate pro 3.0 doesn't print SPC
2600              ;; between body-fld-param's sometimes
2601              (or (eq (char-after) ?\")
2602                  (imap-forward)))
2603            (nreverse strlist)))
2604         ((imap-parse-nil)
2605          nil)))
2606
2607 ;;   body-extension  = nstring / number /
2608 ;;                      "(" body-extension *(SP body-extension) ")"
2609 ;;                       ; Future expansion.  Client implementations
2610 ;;                       ; MUST accept body-extension fields.  Server
2611 ;;                       ; implementations MUST NOT generate
2612 ;;                       ; body-extension fields except as defined by
2613 ;;                       ; future standard or standards-track
2614 ;;                       ; revisions of this specification.
2615
2616 (defun imap-parse-body-extension ()
2617   (if (eq (char-after) ?\()
2618       (let (b-e)
2619         (imap-forward)
2620         (push (imap-parse-body-extension) b-e)
2621         (while (eq (char-after) ?\ )
2622           (imap-forward)
2623           (push (imap-parse-body-extension) b-e))
2624         (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension")
2625         (imap-forward)
2626         (nreverse b-e))
2627     (or (imap-parse-number)
2628         (imap-parse-nstring))))
2629
2630 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2631 ;;                     *(SP body-extension)]]
2632 ;;                       ; MUST NOT be returned on non-extensible
2633 ;;                       ; "BODY" fetch
2634 ;;
2635 ;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2636 ;;                     *(SP body-extension)]]
2637 ;;                       ; MUST NOT be returned on non-extensible
2638 ;;                       ; "BODY" fetch
2639
2640 (defsubst imap-parse-body-ext ()
2641   (let (ext)
2642     (when (eq (char-after) ?\ ) ;; body-fld-dsp
2643       (imap-forward)
2644       (let (dsp)
2645         (if (eq (char-after) ?\()
2646             (progn
2647               (imap-forward)
2648               (push (imap-parse-string) dsp)
2649               (imap-forward)
2650               (push (imap-parse-string-list) dsp)
2651               (imap-forward))
2652           ;; With assert, the code might not be eval'd.
2653           ;; (assert (imap-parse-nil) t "In imap-parse-body-ext")
2654           (imap-parse-nil))
2655         (push (nreverse dsp) ext))
2656       (when (eq (char-after) ?\ ) ;; body-fld-lang
2657         (imap-forward)
2658         (if (eq (char-after) ?\()
2659             (push (imap-parse-string-list) ext)
2660           (push (imap-parse-nstring) ext))
2661         (while (eq (char-after) ?\ ) ;; body-extension
2662           (imap-forward)
2663           (setq ext (append (imap-parse-body-extension) ext)))))
2664     ext))
2665
2666 ;;   body            = "(" body-type-1part / body-type-mpart ")"
2667 ;;
2668 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2669 ;;                     *(SP body-extension)]]
2670 ;;                       ; MUST NOT be returned on non-extensible
2671 ;;                       ; "BODY" fetch
2672 ;;
2673 ;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
2674 ;;                     *(SP body-extension)]]
2675 ;;                       ; MUST NOT be returned on non-extensible
2676 ;;                       ; "BODY" fetch
2677 ;;
2678 ;;   body-fields     = body-fld-param SP body-fld-id SP body-fld-desc SP
2679 ;;                     body-fld-enc SP body-fld-octets
2680 ;;
2681 ;;   body-fld-desc   = nstring
2682 ;;
2683 ;;   body-fld-dsp    = "(" string SP body-fld-param ")" / nil
2684 ;;
2685 ;;   body-fld-enc    = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
2686 ;;                     "QUOTED-PRINTABLE") DQUOTE) / string
2687 ;;
2688 ;;   body-fld-id     = nstring
2689 ;;
2690 ;;   body-fld-lang   = nstring / "(" string *(SP string) ")"
2691 ;;
2692 ;;   body-fld-lines  = number
2693 ;;
2694 ;;   body-fld-md5    = nstring
2695 ;;
2696 ;;   body-fld-octets = number
2697 ;;
2698 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2699 ;;
2700 ;;   body-type-1part = (body-type-basic / body-type-msg / body-type-text)
2701 ;;                     [SP body-ext-1part]
2702 ;;
2703 ;;   body-type-basic = media-basic SP body-fields
2704 ;;                       ; MESSAGE subtype MUST NOT be "RFC822"
2705 ;;
2706 ;;   body-type-msg   = media-message SP body-fields SP envelope
2707 ;;                     SP body SP body-fld-lines
2708 ;;
2709 ;;   body-type-text  = media-text SP body-fields SP body-fld-lines
2710 ;;
2711 ;;   body-type-mpart = 1*body SP media-subtype
2712 ;;                     [SP body-ext-mpart]
2713 ;;
2714 ;;   media-basic     = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
2715 ;;                     "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
2716 ;;                       ; Defined in [MIME-IMT]
2717 ;;
2718 ;;   media-message   = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
2719 ;;                      ; Defined in [MIME-IMT]
2720 ;;
2721 ;;   media-subtype   = string
2722 ;;                       ; Defined in [MIME-IMT]
2723 ;;
2724 ;;   media-text      = DQUOTE "TEXT" DQUOTE SP media-subtype
2725 ;;                       ; Defined in [MIME-IMT]
2726
2727 (defun imap-parse-body ()
2728   (let (body)
2729     (when (eq (char-after) ?\()
2730       (imap-forward)
2731       (if (eq (char-after) ?\()
2732           (let (subbody)
2733             (while (and (eq (char-after) ?\()
2734                         (setq subbody (imap-parse-body)))
2735               ;; buggy stalker communigate pro 3.0 insert a SPC between
2736               ;; parts in multiparts
2737               (when (and (eq (char-after) ?\ )
2738                          (eq (char-after (1+ (point))) ?\())
2739                 (imap-forward))
2740               (push subbody body))
2741             (imap-forward)
2742             (push (imap-parse-string) body) ;; media-subtype
2743             (when (eq (char-after) ?\ ) ;; body-ext-mpart:
2744               (imap-forward)
2745               (if (eq (char-after) ?\() ;; body-fld-param
2746                   (push (imap-parse-string-list) body)
2747                 (push (and (imap-parse-nil) nil) body))
2748               (setq body
2749                     (append (imap-parse-body-ext) body))) ;; body-ext-...
2750             (assert (eq (char-after) ?\)) nil "In imap-parse-body")
2751             (imap-forward)
2752             (nreverse body))
2753
2754         (push (imap-parse-string) body) ;; media-type
2755         (imap-forward)
2756         (push (imap-parse-string) body) ;; media-subtype
2757         (imap-forward)
2758         ;; next line for Sun SIMS bug
2759         (and (eq (char-after) ? ) (imap-forward))
2760         (if (eq (char-after) ?\() ;; body-fld-param
2761             (push (imap-parse-string-list) body)
2762           (push (and (imap-parse-nil) nil) body))
2763         (imap-forward)
2764         (push (imap-parse-nstring) body) ;; body-fld-id
2765         (imap-forward)
2766         (push (imap-parse-nstring) body) ;; body-fld-desc
2767         (imap-forward)
2768         ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
2769         ;; nstring and return nil instead of defaulting back to 7BIT
2770         ;; as the standard says.
2771         (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc
2772         (imap-forward)
2773         (push (imap-parse-number) body) ;; body-fld-octets
2774
2775         ;; ok, we're done parsing the required parts, what comes now is one
2776         ;; of three things:
2777         ;;
2778         ;; envelope       (then we're parsing body-type-msg)
2779         ;; body-fld-lines (then we're parsing body-type-text)
2780         ;; body-ext-1part (then we're parsing body-type-basic)
2781         ;;
2782         ;; the problem is that the two first are in turn optionally followed
2783         ;; by the third.  So we parse the first two here (if there are any)...
2784
2785         (when (eq (char-after) ?\ )
2786           (imap-forward)
2787           (let (lines)
2788             (cond ((eq (char-after) ?\() ;; body-type-msg:
2789                    (push (imap-parse-envelope) body) ;; envelope
2790                    (imap-forward)
2791                    (push (imap-parse-body) body) ;; body
2792                    ;; buggy stalker communigate pro 3.0 doesn't print
2793                    ;; number of lines in message/rfc822 attachment
2794                    (if (eq (char-after) ?\))
2795                        (push 0 body)
2796                      (imap-forward)
2797                      (push (imap-parse-number) body))) ;; body-fld-lines
2798                   ((setq lines (imap-parse-number)) ;; body-type-text:
2799                    (push lines body)) ;; body-fld-lines
2800                   (t
2801                    (backward-char))))) ;; no match...
2802
2803         ;; ...and then parse the third one here...
2804
2805         (when (eq (char-after) ?\ ) ;; body-ext-1part:
2806           (imap-forward)
2807           (push (imap-parse-nstring) body) ;; body-fld-md5
2808           (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
2809
2810         (assert (eq (char-after) ?\)) nil "In imap-parse-body 2")
2811         (imap-forward)
2812         (nreverse body)))))
2813
2814 (when imap-debug                        ; (untrace-all)
2815   (require 'trace)
2816   (buffer-disable-undo (get-buffer-create imap-debug-buffer))
2817   (mapcar (lambda (f) (trace-function-background f imap-debug-buffer))
2818           '(
2819             imap-utf7-encode
2820             imap-utf7-decode
2821             imap-error-text
2822             imap-kerberos4s-p
2823             imap-kerberos4-open
2824             imap-ssl-p
2825             imap-ssl-open
2826             imap-network-p
2827             imap-network-open
2828             imap-interactive-login
2829             imap-kerberos4a-p
2830             imap-kerberos4-auth
2831             imap-cram-md5-p
2832             imap-cram-md5-auth
2833             imap-login-p
2834             imap-login-auth
2835             imap-anonymous-p
2836             imap-anonymous-auth
2837             imap-open-1
2838             imap-open
2839             imap-opened
2840             imap-authenticate
2841             imap-close
2842             imap-capability
2843             imap-namespace
2844             imap-send-command-wait
2845             imap-mailbox-put
2846             imap-mailbox-get
2847             imap-mailbox-map-1
2848             imap-mailbox-map
2849             imap-current-mailbox
2850             imap-current-mailbox-p-1
2851             imap-current-mailbox-p
2852             imap-mailbox-select-1
2853             imap-mailbox-select
2854             imap-mailbox-examine-1
2855             imap-mailbox-examine
2856             imap-mailbox-unselect
2857             imap-mailbox-expunge
2858             imap-mailbox-close
2859             imap-mailbox-create-1
2860             imap-mailbox-create
2861             imap-mailbox-delete
2862             imap-mailbox-rename
2863             imap-mailbox-lsub
2864             imap-mailbox-list
2865             imap-mailbox-subscribe
2866             imap-mailbox-unsubscribe
2867             imap-mailbox-status
2868             imap-mailbox-acl-get
2869             imap-mailbox-acl-set
2870             imap-mailbox-acl-delete
2871             imap-current-message
2872             imap-list-to-message-set
2873             imap-fetch-asynch
2874             imap-fetch
2875             imap-message-put
2876             imap-message-get
2877             imap-message-map
2878             imap-search
2879             imap-message-flag-permanent-p
2880             imap-message-flags-set
2881             imap-message-flags-del
2882             imap-message-flags-add
2883             imap-message-copyuid-1
2884             imap-message-copyuid
2885             imap-message-copy
2886             imap-message-appenduid-1
2887             imap-message-appenduid
2888             imap-message-append
2889             imap-body-lines
2890             imap-envelope-from
2891             imap-send-command-1
2892             imap-send-command
2893             imap-wait-for-tag
2894             imap-sentinel
2895             imap-find-next-line
2896             imap-arrival-filter
2897             imap-parse-greeting
2898             imap-parse-response
2899             imap-parse-resp-text
2900             imap-parse-resp-text-code
2901             imap-parse-data-list
2902             imap-parse-fetch
2903             imap-parse-status
2904             imap-parse-acl
2905             imap-parse-flag-list
2906             imap-parse-envelope
2907             imap-parse-body-extension
2908             imap-parse-body
2909             )))
2910
2911 (provide 'imap)
2912
2913 ;;; imap.el ends here