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