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 (defun imap-sasl-make-mechanisms (buffer)
 909   (let ((mecs '()))
 910     (mapc (lambda (sym)
 911             (let ((name (symbol-name sym)))
 912               (if (and (> (length name) 5)
 913                        (string-equal "AUTH=" (substring name 0 5 )))
 914                   (setq mecs (cons (substring name 5) mecs)))))
 915           (imap-capability nil buffer))
 916     mecs))
 917
 918 (defun imap-sasl-auth-p (buffer)
 919   (and (condition-case ()
 920            (require 'sasl)
 921          (error nil))
 922        (sasl-find-mechanism (imap-sasl-make-mechanisms buffer))))
 923
 924 (defun imap-sasl-auth (buffer)
 925   "Login to server using the SASL method."
 926   (message "imap: Authenticating using SASL...")
 927   (with-current-buffer buffer
 928     (make-local-variable 'imap-username)
 929     (make-local-variable 'imap-sasl-client)
 930     (make-local-variable 'imap-sasl-step)
 931     (let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))
 932           logged user)
 933       (while (not logged)
 934         (setq user (or imap-username
 935                        (read-from-minibuffer
 936                         (concat "IMAP username for " imap-server " using SASL "
 937                                 (sasl-mechanism-name mechanism) ": ")
 938                         (or user imap-default-user))))
 939         (when user
 940           (setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server)
 941                 imap-sasl-step (sasl-next-step imap-sasl-client nil))
 942           (let ((tag (imap-send-command
 943                       (if (sasl-step-data imap-sasl-step)
 944                           (format "AUTHENTICATE %s %s"
 945                                   (sasl-mechanism-name mechanism)
 946                                   (sasl-step-data imap-sasl-step))
 947                         (format "AUTHENTICATE %s" (sasl-mechanism-name mechanism)))
 948                       buffer)))
 949             (while (eq (imap-wait-for-tag tag) 'INCOMPLETE)
 950               (sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation))
 951               (setq imap-continuation nil
 952                     imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step))
 953               (imap-send-command-1 (if (sasl-step-data imap-sasl-step)
 954                                        (base64-encode-string (sasl-step-data imap-sasl-step) t)
 955                                      "")))
 956             (if (imap-ok-p (imap-wait-for-tag tag))
 957                 (setq imap-username user
 958                       logged t)
 959               (message "Login failed...")
 960               (sit-for 1)))))
 961       logged)))
 962
 963 (defun imap-digest-md5-p (buffer)
 964   (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
 965        (condition-case ()
 966            (require 'digest-md5)
 967          (error nil))))
 968
 969 (defun imap-digest-md5-auth (buffer)
 970   "Login to server using the AUTH DIGEST-MD5 method."
 971   (message "imap: Authenticating using DIGEST-MD5...")
 972   (imap-interactive-login
 973    buffer
 974    (lambda (user passwd)
 975      (let ((tag
 976             (imap-send-command
 977              (list
 978               "AUTHENTICATE DIGEST-MD5"
 979               (lambda (challenge)
 980                 (digest-md5-parse-digest-challenge
 981                  (base64-decode-string challenge))
 982                 (let* ((digest-uri
 983                         (digest-md5-digest-uri
 984                          "imap" (digest-md5-challenge 'realm)))
 985                        (response
 986                         (digest-md5-digest-response
 987                          user passwd digest-uri)))
 988                   (base64-encode-string response 'no-line-break))))
 989              )))
 990        (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
 991            nil
 992          (setq imap-continuation nil)
 993          (imap-send-command-1 "")
 994          (imap-ok-p (imap-wait-for-tag tag)))))))
 995
 996 ;; Server functions:
 997
 998 (defun imap-open-1 (buffer)
 999   (with-current-buffer buffer
1000     (erase-buffer)
1001     (setq imap-current-mailbox nil
1002           imap-current-message nil
1003           imap-state 'initial
1004           imap-process (condition-case ()
1005                            (funcall (nth 2 (assq imap-stream
1006                                                  imap-stream-alist))
1007                                     "imap" buffer imap-server imap-port)
1008                          ((error quit) nil)))
1009     (when imap-process
1010       (set-process-filter imap-process 'imap-arrival-filter)
1011       (set-process-sentinel imap-process 'imap-sentinel)
1012       (while (and (eq imap-state 'initial)
1013                   (memq (process-status imap-process) '(open run)))
1014         (message "Waiting for response from %s..." imap-server)
1015         (accept-process-output imap-process 1))
1016       (message "Waiting for response from %s...done" imap-server)
1017       (and (memq (process-status imap-process) '(open run))
1018            imap-process))))
1019
1020 (defun imap-open (server &optional port stream auth buffer)
1021   "Open a IMAP connection to host SERVER at PORT returning a buffer.
1022 If PORT is unspecified, a default value is used (143 except
1023 for SSL which use 993).
1024 STREAM indicates the stream to use, see `imap-streams' for available
1025 streams.  If nil, it choices the best stream the server is capable of.
1026 AUTH indicates authenticator to use, see `imap-authenticators' for
1027 available authenticators.  If nil, it choices the best stream the
1028 server is capable of.
1029 BUFFER can be a buffer or a name of a buffer, which is created if
1030 necessary.  If nil, the buffer name is generated."
1031   (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0))))
1032   (with-current-buffer (get-buffer-create buffer)
1033     (if (imap-opened buffer)
1034         (imap-close buffer))
1035     (mapcar 'make-local-variable imap-local-variables)
1036     (imap-disable-multibyte)
1037     (buffer-disable-undo)
1038     (setq imap-server (or server imap-server))
1039     (setq imap-port (or port imap-port))
1040     (setq imap-auth (or auth imap-auth))
1041     (setq imap-stream (or stream imap-stream))
1042     (message "imap: Connecting to %s..." imap-server)
1043     (if (null (let ((imap-stream (or imap-stream imap-default-stream)))
1044                 (imap-open-1 buffer)))
1045         (progn
1046           (message "imap: Connecting to %s...failed" imap-server)
1047           nil)
1048       (when (null imap-stream)
1049         ;; Need to choose stream.
1050         (let ((streams imap-streams))
1051           (while (setq stream (pop streams))
1052             ;; OK to use this stream?
1053             (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
1054               ;; Stream changed?
1055               (if (not (eq imap-default-stream stream))
1056                   (with-current-buffer (get-buffer-create
1057                                         (generate-new-buffer-name " *temp*"))
1058                     (mapcar 'make-local-variable imap-local-variables)
1059                     (imap-disable-multibyte)
1060                     (buffer-disable-undo)
1061                     (setq imap-server (or server imap-server))
1062                     (setq imap-port (or port imap-port))
1063                     (setq imap-auth (or auth imap-auth))
1064                     (message "imap: Reconnecting with stream `%s'..." stream)
1065                     (if (null (let ((imap-stream stream))
1066                                 (imap-open-1 (current-buffer))))
1067                         (progn
1068                           (kill-buffer (current-buffer))
1069                           (message
1070                            "imap: Reconnecting with stream `%s'...failed"
1071                            stream))
1072                       ;; We're done, kill the first connection
1073                       (imap-close buffer)
1074                       (kill-buffer buffer)
1075                       (rename-buffer buffer)
1076                       (message "imap: Reconnecting with stream `%s'...done"
1077                                stream)
1078                       (setq imap-stream stream)
1079                       (setq imap-capability nil)
1080                       (setq streams nil)))
1081                 ;; We're done
1082                 (message "imap: Connecting to %s...done" imap-server)
1083                 (setq imap-stream stream)
1084                 (setq imap-capability nil)
1085                 (setq streams nil))))))
1086       (when (imap-opened buffer)
1087         (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
1088       (when imap-stream
1089         buffer))))
1090
1091 (defun imap-opened (&optional buffer)
1092   "Return non-nil if connection to imap server in BUFFER is open.
1093 If BUFFER is nil then the current buffer is used."
1094   (and (setq buffer (get-buffer (or buffer (current-buffer))))
1095        (buffer-live-p buffer)
1096        (with-current-buffer buffer
1097          (and imap-process
1098               (memq (process-status imap-process) '(open run))))))
1099
1100 (defun imap-authenticate (&optional user passwd buffer)
1101   "Authenticate to server in BUFFER, using current buffer if nil.
1102 It uses the authenticator specified when opening the server.  If the
1103 authenticator requires username/passwords, they are queried from the
1104 user and optionally stored in the buffer.  If USER and/or PASSWD is
1105 specified, the user will not be questioned and the username and/or
1106 password is remembered in the buffer."
1107   (with-current-buffer (or buffer (current-buffer))
1108     (if (not (eq imap-state 'nonauth))
1109         (or (eq imap-state 'auth)
1110             (eq imap-state 'select)
1111             (eq imap-state 'examine))
1112       (make-local-variable 'imap-username)
1113       (make-local-variable 'imap-password)
1114       (if user (setq imap-username user))
1115       (if passwd (setq imap-password passwd))
1116       (if imap-auth
1117           (and (funcall (nth 2 (assq imap-auth
1118                                      imap-authenticator-alist)) buffer)
1119                (setq imap-state 'auth))
1120         ;; Choose authenticator.
1121         (let ((auths imap-authenticators)
1122               auth)
1123           (while (setq auth (pop auths))
1124             ;; OK to use authenticator?
1125             (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer)
1126               (message "imap: Authenticating to `%s' using `%s'..."
1127                        imap-server auth)
1128               (setq imap-auth auth)
1129               (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer)
1130                   (progn
1131                     (message "imap: Authenticating to `%s' using `%s'...done"
1132                              imap-server auth)
1133                     (setq auths nil))
1134                 (message "imap: Authenticating to `%s' using `%s'...failed"
1135                          imap-server auth)))))
1136         imap-state))))
1137
1138 (defun imap-close (&optional buffer)
1139   "Close connection to server in BUFFER.
1140 If BUFFER is nil, the current buffer is used."
1141   (with-current-buffer (or buffer (current-buffer))
1142     (when (imap-opened)
1143       (condition-case nil
1144           (imap-send-command-wait "LOGOUT")
1145         (quit nil)))
1146     (when (and imap-process
1147                (memq (process-status imap-process) '(open run)))
1148       (delete-process imap-process))
1149     (setq imap-current-mailbox nil
1150           imap-current-message nil
1151           imap-process nil)
1152     (erase-buffer)
1153     t))
1154
1155 (defun imap-capability (&optional identifier buffer)
1156   "Return a list of identifiers which server in BUFFER support.
1157 If IDENTIFIER, return non-nil if it's among the servers capabilities.
1158 If BUFFER is nil, the current buffer is assumed."
1159   (with-current-buffer (or buffer (current-buffer))
1160     (unless imap-capability
1161       (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
1162         (setq imap-capability '(IMAP2))))
1163     (if identifier
1164         (memq (intern (upcase (symbol-name identifier))) imap-capability)
1165       imap-capability)))
1166
1167 (defun imap-id (&optional list-of-values buffer)
1168   "Identify client to server in BUFFER, and return server identity.
1169 LIST-OF-VALUES is nil, or a plist with identifier and value
1170 strings to send to the server to identify the client.
1171
1172 Return a list of identifiers which server in BUFFER support, or
1173 nil if it doesn't support ID or returns no information.
1174
1175 If BUFFER is nil, the current buffer is assumed."
1176   (with-current-buffer (or buffer (current-buffer))
1177     (when (and (imap-capability 'ID)
1178                (imap-ok-p (imap-send-command-wait
1179                            (if (null list-of-values)
1180                                "ID NIL"
1181                              (concat "ID (" (mapconcat (lambda (el)
1182                                                          (concat "\"" el "\""))
1183                                                        list-of-values
1184                                                        " ") ")")))))
1185       imap-id)))
1186
1187 (defun imap-namespace (&optional buffer)
1188   "Return a namespace hierarchy at server in BUFFER.
1189 If BUFFER is nil, the current buffer is assumed."
1190   (with-current-buffer (or buffer (current-buffer))
1191     (unless imap-namespace
1192       (when (imap-capability 'NAMESPACE)
1193         (imap-send-command-wait "NAMESPACE")))
1194     imap-namespace))
1195
1196 (defun imap-send-command-wait (command &optional buffer)
1197   (imap-wait-for-tag (imap-send-command command buffer) buffer))
1198
1199 \f
1200 ;; Mailbox functions:
1201
1202 (defun imap-mailbox-put (propname value &optional mailbox buffer)
1203   (with-current-buffer (or buffer (current-buffer))
1204     (if imap-mailbox-data
1205         (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
1206              propname value)
1207       (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
1208              propname value mailbox (current-buffer)))
1209     t))
1210
1211 (defsubst imap-mailbox-get-1 (propname &optional mailbox)
1212   (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
1213        propname))
1214
1215 (defun imap-mailbox-get (propname &optional mailbox buffer)
1216   (let ((mailbox (imap-utf7-encode mailbox)))
1217     (with-current-buffer (or buffer (current-buffer))
1218       (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
1219
1220 (defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
1221   (with-current-buffer (or buffer (current-buffer))
1222     (let (result)
1223       (mapatoms
1224        (lambda (s)
1225          (push (funcall func (if mailbox-decoder
1226                                  (funcall mailbox-decoder (symbol-name s))
1227                                (symbol-name s))) result))
1228        imap-mailbox-data)
1229       result)))
1230
1231 (defun imap-mailbox-map (func &optional buffer)
1232   "Map a function across each mailbox in `imap-mailbox-data', returning a list.
1233 Function should take a mailbox name (a string) as
1234 the only argument."
1235   (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
1236
1237 (defun imap-current-mailbox (&optional buffer)
1238   (with-current-buffer (or buffer (current-buffer))
1239     (imap-utf7-decode imap-current-mailbox)))
1240
1241 (defun imap-current-mailbox-p-1 (mailbox &optional examine)
1242   (and (string= mailbox imap-current-mailbox)
1243        (or (and examine
1244                 (eq imap-state 'examine))
1245            (and (not examine)
1246                 (eq imap-state 'selected)))))
1247
1248 (defun imap-current-mailbox-p (mailbox &optional examine buffer)
1249   (with-current-buffer (or buffer (current-buffer))
1250     (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine)))
1251
1252 (defun imap-mailbox-select-1 (mailbox &optional examine)
1253   "Select MAILBOX on server in BUFFER.
1254 If EXAMINE is non-nil, do a read-only select."
1255   (if (imap-current-mailbox-p-1 mailbox examine)
1256       imap-current-mailbox
1257     (setq imap-current-mailbox mailbox)
1258     (if (imap-ok-p (imap-send-command-wait
1259                     (concat (if examine "EXAMINE" "SELECT") " \""
1260                             mailbox "\"")))
1261         (progn
1262           (setq imap-message-data (make-vector imap-message-prime 0)
1263                 imap-state (if examine 'examine 'selected))
1264           imap-current-mailbox)
1265       ;; Failed SELECT/EXAMINE unselects current mailbox
1266       (setq imap-current-mailbox nil))))
1267
1268 (defun imap-mailbox-select (mailbox &optional examine buffer)
1269   (with-current-buffer (or buffer (current-buffer))
1270     (imap-utf7-decode
1271      (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
1272
1273 (defun imap-mailbox-examine-1 (mailbox &optional buffer)
1274   (with-current-buffer (or buffer (current-buffer))
1275     (imap-mailbox-select-1 mailbox 'examine)))
1276
1277 (defun imap-mailbox-examine (mailbox &optional buffer)
1278   "Examine MAILBOX on server in BUFFER."
1279   (imap-mailbox-select mailbox 'examine buffer))
1280
1281 (defun imap-mailbox-unselect (&optional buffer)
1282   "Close current folder in BUFFER, without expunging articles."
1283   (with-current-buffer (or buffer (current-buffer))
1284     (when (or (eq imap-state 'auth)
1285               (and (imap-capability 'UNSELECT)
1286                    (imap-ok-p (imap-send-command-wait "UNSELECT")))
1287               (and (imap-ok-p
1288                     (imap-send-command-wait (concat "EXAMINE \""
1289                                                     imap-current-mailbox
1290                                                     "\"")))
1291                    (imap-ok-p (imap-send-command-wait "CLOSE"))))
1292       (setq imap-current-mailbox nil
1293             imap-message-data nil
1294             imap-state 'auth)
1295       t)))
1296
1297 (defun imap-mailbox-expunge (&optional asynch buffer)
1298   "Expunge articles in current folder in BUFFER.
1299 If ASYNCH, do not wait for succesful completion of the command.
1300 If BUFFER is nil the current buffer is assumed."
1301   (with-current-buffer (or buffer (current-buffer))
1302     (when (and imap-current-mailbox (not (eq imap-state 'examine)))
1303       (if asynch
1304           (imap-send-command "EXPUNGE")
1305       (imap-ok-p (imap-send-command-wait "EXPUNGE"))))))
1306
1307 (defun imap-mailbox-close (&optional asynch buffer)
1308   "Expunge articles and close current folder in BUFFER.
1309 If ASYNCH, do not wait for succesful completion of the command.
1310 If BUFFER is nil the current buffer is assumed."
1311   (with-current-buffer (or buffer (current-buffer))
1312     (when imap-current-mailbox
1313       (if asynch
1314           (imap-add-callback (imap-send-command "CLOSE")
1315                              `(lambda (tag status)
1316                                 (message "IMAP mailbox `%s' closed... %s"
1317                                          imap-current-mailbox status)
1318                                 (when (eq ,imap-current-mailbox
1319                                           imap-current-mailbox)
1320                                   ;; Don't wipe out data if another mailbox
1321                                   ;; was selected...
1322                                   (setq imap-current-mailbox nil
1323                                         imap-message-data nil
1324                                         imap-state 'auth))))
1325         (when (imap-ok-p (imap-send-command-wait "CLOSE"))
1326           (setq imap-current-mailbox nil
1327                 imap-message-data nil
1328                 imap-state 'auth)))
1329       t)))
1330
1331 (defun imap-mailbox-create-1 (mailbox)
1332   (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\""))))
1333
1334 (defun imap-mailbox-create (mailbox &optional buffer)
1335   "Create MAILBOX on server in BUFFER.
1336 If BUFFER is nil the current buffer is assumed."
1337   (with-current-buffer (or buffer (current-buffer))
1338     (imap-mailbox-create-1 (imap-utf7-encode mailbox))))
1339
1340 (defun imap-mailbox-delete (mailbox &optional buffer)
1341   "Delete MAILBOX on server in BUFFER.
1342 If BUFFER is nil the current buffer is assumed."
1343   (let ((mailbox (imap-utf7-encode mailbox)))
1344     (with-current-buffer (or buffer (current-buffer))
1345       (imap-ok-p
1346        (imap-send-command-wait (list "DELETE \"" mailbox "\""))))))
1347
1348 (defun imap-mailbox-rename (oldname newname &optional buffer)
1349   "Rename mailbox OLDNAME to NEWNAME on server in BUFFER.
1350 If BUFFER is nil the current buffer is assumed."
1351   (let ((oldname (imap-utf7-encode oldname))
1352         (newname (imap-utf7-encode newname)))
1353     (with-current-buffer (or buffer (current-buffer))
1354       (imap-ok-p
1355        (imap-send-command-wait (list "RENAME \"" oldname "\" "
1356                                      "\"" newname "\""))))))
1357
1358 (defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
1359   "Return a list of subscribed mailboxes on server in BUFFER.
1360 If ROOT is non-nil, only list matching mailboxes.  If ADD-DELIMITER is
1361 non-nil, a hierarchy delimiter is added to root.  REFERENCE is a
1362 implementation-specific string that has to be passed to lsub command."
1363   (with-current-buffer (or buffer (current-buffer))
1364     ;; Make sure we know the hierarchy separator for root's hierarchy
1365     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1366       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1367                                       (imap-utf7-encode root) "\"")))
1368     ;; clear list data (NB not delimiter and other stuff)
1369     (imap-mailbox-map-1 (lambda (mailbox)
1370                           (imap-mailbox-put 'lsub nil mailbox)))
1371     (when (imap-ok-p
1372            (imap-send-command-wait
1373             (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root)
1374                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1375                     "%\"")))
1376       (let (out)
1377         (imap-mailbox-map-1 (lambda (mailbox)
1378                               (when (imap-mailbox-get-1 'lsub mailbox)
1379                                 (push (imap-utf7-decode mailbox) out))))
1380         (nreverse out)))))
1381
1382 (defun imap-mailbox-list (root &optional reference add-delimiter buffer)
1383   "Return a list of mailboxes matching ROOT on server in BUFFER.
1384 If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
1385 root.  REFERENCE is a implementation-specific string that has to be
1386 passed to list command."
1387   (with-current-buffer (or buffer (current-buffer))
1388     ;; Make sure we know the hierarchy separator for root's hierarchy
1389     (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
1390       (imap-send-command-wait (concat "LIST \"" reference "\" \""
1391                                       (imap-utf7-encode root) "\"")))
1392     ;; clear list data (NB not delimiter and other stuff)
1393     (imap-mailbox-map-1 (lambda (mailbox)
1394                           (imap-mailbox-put 'list nil mailbox)))
1395     (when (imap-ok-p
1396            (imap-send-command-wait
1397             (concat "LIST \"" reference "\" \"" (imap-utf7-encode root)
1398                     (and add-delimiter (imap-mailbox-get-1 'delimiter root))
1399                     "%\"")))
1400       (let (out)
1401         (imap-mailbox-map-1 (lambda (mailbox)
1402                               (when (imap-mailbox-get-1 'list mailbox)
1403                                 (push (imap-utf7-decode mailbox) out))))
1404         (nreverse out)))))
1405
1406 (defun imap-mailbox-subscribe (mailbox &optional buffer)
1407   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1408 Returns non-nil if successful."
1409   (with-current-buffer (or buffer (current-buffer))
1410     (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
1411                                                (imap-utf7-encode mailbox)
1412                                                "\"")))))
1413
1414 (defun imap-mailbox-unsubscribe (mailbox &optional buffer)
1415   "Send the SUBSCRIBE command on the mailbox to server in BUFFER.
1416 Returns non-nil if successful."
1417   (with-current-buffer (or buffer (current-buffer))
1418     (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
1419                                                (imap-utf7-encode mailbox)
1420                                                "\"")))))
1421
1422 (defun imap-mailbox-status (mailbox items &optional buffer)
1423   "Get status items ITEM in MAILBOX from server in BUFFER.
1424 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1425 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1426 or 'unseen.  If ITEMS is a list of symbols, a list of values is
1427 returned, if ITEMS is a symbol only its value is returned."
1428   (with-current-buffer (or buffer (current-buffer))
1429     (when (imap-ok-p
1430            (imap-send-command-wait (list "STATUS \""
1431                                          (imap-utf7-encode mailbox)
1432                                          "\" "
1433                                          (upcase
1434                                           (format "%s"
1435                                                   (if (listp items)
1436                                                       items
1437                                                     (list items)))))))
1438       (if (listp items)
1439           (mapcar (lambda (item)
1440                     (imap-mailbox-get item mailbox))
1441                   items)
1442         (imap-mailbox-get items mailbox)))))
1443
1444 (defun imap-mailbox-status-asynch (mailbox items &optional buffer)
1445   "Send status item request ITEM on MAILBOX to server in BUFFER.
1446 ITEMS can be a symbol or a list of symbols, valid symbols are one of
1447 the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity
1448 or 'unseen.  The IMAP command tag is returned."
1449   (with-current-buffer (or buffer (current-buffer))
1450     (imap-send-command (list "STATUS \""
1451                              (imap-utf7-encode mailbox)
1452                              "\" "
1453                              (format "%s"
1454                                      (if (listp items)
1455                                          items
1456                                        (list items)))))))
1457
1458 (defun imap-mailbox-acl-get (&optional mailbox buffer)
1459   "Get ACL on mailbox from server in BUFFER."
1460   (let ((mailbox (imap-utf7-encode mailbox)))
1461     (with-current-buffer (or buffer (current-buffer))
1462       (when (imap-ok-p
1463              (imap-send-command-wait (list "GETACL \""
1464                                            (or mailbox imap-current-mailbox)
1465                                            "\"")))
1466         (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox))))))
1467
1468 (defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer)
1469   "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER."
1470   (let ((mailbox (imap-utf7-encode mailbox)))
1471     (with-current-buffer (or buffer (current-buffer))
1472       (imap-ok-p
1473        (imap-send-command-wait (list "SETACL \""
1474                                      (or mailbox imap-current-mailbox)
1475                                      "\" "
1476                                      identifier
1477                                      " "
1478                                      rights))))))
1479
1480 (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
1481   "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER."
1482   (let ((mailbox (imap-utf7-encode mailbox)))
1483     (with-current-buffer (or buffer (current-buffer))
1484       (imap-ok-p
1485        (imap-send-command-wait (list "DELETEACL \""
1486                                      (or mailbox imap-current-mailbox)
1487                                      "\" "
1488                                      identifier))))))
1489
1490 \f
1491 ;; Message functions:
1492
1493 (defun imap-current-message (&optional buffer)
1494   (with-current-buffer (or buffer (current-buffer))
1495     imap-current-message))
1496
1497 (defun imap-list-to-message-set (list)
1498   (mapconcat (lambda (item)
1499                (number-to-string item))
1500              (if (listp list)
1501                  list
1502                (list list))
1503              ","))
1504
1505 (defun imap-range-to-message-set (range)
1506   (mapconcat
1507    (lambda (item)
1508      (if (consp item)
1509          (format "%d:%d"
1510                  (car item) (cdr item))
1511        (format "%d" item)))
1512    (if (and (listp range) (not (listp (cdr range))))
1513        (list range) ;; make (1 . 2) into ((1 . 2))
1514      range)
1515    ","))
1516
1517 (defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
1518   (with-current-buffer (or buffer (current-buffer))
1519     (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1520                                (if (listp uids)
1521                                    (imap-list-to-message-set uids)
1522                                  uids)
1523                                props))))
1524
1525 (defun imap-fetch (uids props &optional receive nouidfetch buffer)
1526   "Fetch properties PROPS from message set UIDS from server in BUFFER.
1527 UIDS can be a string, number or a list of numbers.  If RECEIVE
1528 is non-nil return theese properties."
1529   (with-current-buffer (or buffer (current-buffer))
1530     (when (imap-ok-p (imap-send-command-wait
1531                       (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
1532                               (if (listp uids)
1533                                   (imap-list-to-message-set uids)
1534                                 uids)
1535                               props)))
1536       (if (or (null receive) (stringp uids))
1537           t
1538         (if (listp uids)
1539             (mapcar (lambda (uid)
1540                       (if (listp receive)
1541                           (mapcar (lambda (prop)
1542                                     (imap-message-get uid prop))
1543                                   receive)
1544                         (imap-message-get uid receive)))
1545                     uids)
1546           (imap-message-get uids receive))))))
1547
1548 (defun imap-message-put (uid propname value &optional buffer)
1549   (with-current-buffer (or buffer (current-buffer))
1550     (if imap-message-data
1551         (put (intern (number-to-string uid) imap-message-data)
1552              propname value)
1553       (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
1554              uid propname value (current-buffer)))
1555     t))
1556
1557 (defun imap-message-get (uid propname &optional buffer)
1558   (with-current-buffer (or buffer (current-buffer))
1559     (get (intern-soft (number-to-string uid) imap-message-data)
1560          propname)))
1561
1562 (defun imap-message-map (func propname &optional buffer)
1563   "Map a function across each mailbox in `imap-message-data', returning a list."
1564   (with-current-buffer (or buffer (current-buffer))
1565     (let (result)
1566       (mapatoms
1567        (lambda (s)
1568          (push (funcall func (get s 'UID) (get s propname)) result))
1569        imap-message-data)
1570       result)))
1571
1572 (defmacro imap-message-envelope-date (uid &optional buffer)
1573   `(with-current-buffer (or ,buffer (current-buffer))
1574      (elt (imap-message-get ,uid 'ENVELOPE) 0)))
1575
1576 (defmacro imap-message-envelope-subject (uid &optional buffer)
1577   `(with-current-buffer (or ,buffer (current-buffer))
1578      (elt (imap-message-get ,uid 'ENVELOPE) 1)))
1579
1580 (defmacro imap-message-envelope-from (uid &optional buffer)
1581   `(with-current-buffer (or ,buffer (current-buffer))
1582      (elt (imap-message-get ,uid 'ENVELOPE) 2)))
1583
1584 (defmacro imap-message-envelope-sender (uid &optional buffer)
1585   `(with-current-buffer (or ,buffer (current-buffer))
1586      (elt (imap-message-get ,uid 'ENVELOPE) 3)))
1587
1588 (defmacro imap-message-envelope-reply-to (uid &optional buffer)
1589   `(with-current-buffer (or ,buffer (current-buffer))
1590      (elt (imap-message-get ,uid 'ENVELOPE) 4)))
1591
1592 (defmacro imap-message-envelope-to (uid &optional buffer)
1593   `(with-current-buffer (or ,buffer (current-buffer))
1594      (elt (imap-message-get ,uid 'ENVELOPE) 5)))
1595
1596 (defmacro imap-message-envelope-cc (uid &optional buffer)
1597   `(with-current-buffer (or ,buffer (current-buffer))
1598      (elt (imap-message-get ,uid 'ENVELOPE) 6)))
1599
1600 (defmacro imap-message-envelope-bcc (uid &optional buffer)
1601   `(with-current-buffer (or ,buffer (current-buffer))
1602      (elt (imap-message-get ,uid 'ENVELOPE) 7)))
1603
1604 (defmacro imap-message-envelope-in-reply-to (uid &optional buffer)
1605   `(with-current-buffer (or ,buffer (current-buffer))
1606      (elt (imap-message-get ,uid 'ENVELOPE) 8)))
1607
1608 (defmacro imap-message-envelope-message-id (uid &optional buffer)
1609   `(with-current-buffer (or ,buffer (current-buffer))
1610      (elt (imap-message-get ,uid 'ENVELOPE) 9)))
1611
1612 (defmacro imap-message-body (uid &optional buffer)
1613   `(with-current-buffer (or ,buffer (current-buffer))
1614      (imap-message-get ,uid 'BODY)))
1615
1616 (defun imap-search (predicate &optional buffer)
1617   (with-current-buffer (or buffer (current-buffer))
1618     (imap-mailbox-put 'search 'dummy)
1619     (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
1620       (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
1621           (progn
1622             (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...")
1623             nil)
1624         (imap-mailbox-get-1 'search imap-current-mailbox)))))
1625
1626 (defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
1627   "Return t iff FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
1628   (with-current-buffer (or buffer (current-buffer))
1629     (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
1630         (member flag (imap-mailbox-get 'permanentflags mailbox)))))
1631
1632 (defun imap-message-flags-set (articles flags &optional silent buffer)
1633   (when (and articles flags)
1634     (with-current-buffer (or buffer (current-buffer))
1635       (imap-ok-p (imap-send-command-wait
1636                   (concat "UID STORE " articles
1637                           " FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1638
1639 (defun imap-message-flags-del (articles flags &optional silent buffer)
1640   (when (and articles flags)
1641     (with-current-buffer (or buffer (current-buffer))
1642       (imap-ok-p (imap-send-command-wait
1643                   (concat "UID STORE " articles
1644                           " -FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1645
1646 (defun imap-message-flags-add (articles flags &optional silent buffer)
1647   (when (and articles flags)
1648     (with-current-buffer (or buffer (current-buffer))
1649       (imap-ok-p (imap-send-command-wait
1650                   (concat "UID STORE " articles
1651                           " +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
1652
1653 (defun imap-message-copyuid-1 (mailbox)
1654   (if (imap-capability 'UIDPLUS)
1655       (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
1656             (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
1657     (let ((old-mailbox imap-current-mailbox)
1658           (state imap-state)
1659           (imap-message-data (make-vector 2 0)))
1660       (when (imap-mailbox-examine-1 mailbox)
1661         (prog1
1662             (and (imap-fetch "*" "UID")
1663                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
1664                        (apply 'max (imap-message-map
1665                                     (lambda (uid prop) uid) 'UID))))
1666           (if old-mailbox
1667               (imap-mailbox-select old-mailbox (eq state 'examine))
1668             (imap-mailbox-unselect)))))))
1669
1670 (defun imap-message-copyuid (mailbox &optional buffer)
1671   (with-current-buffer (or buffer (current-buffer))
1672     (imap-message-copyuid-1 (imap-utf7-decode mailbox))))
1673
1674 (defun imap-message-copy (articles mailbox
1675                                    &optional dont-create no-copyuid buffer)
1676   "Copy ARTICLES (a string message set) to MAILBOX on server in
1677 BUFFER, creating mailbox if it doesn't exist.  If dont-create is
1678 non-nil, it will not create a mailbox.  On success, return a list with
1679 the UIDVALIDITY of the mailbox the article(s) was copied to as the
1680 first element, rest of list contain the saved articles' UIDs."
1681   (when articles
1682     (with-current-buffer (or buffer (current-buffer))
1683       (let ((mailbox (imap-utf7-encode mailbox)))
1684         (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\""))
1685                   (imap-current-target-mailbox mailbox))
1686               (if (imap-ok-p (imap-send-command-wait cmd))
1687                   t
1688                 (when (and (not dont-create)
1689                            ;; removed because of buggy Oracle server
1690                            ;; that doesn't send TRYCREATE tags (which
1691                            ;; is a MUST according to specifications):
1692                            ;;(imap-mailbox-get-1 'trycreate mailbox)
1693                            (imap-mailbox-create-1 mailbox))
1694                   (imap-ok-p (imap-send-command-wait cmd)))))
1695             (or no-copyuid
1696                 (imap-message-copyuid-1 mailbox)))))))
1697
1698 (defun imap-message-appenduid-1 (mailbox)
1699   (if (imap-capability 'UIDPLUS)
1700       (imap-mailbox-get-1 'appenduid mailbox)
1701     (let ((old-mailbox imap-current-mailbox)
1702           (state imap-state)
1703           (imap-message-data (make-vector 2 0)))
1704       (when (imap-mailbox-examine-1 mailbox)
1705         (prog1
1706             (and (imap-fetch "*" "UID")
1707                  (list (imap-mailbox-get-1 'uidvalidity mailbox)
1708                        (apply 'max (imap-message-map
1709                                     (lambda (uid prop) uid) 'UID))))
1710           (if old-mailbox
1711               (imap-mailbox-select old-mailbox (eq state 'examine))
1712             (imap-mailbox-unselect)))))))
1713
1714 (defun imap-message-appenduid (mailbox &optional buffer)
1715   (with-current-buffer (or buffer (current-buffer))
1716     (imap-message-appenduid-1 (imap-utf7-encode mailbox))))
1717
1718 (defun imap-message-append (mailbox article &optional flags date-time buffer)
1719   "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER.
1720 FLAGS and DATE-TIME is currently not used.  Return a cons holding
1721 uidvalidity of MAILBOX and UID the newly created article got, or nil
1722 on failure."
1723   (let ((mailbox (imap-utf7-encode mailbox)))
1724     (with-current-buffer (or buffer (current-buffer))
1725       (and (let ((imap-current-target-mailbox mailbox))
1726              (imap-ok-p
1727               (imap-send-command-wait
1728                (list "APPEND \"" mailbox "\" "  article))))
1729            (imap-message-appenduid-1 mailbox)))))
1730
1731 (defun imap-body-lines (body)
1732   "Return number of lines in article by looking at the mime bodystructure BODY."
1733   (if (listp body)
1734       (if (stringp (car body))
1735           (cond ((and (string= (upcase (car body)) "TEXT")
1736                       (numberp (nth 7 body)))
1737                  (nth 7 body))
1738                 ((and (string= (upcase (car body)) "MESSAGE")
1739                       (numberp (nth 9 body)))
1740                  (nth 9 body))
1741                 (t 0))
1742         (apply '+ (mapcar 'imap-body-lines body)))
1743     0))
1744
1745 (defun imap-envelope-from (from)
1746   "Return a from string line."
1747   (and from
1748        (concat (aref from 0)
1749                (if (aref from 0) " <")
1750                (aref from 2)
1751                "@"
1752                (aref from 3)
1753                (if (aref from 0) ">"))))
1754
1755 \f
1756 ;; Internal functions.
1757
1758 (defun imap-add-callback (tag func)
1759   (setq imap-callbacks (append (list (cons tag func)) imap-callbacks)))
1760
1761 (defun imap-send-command-1 (cmdstr)
1762   (setq cmdstr (concat cmdstr imap-client-eol))
1763   (and imap-log
1764        (with-current-buffer (get-buffer-create imap-log-buffer)
1765          (imap-disable-multibyte)
1766          (buffer-disable-undo)
1767          (goto-char (point-max))
1768          (insert cmdstr)))
1769   (process-send-string imap-process cmdstr))
1770
1771 (defun imap-send-command (command &optional buffer)
1772   (with-current-buffer (or buffer (current-buffer))
1773     (if (not (listp command)) (setq command (list command)))
1774     (let ((tag (setq imap-tag (1+ imap-tag)))
1775           cmd cmdstr)
1776       (setq cmdstr (concat (number-to-string imap-tag) " "))
1777       (while (setq cmd (pop command))
1778         (cond ((stringp cmd)
1779                (setq cmdstr (concat cmdstr cmd)))
1780               ((bufferp cmd)
1781                (let ((eol imap-client-eol)
1782                      (calcfirst imap-calculate-literal-size-first)
1783                      size)
1784                  (with-current-buffer cmd
1785                    (if calcfirst
1786                        (setq size (buffer-size)))
1787                    (when (not (equal eol "\r\n"))
1788                      ;; XXX modifies buffer!
1789                      (goto-char (point-min))
1790                      (while (search-forward "\r\n" nil t)
1791                        (replace-match eol)))
1792                    (if (not calcfirst)
1793                        (setq size (buffer-size))))
1794                  (setq cmdstr
1795                        (concat cmdstr (format "{%d}" size))))
1796                (unwind-protect
1797                    (progn
1798                      (imap-send-command-1 cmdstr)
1799                      (setq cmdstr nil)
1800                      (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1801                          (setq command nil) ;; abort command if no cont-req
1802                        (let ((process imap-process)
1803                              (stream imap-stream)
1804                              (eol imap-client-eol))
1805                          (with-current-buffer cmd
1806                            (and imap-log
1807                                 (with-current-buffer (get-buffer-create
1808                                                       imap-log-buffer)
1809                                   (imap-disable-multibyte)
1810                                   (buffer-disable-undo)
1811                                   (goto-char (point-max))
1812                                   (insert-buffer-substring cmd)))
1813                            (process-send-region process (point-min)
1814                                                 (point-max)))
1815                          (process-send-string process imap-client-eol))))
1816                  (setq imap-continuation nil)))
1817               ((functionp cmd)
1818                (imap-send-command-1 cmdstr)
1819                (setq cmdstr nil)
1820                (unwind-protect
1821                    (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
1822                        (setq command nil) ;; abort command if no cont-req
1823                      (setq command (cons (funcall cmd imap-continuation)
1824                                          command)))
1825                  (setq imap-continuation nil)))
1826               (t
1827                (error "Unknown command type"))))
1828       (if cmdstr
1829           (imap-send-command-1 cmdstr))
1830       tag)))
1831
1832 (defun imap-wait-for-tag (tag &optional buffer)
1833   (with-current-buffer (or buffer (current-buffer))
1834     (let (imap-have-messaged)
1835       (while (and (null imap-continuation)
1836                   (memq (process-status imap-process) '(open run))
1837                   (< imap-reached-tag tag))
1838         (let ((len (/ (point-max) 1024))
1839               message-log-max)
1840           (unless (< len 10)
1841             (setq imap-have-messaged t)
1842             (message "imap read: %dk" len))
1843           (accept-process-output imap-process
1844                                  (truncate imap-read-timeout)
1845                                  (truncate (* (- imap-read-timeout
1846                                                  (truncate imap-read-timeout))
1847                                               1000)))))
1848       ;; A process can die _before_ we have processed everything it
1849       ;; has to say.  Moreover, this can happen in between the call to
1850       ;; accept-process-output and the call to process-status in an
1851       ;; iteration of the loop above.
1852       (when (and (null imap-continuation)
1853                  (< imap-reached-tag tag))
1854         (accept-process-output imap-process 0 0))
1855       (when imap-have-messaged
1856         (message ""))
1857       (and (memq (process-status imap-process) '(open run))
1858            (or (assq tag imap-failed-tags)
1859                (if imap-continuation
1860                    'INCOMPLETE
1861                  'OK))))))
1862
1863 (defun imap-sentinel (process string)
1864   (delete-process process))
1865
1866 (defun imap-find-next-line ()
1867   "Return point at end of current line, taking into account literals.
1868 Return nil if no complete line has arrived."
1869   (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}"
1870                                    imap-server-eol)
1871                            nil t)
1872     (if (match-string 1)
1873         (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1874             nil
1875           (goto-char (+ (point) (string-to-number (match-string 1))))
1876           (imap-find-next-line))
1877       (point))))
1878
1879 (defun imap-arrival-filter (proc string)
1880   "IMAP process filter."
1881   ;; Sometimes, we are called even though the process has died.
1882   ;; Better abstain from doing stuff in that case.
1883   (when (buffer-name (process-buffer proc))
1884     (with-current-buffer (process-buffer proc)
1885       (goto-char (point-max))
1886       (insert string)
1887       (and imap-log
1888            (with-current-buffer (get-buffer-create imap-log-buffer)
1889              (imap-disable-multibyte)
1890              (buffer-disable-undo)
1891              (goto-char (point-max))
1892              (insert string)))
1893       (let (end)
1894         (goto-char (point-min))
1895         (while (setq end (imap-find-next-line))
1896           (save-restriction
1897             (narrow-to-region (point-min) end)
1898             (delete-backward-char (length imap-server-eol))
1899             (goto-char (point-min))
1900             (unwind-protect
1901                 (cond ((eq imap-state 'initial)
1902                        (imap-parse-greeting))
1903                       ((or (eq imap-state 'auth)
1904                            (eq imap-state 'nonauth)
1905                            (eq imap-state 'selected)
1906                            (eq imap-state 'examine))
1907                        (imap-parse-response))
1908                       (t
1909                        (message "Unknown state %s in arrival filter"
1910                                 imap-state)))
1911               (delete-region (point-min) (point-max)))))))))
1912
1913 \f
1914 ;; Imap parser.
1915
1916 (defsubst imap-forward ()
1917   (or (eobp) (forward-char)))
1918
1919 ;;   number          = 1*DIGIT
1920 ;;                       ; Unsigned 32-bit integer
1921 ;;                       ; (0 <= n < 4,294,967,296)
1922
1923 (defsubst imap-parse-number ()
1924   (when (looking-at "[0-9]+")
1925     (prog1
1926         (string-to-number (match-string 0))
1927       (goto-char (match-end 0)))))
1928
1929 ;;   literal         = "{" number "}" CRLF *CHAR8
1930 ;;                       ; Number represents the number of CHAR8s
1931
1932 (defsubst imap-parse-literal ()
1933   (when (looking-at "{\\([0-9]+\\)}\r\n")
1934     (let ((pos (match-end 0))
1935           (len (string-to-number (match-string 1))))
1936       (if (< (point-max) (+ pos len))
1937           nil
1938         (goto-char (+ pos len))
1939         (buffer-substring pos (+ pos len))))))
1940
1941 ;;   string          = quoted / literal
1942 ;;
1943 ;;   quoted          = DQUOTE *QUOTED-CHAR DQUOTE
1944 ;;
1945 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
1946 ;;                     "\" quoted-specials
1947 ;;
1948 ;;   quoted-specials = DQUOTE / "\"
1949 ;;
1950 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
1951
1952 (defsubst imap-parse-string ()
1953   (cond ((eq (char-after) ?\")
1954          (forward-char 1)
1955          (let ((p (point)) (name ""))
1956            (skip-chars-forward "^\"\\\\")
1957            (setq name (buffer-substring p (point)))
1958            (while (eq (char-after) ?\\)
1959              (setq p (1+ (point)))
1960              (forward-char 2)
1961              (skip-chars-forward "^\"\\\\")
1962              (setq name (concat name (buffer-substring p (point)))))
1963            (forward-char 1)
1964            name))
1965         ((eq (char-after) ?{)
1966          (imap-parse-literal))))
1967
1968 ;;   nil             = "NIL"
1969
1970 (defsubst imap-parse-nil ()
1971   (if (looking-at "NIL")
1972       (goto-char (match-end 0))))
1973
1974 ;;   nstring         = string / nil
1975
1976 (defsubst imap-parse-nstring ()
1977   (or (imap-parse-string)
1978       (and (imap-parse-nil)
1979            nil)))
1980
1981 ;;   astring         = atom / string
1982 ;;
1983 ;;   atom            = 1*ATOM-CHAR
1984 ;;
1985 ;;   ATOM-CHAR       = <any CHAR except atom-specials>
1986 ;;
1987 ;;   atom-specials   = "(" / ")" / "{" / SP / CTL / list-wildcards /
1988 ;;                     quoted-specials
1989 ;;
1990 ;;   list-wildcards  = "%" / "*"
1991 ;;
1992 ;;   quoted-specials = DQUOTE / "\"
1993
1994 (defsubst imap-parse-astring ()
1995   (or (imap-parse-string)
1996       (buffer-substring (point)
1997                         (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1998                             (goto-char (1- (match-end 0)))
1999                           (end-of-line)
2000                           (point)))))
2001
2002 ;;   address         = "(" addr-name SP addr-adl SP addr-mailbox SP
2003 ;;                      addr-host ")"
2004 ;;
2005 ;;   addr-adl        = nstring
2006 ;;                       ; Holds route from [RFC-822] route-addr if
2007 ;;                       ; non-nil
2008 ;;
2009 ;;   addr-host       = nstring
2010 ;;                       ; nil indicates [RFC-822] group syntax.
2011 ;;                       ; Otherwise, holds [RFC-822] domain name
2012 ;;
2013 ;;   addr-mailbox    = nstring
2014 ;;                       ; nil indicates end of [RFC-822] group; if
2015 ;;                       ; non-nil and addr-host is nil, holds
2016 ;;                       ; [RFC-822] group name.
2017 ;;                       ; Otherwise, holds [RFC-822] local-part
2018 ;;                       ; after removing [RFC-822] quoting
2019 ;;
2020 ;;   addr-name       = nstring
2021 ;;                       ; If non-nil, holds phrase from [RFC-822]
2022 ;;                       ; mailbox after removing [RFC-822] quoting
2023 ;;
2024
2025 (defsubst imap-parse-address ()
2026   (let (address)
2027     (when (eq (char-after) ?\()
2028       (imap-forward)
2029       (setq address (vector (prog1 (imap-parse-nstring)
2030                               (imap-forward))
2031                             (prog1 (imap-parse-nstring)
2032                               (imap-forward))
2033                             (prog1 (imap-parse-nstring)
2034                               (imap-forward))
2035                             (imap-parse-nstring)))
2036       (when (eq (char-after) ?\))
2037         (imap-forward)
2038         address))))
2039
2040 ;;   address-list    = "(" 1*address ")" / nil
2041 ;;
2042 ;;   nil             = "NIL"
2043
2044 (defsubst imap-parse-address-list ()
2045   (if (eq (char-after) ?\()
2046       (let (address addresses)
2047         (imap-forward)
2048         (while (and (not (eq (char-after) ?\)))
2049                     ;; next line for MS Exchange bug
2050                     (progn (and (eq (char-after) ? ) (imap-forward)) t)
2051                     (setq address (imap-parse-address)))
2052           (setq addresses (cons address addresses)))
2053         (when (eq (char-after) ?\))
2054           (imap-forward)
2055           (nreverse addresses)))
2056     (assert (imap-parse-nil) t "In imap-parse-address-list")))
2057
2058 ;;   mailbox         = "INBOX" / astring
2059 ;;                       ; INBOX is case-insensitive.  All case variants of
2060 ;;                       ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX
2061 ;;                       ; not as an astring.  An astring which consists of
2062 ;;                       ; the case-insensitive sequence "I" "N" "B" "O" "X"
2063 ;;                       ; is considered to be INBOX and not an astring.
2064 ;;                       ;  Refer to section 5.1 for further
2065 ;;                       ; semantic details of mailbox names.
2066
2067 (defsubst imap-parse-mailbox ()
2068   (let ((mailbox (imap-parse-astring)))
2069     (if (string-equal "INBOX" (upcase mailbox))
2070         "INBOX"
2071       mailbox)))
2072
2073 ;;   greeting        = "*" SP (resp-cond-auth / resp-cond-bye) CRLF
2074 ;;
2075 ;;   resp-cond-auth  = ("OK" / "PREAUTH") SP resp-text
2076 ;;                       ; Authentication condition
2077 ;;
2078 ;;   resp-cond-bye   = "BYE" SP resp-text
2079
2080 (defun imap-parse-greeting ()
2081   "Parse a IMAP greeting."
2082   (cond ((looking-at "\\* OK ")
2083          (setq imap-state 'nonauth))
2084         ((looking-at "\\* PREAUTH ")
2085          (setq imap-state 'auth))
2086         ((looking-at "\\* BYE ")
2087          (setq imap-state 'closed))))
2088
2089 ;;   response        = *(continue-req / response-data) response-done
2090 ;;
2091 ;;   continue-req    = "+" SP (resp-text / base64) CRLF
2092 ;;
2093 ;;   response-data   = "*" SP (resp-cond-state / resp-cond-bye /
2094 ;;                     mailbox-data / message-data / capability-data) CRLF
2095 ;;
2096 ;;   response-done   = response-tagged / response-fatal
2097 ;;
2098 ;;   response-fatal  = "*" SP resp-cond-bye CRLF
2099 ;;                       ; Server closes connection immediately
2100 ;;
2101 ;;   response-tagged = tag SP resp-cond-state CRLF
2102 ;;
2103 ;;   resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text
2104 ;;                       ; Status condition
2105 ;;
2106 ;;   resp-cond-bye   = "BYE" SP resp-text
2107 ;;
2108 ;;   mailbox-data    =  "FLAGS" SP flag-list /
2109 ;;                      "LIST" SP mailbox-list /
2110 ;;                      "LSUB" SP mailbox-list /
2111 ;;                      "SEARCH" *(SP nz-number) /
2112 ;;                      "STATUS" SP mailbox SP "("
2113 ;;                            [status-att SP number *(SP status-att SP number)] ")" /
2114 ;;                      number SP "EXISTS" /
2115 ;;                      number SP "RECENT"
2116 ;;
2117 ;;   message-data    = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att))
2118 ;;
2119 ;;   capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1"
2120 ;;                     *(SP capability)
2121 ;;                       ; IMAP4rev1 servers which offer RFC 1730
2122 ;;                       ; compatibility MUST list "IMAP4" as the first
2123 ;;                       ; capability.
2124
2125 (defun imap-parse-response ()
2126   "Parse a IMAP command response."
2127   (let (token)
2128     (case (setq token (read (current-buffer)))
2129       (+ (setq imap-continuation
2130                (or (buffer-substring (min (point-max) (1+ (point)))
2131                                      (point-max))
2132                    t)))
2133       (* (case (prog1 (setq token (read (current-buffer)))
2134                  (imap-forward))
2135            (OK         (imap-parse-resp-text))
2136            (NO         (imap-parse-resp-text))
2137            (BAD        (imap-parse-resp-text))
2138            (BYE        (imap-parse-resp-text))
2139            (FLAGS      (imap-mailbox-put 'flags (imap-parse-flag-list)))
2140            (LIST       (imap-parse-data-list 'list))
2141            (LSUB       (imap-parse-data-list 'lsub))
2142            (SEARCH     (imap-mailbox-put
2143                         'search
2144                         (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
2145            (STATUS     (imap-parse-status))
2146            (CAPABILITY (setq imap-capability
2147                                (read (concat "(" (upcase (buffer-substring
2148                                                           (point) (point-max)))
2149                                              ")"))))
2150            (ID         (setq imap-id (read (buffer-substring (point)
2151                                                              (point-max)))))
2152            (ACL        (imap-parse-acl))
2153            (t       (case (prog1 (read (current-buffer))
2154                             (imap-forward))
2155                       (EXISTS  (imap-mailbox-put 'exists token))
2156                       (RECENT  (imap-mailbox-put 'recent token))
2157                       (EXPUNGE t)
2158                       (FETCH   (imap-parse-fetch token))
2159                       (t       (message "Garbage: %s" (buffer-string)))))))
2160       (t (let (status)
2161            (if (not (integerp token))
2162                (message "Garbage: %s" (buffer-string))
2163              (case (prog1 (setq status (read (current-buffer)))
2164                      (imap-forward))
2165                (OK  (progn
2166                       (setq imap-reached-tag (max imap-reached-tag token))
2167                       (imap-parse-resp-text)))
2168                (NO  (progn
2169                       (setq imap-reached-tag (max imap-reached-tag token))
2170                       (save-excursion
2171                         (imap-parse-resp-text))
2172                       (let (code text)
2173                         (when (eq (char-after) ?\[)
2174                           (setq code (buffer-substring (point)
2175                                                        (search-forward "]")))
2176                           (imap-forward))
2177                         (setq text (buffer-substring (point) (point-max)))
2178                         (push (list token status code text)
2179                               imap-failed-tags))))
2180                (BAD (progn
2181                       (setq imap-reached-tag (max imap-reached-tag token))
2182                       (save-excursion
2183                         (imap-parse-resp-text))
2184                       (let (code text)
2185                         (when (eq (char-after) ?\[)
2186                           (setq code (buffer-substring (point)
2187                                                        (search-forward "]")))
2188                           (imap-forward))
2189                         (setq text (buffer-substring (point) (point-max)))
2190                         (push (list token status code text) imap-failed-tags)
2191                         (error "Internal error, tag %s status %s code %s text %s"
2192                                token status code text))))
2193                (t   (message "Garbage: %s" (buffer-string))))
2194              (when (assq token imap-callbacks)
2195                (funcall (cdr (assq token imap-callbacks)) token status)
2196                (setq imap-callbacks
2197                      (imap-remassoc token imap-callbacks)))))))))
2198
2199 ;;   resp-text       = ["[" resp-text-code "]" SP] text
2200 ;;
2201 ;;   text            = 1*TEXT-CHAR
2202 ;;
2203 ;;   TEXT-CHAR       = <any CHAR except CR and LF>
2204
2205 (defun imap-parse-resp-text ()
2206   (imap-parse-resp-text-code))
2207
2208 ;;   resp-text-code  = "ALERT" /
2209 ;;                     "BADCHARSET [SP "(" astring *(SP astring) ")" ] /
2210 ;;                     "NEWNAME" SP string SP string /
2211 ;;                     "PARSE" /
2212 ;;                     "PERMANENTFLAGS" SP "("
2213 ;;                               [flag-perm *(SP flag-perm)] ")" /
2214 ;;                     "READ-ONLY" /
2215 ;;                     "READ-WRITE" /
2216 ;;                     "TRYCREATE" /
2217 ;;                     "UIDNEXT" SP nz-number /
2218 ;;                     "UIDVALIDITY" SP nz-number /
2219 ;;                     "UNSEEN" SP nz-number /
2220 ;;                     resp-text-atom [SP 1*<any TEXT-CHAR except "]">]
2221 ;;
2222 ;;   resp_code_apnd  = "APPENDUID" SPACE nz_number SPACE uniqueid
2223 ;;
2224 ;;   resp_code_copy  = "COPYUID" SPACE nz_number SPACE set SPACE set
2225 ;;
2226 ;;   set             = sequence-num / (sequence-num ":" sequence-num) /
2227 ;;                        (set "," set)
2228 ;;                          ; Identifies a set of messages.  For message
2229 ;;                          ; sequence numbers, these are consecutive
2230 ;;                          ; numbers from 1 to the number of messages in
2231 ;;                          ; the mailbox
2232 ;;                          ; Comma delimits individual numbers, colon
2233 ;;                          ; delimits between two numbers inclusive.
2234 ;;                          ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13,
2235 ;;                          ; 14,15 for a mailbox with 15 messages.
2236 ;;
2237 ;;   sequence-num    = nz-number / "*"
2238 ;;                          ; * is the largest number in use.  For message
2239 ;;                          ; sequence numbers, it is the number of messages
2240 ;;                          ; in the mailbox.  For unique identifiers, it is
2241 ;;                          ; the unique identifier of the last message in
2242 ;;                          ; the mailbox.
2243 ;;
2244 ;;   flag-perm       = flag / "\*"
2245 ;;
2246 ;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
2247 ;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
2248 ;;                       ; Does not include "\Recent"
2249 ;;
2250 ;;   flag-extension  = "\" atom
2251 ;;                       ; Future expansion.  Client implementations
2252 ;;                       ; MUST accept flag-extension flags.  Server
2253 ;;                       ; implementations MUST NOT generate
2254 ;;                       ; flag-extension flags except as defined by
2255 ;;                       ; future standard or standards-track
2256 ;;                       ; revisions of this specification.
2257 ;;
2258 ;;   flag-keyword    = atom
2259 ;;
2260 ;;   resp-text-atom  = 1*<any ATOM-CHAR except "]">
2261
2262 (defun imap-parse-resp-text-code ()
2263   ;; xxx next line for stalker communigate pro 3.3.1 bug
2264   (when (looking-at " \\[")
2265     (imap-forward))
2266   (when (eq (char-after) ?\[)
2267     (imap-forward)
2268     (cond ((search-forward "PERMANENTFLAGS " nil t)
2269            (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))
2270           ((search-forward "UIDNEXT \\([0-9]+\\)" nil t)
2271            (imap-mailbox-put 'uidnext (match-string 1)))
2272           ((search-forward "UNSEEN " nil t)
2273            (imap-mailbox-put 'first-unseen (read (current-buffer))))
2274           ((looking-at "UIDVALIDITY \\([0-9]+\\)")
2275            (imap-mailbox-put 'uidvalidity (match-string 1)))
2276           ((search-forward "READ-ONLY" nil t)
2277            (imap-mailbox-put 'read-only t))
2278           ((search-forward "NEWNAME " nil t)
2279            (let (oldname newname)
2280              (setq oldname (imap-parse-string))
2281              (imap-forward)
2282              (setq newname (imap-parse-string))
2283              (imap-mailbox-put 'newname newname oldname)))
2284           ((search-forward "TRYCREATE" nil t)
2285            (imap-mailbox-put 'trycreate t imap-current-target-mailbox))
2286           ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
2287            (imap-mailbox-put 'appenduid
2288                              (list (match-string 1)
2289                                    (string-to-number (match-string 2)))
2290                              imap-current-target-mailbox))
2291           ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
2292            (imap-mailbox-put 'copyuid (list (match-string 1)
2293                                             (match-string 2)
2294                                             (match-string 3))
2295                              imap-current-target-mailbox))
2296           ((search-forward "ALERT] " nil t)
2297            (message "Imap server %s information: %s" imap-server
2298                     (buffer-substring (point) (point-max)))))))
2299
2300 ;;   mailbox-list    = "(" [mbx-list-flags] ")" SP
2301 ;;                      (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox
2302 ;;
2303 ;;   mbx-list-flags  = *(mbx-list-oflag SP) mbx-list-sflag
2304 ;;                     *(SP mbx-list-oflag) /
2305 ;;                     mbx-list-oflag *(SP mbx-list-oflag)
2306 ;;
2307 ;;   mbx-list-oflag  = "\Noinferiors" / flag-extension
2308 ;;                       ; Other flags; multiple possible per LIST response
2309 ;;
2310 ;;   mbx-list-sflag  = "\Noselect" / "\Marked" / "\Unmarked"
2311 ;;                       ; Selectability flags; only one per LIST response
2312 ;;
2313 ;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
2314 ;;                     "\" quoted-specials
2315 ;;
2316 ;;   quoted-specials = DQUOTE / "\"
2317
2318 (defun imap-parse-data-list (type)
2319   (let (flags delimiter mailbox)
2320     (setq flags (imap-parse-flag-list))
2321     (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
2322       (setq delimiter (match-string 1))
2323       (goto-char (1+ (match-end 0)))
2324       (when (setq mailbox (imap-parse-mailbox))
2325         (imap-mailbox-put type t mailbox)
2326         (imap-mailbox-put 'list-flags flags mailbox)
2327         (imap-mailbox-put 'delimiter delimiter mailbox)))))
2328
2329 ;;  msg_att         ::= "(" 1#("ENVELOPE" SPACE envelope /
2330 ;;                      "FLAGS" SPACE "(" #(flag / "\Recent") ")" /
2331 ;;                      "INTERNALDATE" SPACE date_time /
2332 ;;                      "RFC822" [".HEADER" / ".TEXT"] SPACE nstring /
2333 ;;                      "RFC822.SIZE" SPACE number /
2334 ;;                      "BODY" ["STRUCTURE"] SPACE body /
2335 ;;                      "BODY" section ["<" number ">"] SPACE nstring /
2336 ;;                      "UID" SPACE uniqueid) ")"
2337 ;;
2338 ;;  date_time       ::= <"> date_day_fixed "-" date_month "-" date_year
2339 ;;                      SPACE time SPACE zone <">
2340 ;;
2341 ;;  section         ::= "[" [section_text / (nz_number *["." nz_number]
2342 ;;                      ["." (section_text / "MIME")])] "]"
2343 ;;
2344 ;;  section_text    ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
2345 ;;                      SPACE header_list / "TEXT"
2346 ;;
2347 ;;  header_fld_name ::= astring
2348 ;;
2349 ;;  header_list     ::= "(" 1#header_fld_name ")"
2350
2351 (defsubst imap-parse-header-list ()
2352   (when (eq (char-after) ?\()
2353     (let (strlist)
2354       (while (not (eq (char-after) ?\)))
2355         (imap-forward)
2356         (push (imap-parse-astring) strlist))
2357       (imap-forward)
2358       (nreverse strlist))))
2359
2360 (defsubst imap-parse-fetch-body-section ()
2361   (let ((section
2362          (buffer-substring (point) (1- (re-search-forward "[] ]" nil t)))))
2363     (if (eq (char-before) ? )
2364         (prog1
2365             (mapconcat 'identity (cons section (imap-parse-header-list)) " ")
2366           (search-forward "]" nil t))
2367       section)))
2368
2369 (defun imap-parse-fetch (response)
2370   (when (eq (char-after) ?\()
2371     (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
2372               rfc822size body bodydetail bodystructure flags-empty)
2373       (while (not (eq (char-after) ?\)))
2374         (imap-forward)
2375         (let ((token (read (current-buffer))))
2376           (imap-forward)
2377           (cond ((eq token 'UID)
2378                  (setq uid (condition-case ()
2379                                (read (current-buffer))
2380                              (error))))
2381                 ((eq token 'FLAGS)
2382                  (setq flags (imap-parse-flag-list))
2383                  (if (not flags)
2384                      (setq flags-empty 't)))
2385                 ((eq token 'ENVELOPE)
2386                  (setq envelope (imap-parse-envelope)))
2387                 ((eq token 'INTERNALDATE)
2388                  (setq internaldate (imap-parse-string)))
2389                 ((eq token 'RFC822)
2390                  (setq rfc822 (imap-parse-nstring)))
2391                 ((eq token 'RFC822.HEADER)
2392                  (setq rfc822header (imap-parse-nstring)))
2393                 ((eq token 'RFC822.TEXT)
2394                  (setq rfc822text (imap-parse-nstring)))
2395                 ((eq token 'RFC822.SIZE)
2396                  (setq rfc822size (read (current-buffer))))
2397                 ((eq token 'BODY)
2398                  (if (eq (char-before) ?\[)
2399                      (push (list
2400                             (upcase (imap-parse-fetch-body-section))
2401                             (and (eq (char-after) ?<)
2402                                  (buffer-substring (1+ (point))
2403                                                    (search-forward ">" nil t)))
2404                             (progn (imap-forward)
2405                                    (imap-parse-nstring)))
2406                            bodydetail)
2407                    (setq body (imap-parse-body))))
2408                 ((eq token 'BODYSTRUCTURE)
2409                  (setq bodystructure (imap-parse-body))))))
2410       (when uid
2411         (setq imap-current-message uid)
2412         (imap-message-put uid 'UID uid)
2413         (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags))
2414         (and envelope (imap-message-put uid 'ENVELOPE envelope))
2415         (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))
2416         (and rfc822 (imap-message-put uid 'RFC822 rfc822))
2417         (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header))
2418         (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text))
2419         (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size))
2420         (and body (imap-message-put uid 'BODY body))
2421         (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail))
2422         (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure))
2423         (run-hooks 'imap-fetch-data-hook)))))
2424
2425 ;;   mailbox-data    =  ...
2426 ;;                      "STATUS" SP mailbox SP "("
2427 ;;                            [status-att SP number
2428 ;;                            *(SP status-att SP number)] ")"
2429 ;;                      ...
2430 ;;
2431 ;;   status-att      = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" /
2432 ;;                     "UNSEEN"
2433
2434 (defun imap-parse-status ()
2435   (let ((mailbox (imap-parse-mailbox)))
2436     (if (eq (char-after) ? )
2437         (forward-char))
2438     (when (and mailbox (eq (char-after) ?\())
2439       (while (and (not (eq (char-after) ?\)))
2440                   (or (forward-char) t)
2441                   (looking-at "\\([A-Za-z]+\\) "))
2442         (let ((token (match-string 1)))
2443           (goto-char (match-end 0))
2444           (cond ((string= token "MESSAGES")
2445                  (imap-mailbox-put 'messages (read (current-buffer)) mailbox))
2446                 ((string= token "RECENT")
2447                  (imap-mailbox-put 'recent (read (current-buffer)) mailbox))
2448                 ((string= token "UIDNEXT")
2449                  (and (looking-at "[0-9]+")
2450                       (imap-mailbox-put 'uidnext (match-string 0) mailbox)
2451                       (goto-char (match-end 0))))
2452                 ((string= token "UIDVALIDITY")
2453                  (and (looking-at "[0-9]+")
2454                       (imap-mailbox-put 'uidvalidity (match-string 0) mailbox)
2455                       (goto-char (match-end 0))))
2456                 ((string= token "UNSEEN")
2457                  (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))
2458                 (t
2459                  (message "Unknown status data %s in mailbox %s ignored"
2460                           token mailbox)
2461                  (read (current-buffer)))))))))
2462
2463 ;;   acl_data        ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
2464 ;;                        rights)
2465 ;;
2466 ;;   identifier      ::= astring
2467 ;;
2468 ;;   rights          ::= astring
2469
2470 (defun imap-parse-acl ()
2471   (let ((mailbox (imap-parse-mailbox))
2472         identifier rights acl)
2473     (while (eq (char-after) ?\ )
2474       (imap-forward)
2475       (setq identifier (imap-parse-astring))
2476       (imap-forward)
2477       (setq rights (imap-parse-astring))
2478       (setq acl (append acl (list (cons identifier rights)))))
2479     (imap-mailbox-put 'acl acl mailbox)))
2480
2481 ;;   flag-list       = "(" [flag *(SP flag)] ")"
2482 ;;
2483 ;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
2484 ;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
2485 ;;                       ; Does not include "\Recent"
2486 ;;
2487 ;;   flag-keyword    = atom
2488 ;;
2489 ;;   flag-extension  = "\" atom
2490 ;;                       ; Future expansion.  Client implementations
2491 ;;                       ; MUST accept flag-extension flags.  Server
2492 ;;                       ; implementations MUST NOT generate
2493 ;;                       ; flag-extension flags except as defined by
2494 ;;                       ; future standard or standards-track
2495 ;;                       ; revisions of this specification.
2496
2497 (defun imap-parse-flag-list ()
2498   (let (flag-list start)
2499     (assert (eq (char-after) ?\() nil "In imap-parse-flag-list")
2500     (while (and (not (eq (char-after) ?\)))
2501                 (setq start (progn
2502                               (imap-forward)
2503                               ;; next line for Courier IMAP bug.
2504                               (skip-chars-forward " ")
2505                               (point)))
2506                 (> (skip-chars-forward "^ )" (point-at-eol)) 0))
2507       (push (buffer-substring start (point)) flag-list))
2508     (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list")
2509     (imap-forward)
2510     (nreverse flag-list)))
2511
2512 ;;   envelope        = "(" env-date SP env-subject SP env-from SP env-sender SP
2513 ;;                     env-reply-to SP env-to SP env-cc SP env-bcc SP
2514 ;;                     env-in-reply-to SP env-message-id ")"
2515 ;;
2516 ;;   env-bcc         = "(" 1*address ")" / nil
2517 ;;
2518 ;;   env-cc          = "(" 1*address ")" / nil
2519 ;;
2520 ;;   env-date        = nstring
2521 ;;
2522 ;;   env-from        = "(" 1*address ")" / nil
2523 ;;
2524 ;;   env-in-reply-to = nstring
2525 ;;
2526 ;;   env-message-id  = nstring
2527 ;;
2528 ;;   env-reply-to    = "(" 1*address ")" / nil
2529 ;;
2530 ;;   env-sender      = "(" 1*address ")" / nil
2531 ;;
2532 ;;   env-subject     = nstring
2533 ;;
2534 ;;   env-to          = "(" 1*address ")" / nil
2535
2536 (defun imap-parse-envelope ()
2537   (when (eq (char-after) ?\()
2538     (imap-forward)
2539     (vector (prog1 (imap-parse-nstring) ;; date
2540               (imap-forward))
2541             (prog1 (imap-parse-nstring) ;; subject
2542               (imap-forward))
2543             (prog1 (imap-parse-address-list) ;; from
2544               (imap-forward))
2545             (prog1 (imap-parse-address-list) ;; sender
2546               (imap-forward))
2547             (prog1 (imap-parse-address-list) ;; reply-to
2548               (imap-forward))
2549             (prog1 (imap-parse-address-list) ;; to
2550               (imap-forward))
2551             (prog1 (imap-parse-address-list) ;; cc
2552               (imap-forward))
2553             (prog1 (imap-parse-address-list) ;; bcc
2554               (imap-forward))
2555             (prog1 (imap-parse-nstring) ;; in-reply-to
2556               (imap-forward))
2557             (prog1 (imap-parse-nstring) ;; message-id
2558               (imap-forward)))))
2559
2560 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2561
2562 (defsubst imap-parse-string-list ()
2563   (cond ((eq (char-after) ?\() ;; body-fld-param
2564          (let (strlist str)
2565            (imap-forward)
2566            (while (setq str (imap-parse-string))
2567              (push str strlist)
2568              ;; buggy stalker communigate pro 3.0 doesn't print SPC
2569              ;; between body-fld-param's sometimes
2570              (or (eq (char-after) ?\")
2571                  (imap-forward)))
2572            (nreverse strlist)))
2573         ((imap-parse-nil)
2574          nil)))
2575
2576 ;;   body-extension  = nstring / number /
2577 ;;                      "(" body-extension *(SP body-extension) ")"
2578 ;;                       ; Future expansion.  Client implementations
2579 ;;                       ; MUST accept body-extension fields.  Server
2580 ;;                       ; implementations MUST NOT generate
2581 ;;                       ; body-extension fields except as defined by
2582 ;;                       ; future standard or standards-track
2583 ;;                       ; revisions of this specification.
2584
2585 (defun imap-parse-body-extension ()
2586   (if (eq (char-after) ?\()
2587       (let (b-e)
2588         (imap-forward)
2589         (push (imap-parse-body-extension) b-e)
2590         (while (eq (char-after) ?\ )
2591           (imap-forward)
2592           (push (imap-parse-body-extension) b-e))
2593         (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension")
2594         (imap-forward)
2595         (nreverse b-e))
2596     (or (imap-parse-number)
2597         (imap-parse-nstring))))
2598
2599 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2600 ;;                     *(SP body-extension)]]
2601 ;;                       ; MUST NOT be returned on non-extensible
2602 ;;                       ; "BODY" fetch
2603 ;;
2604 ;;   body-ext-mpart  = body-fld-param [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 (defsubst imap-parse-body-ext ()
2610   (let (ext)
2611     (when (eq (char-after) ?\ ) ;; body-fld-dsp
2612       (imap-forward)
2613       (let (dsp)
2614         (if (eq (char-after) ?\()
2615             (progn
2616               (imap-forward)
2617               (push (imap-parse-string) dsp)
2618               (imap-forward)
2619               (push (imap-parse-string-list) dsp)
2620               (imap-forward))
2621           (assert (imap-parse-nil) t "In imap-parse-body-ext"))
2622         (push (nreverse dsp) ext))
2623       (when (eq (char-after) ?\ ) ;; body-fld-lang
2624         (imap-forward)
2625         (if (eq (char-after) ?\()
2626             (push (imap-parse-string-list) ext)
2627           (push (imap-parse-nstring) ext))
2628         (while (eq (char-after) ?\ ) ;; body-extension
2629           (imap-forward)
2630           (setq ext (append (imap-parse-body-extension) ext)))))
2631     ext))
2632
2633 ;;   body            = "(" body-type-1part / body-type-mpart ")"
2634 ;;
2635 ;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
2636 ;;                     *(SP body-extension)]]
2637 ;;                       ; MUST NOT be returned on non-extensible
2638 ;;                       ; "BODY" fetch
2639 ;;
2640 ;;   body-ext-mpart  = body-fld-param [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-fields     = body-fld-param SP body-fld-id SP body-fld-desc SP
2646 ;;                     body-fld-enc SP body-fld-octets
2647 ;;
2648 ;;   body-fld-desc   = nstring
2649 ;;
2650 ;;   body-fld-dsp    = "(" string SP body-fld-param ")" / nil
2651 ;;
2652 ;;   body-fld-enc    = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
2653 ;;                     "QUOTED-PRINTABLE") DQUOTE) / string
2654 ;;
2655 ;;   body-fld-id     = nstring
2656 ;;
2657 ;;   body-fld-lang   = nstring / "(" string *(SP string) ")"
2658 ;;
2659 ;;   body-fld-lines  = number
2660 ;;
2661 ;;   body-fld-md5    = nstring
2662 ;;
2663 ;;   body-fld-octets = number
2664 ;;
2665 ;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
2666 ;;
2667 ;;   body-type-1part = (body-type-basic / body-type-msg / body-type-text)
2668 ;;                     [SP body-ext-1part]
2669 ;;
2670 ;;   body-type-basic = media-basic SP body-fields
2671 ;;                       ; MESSAGE subtype MUST NOT be "RFC822"
2672 ;;
2673 ;;   body-type-msg   = media-message SP body-fields SP envelope
2674 ;;                     SP body SP body-fld-lines
2675 ;;
2676 ;;   body-type-text  = media-text SP body-fields SP body-fld-lines
2677 ;;
2678 ;;   body-type-mpart = 1*body SP media-subtype
2679 ;;                     [SP body-ext-mpart]
2680 ;;
2681 ;;   media-basic     = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
2682 ;;                     "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
2683 ;;                       ; Defined in [MIME-IMT]
2684 ;;
2685 ;;   media-message   = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
2686 ;;                      ; Defined in [MIME-IMT]
2687 ;;
2688 ;;   media-subtype   = string
2689 ;;                       ; Defined in [MIME-IMT]
2690 ;;
2691 ;;   media-text      = DQUOTE "TEXT" DQUOTE SP media-subtype
2692 ;;                       ; Defined in [MIME-IMT]
2693
2694 (defun imap-parse-body ()
2695   (let (body)
2696     (when (eq (char-after) ?\()
2697       (imap-forward)
2698       (if (eq (char-after) ?\()
2699           (let (subbody)
2700             (while (and (eq (char-after) ?\()
2701                         (setq subbody (imap-parse-body)))
2702               ;; buggy stalker communigate pro 3.0 insert a SPC between
2703               ;; parts in multiparts
2704               (when (and (eq (char-after) ?\ )
2705                          (eq (char-after (1+ (point))) ?\())
2706                 (imap-forward))
2707               (push subbody body))
2708             (imap-forward)
2709             (push (imap-parse-string) body) ;; media-subtype
2710             (when (eq (char-after) ?\ ) ;; body-ext-mpart:
2711               (imap-forward)
2712               (if (eq (char-after) ?\() ;; body-fld-param
2713                   (push (imap-parse-string-list) body)
2714                 (push (and (imap-parse-nil) nil) body))
2715               (setq body
2716                     (append (imap-parse-body-ext) body))) ;; body-ext-...
2717             (assert (eq (char-after) ?\)) nil "In imap-parse-body")
2718             (imap-forward)
2719             (nreverse body))
2720
2721         (push (imap-parse-string) body) ;; media-type
2722         (imap-forward)
2723         (push (imap-parse-string) body) ;; media-subtype
2724         (imap-forward)
2725         ;; next line for Sun SIMS bug
2726         (and (eq (char-after) ? ) (imap-forward))
2727         (if (eq (char-after) ?\() ;; body-fld-param
2728             (push (imap-parse-string-list) body)
2729           (push (and (imap-parse-nil) nil) body))
2730         (imap-forward)
2731         (push (imap-parse-nstring) body) ;; body-fld-id
2732         (imap-forward)
2733         (push (imap-parse-nstring) body) ;; body-fld-desc
2734         (imap-forward)
2735         ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
2736         ;; nstring and return nil instead of defaulting back to 7BIT
2737         ;; as the standard says.
2738         (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc
2739         (imap-forward)
2740         (push (imap-parse-number) body) ;; body-fld-octets
2741
2742         ;; ok, we're done parsing the required parts, what comes now is one
2743         ;; of three things:
2744         ;;
2745         ;; envelope       (then we're parsing body-type-msg)
2746         ;; body-fld-lines (then we're parsing body-type-text)
2747         ;; body-ext-1part (then we're parsing body-type-basic)
2748         ;;
2749         ;; the problem is that the two first are in turn optionally followed
2750         ;; by the third.  So we parse the first two here (if there are any)...
2751
2752         (when (eq (char-after) ?\ )
2753           (imap-forward)
2754           (let (lines)
2755             (cond ((eq (char-after) ?\() ;; body-type-msg:
2756                    (push (imap-parse-envelope) body) ;; envelope
2757                    (imap-forward)
2758                    (push (imap-parse-body) body) ;; body
2759                    ;; buggy stalker communigate pro 3.0 doesn't print
2760                    ;; number of lines in message/rfc822 attachment
2761                    (if (eq (char-after) ?\))
2762                        (push 0 body)
2763                      (imap-forward)
2764                      (push (imap-parse-number) body))) ;; body-fld-lines
2765                   ((setq lines (imap-parse-number)) ;; body-type-text:
2766                    (push lines body)) ;; body-fld-lines
2767                   (t
2768                    (backward-char))))) ;; no match...
2769
2770         ;; ...and then parse the third one here...
2771
2772         (when (eq (char-after) ?\ ) ;; body-ext-1part:
2773           (imap-forward)
2774           (push (imap-parse-nstring) body) ;; body-fld-md5
2775           (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
2776
2777         (assert (eq (char-after) ?\)) nil "In imap-parse-body 2")
2778         (imap-forward)
2779         (nreverse body)))))
2780
2781 (when imap-debug                        ; (untrace-all)
2782   (require 'trace)
2783   (buffer-disable-undo (get-buffer-create imap-debug-buffer))
2784   (mapcar (lambda (f) (trace-function-background f imap-debug-buffer))
2785           '(
2786             imap-utf7-encode
2787             imap-utf7-decode
2788             imap-error-text
2789             imap-kerberos4s-p
2790             imap-kerberos4-open
2791             imap-ssl-p
2792             imap-ssl-open
2793             imap-network-p
2794             imap-network-open
2795             imap-interactive-login
2796             imap-kerberos4a-p
2797             imap-kerberos4-auth
2798             imap-cram-md5-p
2799             imap-cram-md5-auth
2800             imap-login-p
2801             imap-login-auth
2802             imap-anonymous-p
2803             imap-anonymous-auth
2804             imap-open-1
2805             imap-open
2806             imap-opened
2807             imap-authenticate
2808             imap-close
2809             imap-capability
2810             imap-namespace
2811             imap-send-command-wait
2812             imap-mailbox-put
2813             imap-mailbox-get
2814             imap-mailbox-map-1
2815             imap-mailbox-map
2816             imap-current-mailbox
2817             imap-current-mailbox-p-1
2818             imap-current-mailbox-p
2819             imap-mailbox-select-1
2820             imap-mailbox-select
2821             imap-mailbox-examine-1
2822             imap-mailbox-examine
2823             imap-mailbox-unselect
2824             imap-mailbox-expunge
2825             imap-mailbox-close
2826             imap-mailbox-create-1
2827             imap-mailbox-create
2828             imap-mailbox-delete
2829             imap-mailbox-rename
2830             imap-mailbox-lsub
2831             imap-mailbox-list
2832             imap-mailbox-subscribe
2833             imap-mailbox-unsubscribe
2834             imap-mailbox-status
2835             imap-mailbox-acl-get
2836             imap-mailbox-acl-set
2837             imap-mailbox-acl-delete
2838             imap-current-message
2839             imap-list-to-message-set
2840             imap-fetch-asynch
2841             imap-fetch
2842             imap-message-put
2843             imap-message-get
2844             imap-message-map
2845             imap-search
2846             imap-message-flag-permanent-p
2847             imap-message-flags-set
2848             imap-message-flags-del
2849             imap-message-flags-add
2850             imap-message-copyuid-1
2851             imap-message-copyuid
2852             imap-message-copy
2853             imap-message-appenduid-1
2854             imap-message-appenduid
2855             imap-message-append
2856             imap-body-lines
2857             imap-envelope-from
2858             imap-send-command-1
2859             imap-send-command
2860             imap-wait-for-tag
2861             imap-sentinel
2862             imap-find-next-line
2863             imap-arrival-filter
2864             imap-parse-greeting
2865             imap-parse-response
2866             imap-parse-resp-text
2867             imap-parse-resp-text-code
2868             imap-parse-data-list
2869             imap-parse-fetch
2870             imap-parse-status
2871             imap-parse-acl
2872             imap-parse-flag-list
2873             imap-parse-envelope
2874             imap-parse-body-extension
2875             imap-parse-body
2876             )))
2877
2878 (provide 'imap)
2879
2880 ;;; imap.el ends here