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

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