cgit.sxemacs.org Git - gnus/blob - lisp/imap.el

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