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