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