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

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