cgit.sxemacs.org Git - gnus/blob - lisp/imap.el

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