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

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