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