Merge branch 'master' of http://git.gnus.org/gnus into SYgnus
authorSteve Youngs <steve@sxemacs.org>
Tue, 5 Jan 2016 00:00:55 +0000 (10:00 +1000)
committerSteve Youngs <steve@sxemacs.org>
Tue, 5 Jan 2016 00:00:55 +0000 (10:00 +1000)
.gitignore
lisp/dgnushack.el
lisp/gnus-start.el
lisp/imap.el [new file with mode: 0644]
lisp/smiley.el

index cd5b9fe..5e2b6b7 100644 (file)
@@ -77,3 +77,4 @@ texi/ps/Makefile
 lisp/*.orig
 texi/*.orig
 texi/*.info
+++log
index e276756..b1203e3 100644 (file)
@@ -345,6 +345,26 @@ This means that every warning will be reported as an error."
       (setq files (delete "gnus-icalendar.el" files))
       ;; Temporary during development.
       (setq files (delete "gnus-cloud.el" files)))
+    ;; Prefer XEmacs mail-lib pkg if installed
+    (when (and (featurep 'xemacs)
+              (locate-library "mail-lib/_pkg"))
+      (dolist (file
+              '("rfc2104.el" "netrc.el" "pop3.el" "starttls.el" "tls.el"))
+       (setq files (delete file files))))
+    ;; Prefer XEmacs ecrypto pkg if installed
+    (when (and (featurep 'xemacs)
+              (locate-library "ecrypto/_pkg"))
+      (dolist (file '("md4.el" "sha1.el" "hex-util.el"))
+       (setq files (delete file files))))
+    ;; Prefer XEmacs net-utils pkg if installed
+    (when (and (featurep 'xemacs)
+              (locate-library "net-utils/_pkg"))
+      (dolist (file '("dig.el" "dns.el" "dns-mode.el"))
+       (setq files (delete file files))))
+    ;; Prefer XEmacs text-modes pkg if installed
+    (when (and (featurep 'xemacs)
+              (locate-library "text-modes/_pkg"))
+      (setq files (delete "format-spec.el" files)))
     (dolist (file files)
       (setq file (expand-file-name file srcdir))
       (when (and (file-exists-p
index f03ff85..52a53a7 100644 (file)
@@ -30,7 +30,7 @@
 (require 'gnus-spec)
 (require 'gnus-range)
 (require 'gnus-util)
-(require 'gnus-cloud)
+(ignore-errors (require 'gnus-cloud))
 (autoload 'message-make-date "message")
 (autoload 'gnus-agent-read-servers-validate "gnus-agent")
 (autoload 'gnus-agent-save-local "gnus-agent")
diff --git a/lisp/imap.el b/lisp/imap.el
new file mode 100644 (file)
index 0000000..a478225
--- /dev/null
@@ -0,0 +1,3097 @@
+;;; imap.el --- imap library
+
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
+
+;; Author: Simon Josefsson <simon@josefsson.org>
+;; Keywords: mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; imap.el is an elisp library providing an interface for talking to
+;; IMAP servers.
+;;
+;; imap.el is roughly divided in two parts, one that parses IMAP
+;; responses from the server and storing data into buffer-local
+;; variables, and one for utility functions which send commands to
+;; server, waits for an answer, and return information.  The latter
+;; part is layered on top of the previous.
+;;
+;; The imap.el API consist of the following functions, other functions
+;; in this file should not be called directly and the result of doing
+;; so are at best undefined.
+;;
+;; Global commands:
+;;
+;; imap-open,       imap-opened,    imap-authenticate, imap-close,
+;; imap-capability, imap-namespace, imap-error-text
+;;
+;; Mailbox commands:
+;;
+;; imap-mailbox-get,       imap-mailbox-map,         imap-current-mailbox,
+;; imap-current-mailbox-p, imap-search,              imap-mailbox-select,
+;; imap-mailbox-examine,   imap-mailbox-unselect,    imap-mailbox-expunge
+;; imap-mailbox-close,     imap-mailbox-create,      imap-mailbox-delete
+;; imap-mailbox-rename,    imap-mailbox-lsub,        imap-mailbox-list
+;; imap-mailbox-subscribe, imap-mailbox-unsubscribe, imap-mailbox-status
+;; imap-mailbox-acl-get,   imap-mailbox-acl-set,     imap-mailbox-acl-delete
+;;
+;; Message commands:
+;;
+;; imap-fetch-asynch,                 imap-fetch,
+;; imap-current-message,              imap-list-to-message-set,
+;; imap-message-get,                  imap-message-map
+;; imap-message-envelope-date,        imap-message-envelope-subject,
+;; imap-message-envelope-from,        imap-message-envelope-sender,
+;; imap-message-envelope-reply-to,    imap-message-envelope-to,
+;; imap-message-envelope-cc,          imap-message-envelope-bcc
+;; imap-message-envelope-in-reply-to, imap-message-envelope-message-id
+;; imap-message-body,                 imap-message-flag-permanent-p
+;; imap-message-flags-set,            imap-message-flags-del
+;; imap-message-flags-add,            imap-message-copyuid
+;; imap-message-copy,                 imap-message-appenduid
+;; imap-message-append,               imap-envelope-from
+;; imap-body-lines
+;;
+;; It is my hope that these commands should be pretty self
+;; explanatory for someone that know IMAP.  All functions have
+;; additional documentation on how to invoke them.
+;;
+;; imap.el supports RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1).  The implemented
+;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
+;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
+;; LOGINDISABLED) (with use of external library starttls.el and
+;; program starttls), and the GSSAPI / Kerberos V4 sections of RFC1731
+;; (with use of external program `imtest'), and RFC2971 (ID).  It also
+;; takes advantage of the UNSELECT extension in Cyrus IMAPD.
+;;
+;; Without the work of John McClary Prevost and Jim Radford this library
+;; would not have seen the light of day.  Many thanks.
+;;
+;; This is a transcript of a short interactive session for demonstration
+;; purposes.
+;;
+;; (imap-open "my.mail.server")
+;; => " *imap* my.mail.server:0"
+;;
+;; The rest are invoked with current buffer as the buffer returned by
+;; `imap-open'.  It is possible to do it all without this, but it would
+;; look ugly here since `buffer' is always the last argument for all
+;; imap.el API functions.
+;;
+;; (imap-authenticate "myusername" "mypassword")
+;; => auth
+;;
+;; (imap-mailbox-lsub "*")
+;; => ("INBOX.sentmail" "INBOX.private" "INBOX.draft" "INBOX.spam")
+;;
+;; (imap-mailbox-list "INBOX.n%")
+;; => ("INBOX.namedroppers" "INBOX.nnimap" "INBOX.ntbugtraq")
+;;
+;; (imap-mailbox-select "INBOX.nnimap")
+;; => "INBOX.nnimap"
+;;
+;; (imap-mailbox-get 'exists)
+;; => 166
+;;
+;; (imap-mailbox-get 'uidvalidity)
+;; => "908992622"
+;;
+;; (imap-search "FLAGGED SINCE 18-DEC-98")
+;; => (235 236)
+;;
+;; (imap-fetch 235 "RFC822.PEEK" 'RFC822)
+;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <jas@pdc.kth.se>^M\r...."
+;;
+;; Todo:
+;;
+;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow.
+;;   Use IEEE floats (which are effectively exact)?  -- fx
+;; o Don't use `read' at all (important places already fixed)
+;; o Accept list of articles instead of message set string in most
+;;   imap-message-* functions.
+;; o Send strings as literal if they contain, e.g., ".
+;;
+;; Revision history:
+;;
+;;  - 19991218 added starttls/digest-md5 patch,
+;;             by Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;;             NB! you need SLIM for starttls.el and digest-md5.el
+;;  - 19991023 committed to pgnus
+;;
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+(eval-and-compile
+  (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
+  (autoload 'starttls-open-stream "starttls")
+  (autoload 'starttls-negotiate "starttls")
+  (autoload 'sasl-find-mechanism "sasl")
+  (autoload 'digest-md5-parse-digest-challenge "digest-md5")
+  (autoload 'digest-md5-digest-response "digest-md5")
+  (autoload 'digest-md5-digest-uri "digest-md5")
+  (autoload 'digest-md5-challenge "digest-md5")
+  (autoload 'rfc2104-hash "rfc2104")
+  (autoload 'utf7-encode "utf7")
+  (autoload 'utf7-decode "utf7")
+  (autoload 'format-spec "format-spec")
+  (autoload 'format-spec-make "format-spec")
+  (autoload 'open-tls-stream "tls"))
+
+;; User variables.
+
+(defgroup imap nil
+  "Low-level IMAP issues."
+  :version "21.1"
+  :group 'mail)
+
+(defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s"
+                                   "imtest -kp %s %p")
+  "List of strings containing commands for Kerberos 4 authentication.
+%s is replaced with server hostname, %p with port to connect to, and
+%l with the value of `imap-default-user'.  The program should accept
+IMAP commands on stdin and return responses to stdout.  Each entry in
+the list is tried until a successful connection is made."
+  :group 'imap
+  :type '(repeat string))
+
+(defcustom imap-gssapi-program (list
+                               (concat "gsasl %s %p "
+                                       "--mechanism GSSAPI "
+                                       "--authentication-id %l")
+                               "imtest -m gssapi -u %l -p %p %s")
+  "List of strings containing commands for GSSAPI (krb5) authentication.
+%s is replaced with server hostname, %p with port to connect to, and
+%l with the value of `imap-default-user'.  The program should accept
+IMAP commands on stdin and return responses to stdout.  Each entry in
+the list is tried until a successful connection is made."
+  :group 'imap
+  :type '(repeat string))
+
+(defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p"
+                             "openssl s_client -quiet -ssl2 -connect %s:%p"
+                             "s_client -quiet -ssl3 -connect %s:%p"
+                             "s_client -quiet -ssl2 -connect %s:%p")
+  "A string, or list of strings, containing commands for SSL connections.
+Within a string, %s is replaced with the server address and %p with
+port number on server.  The program should accept IMAP commands on
+stdin and return responses to stdout.  Each entry in the list is tried
+until a successful connection is made."
+  :group 'imap
+  :type '(choice string
+                (repeat string)))
+
+(defcustom imap-shell-program '("ssh %s imapd"
+                               "rsh %s imapd"
+                               "ssh %g ssh %s imapd"
+                               "rsh %g rsh %s imapd")
+  "A list of strings, containing commands for IMAP connection.
+Within a string, %s is replaced with the server address, %p with port
+number on server, %g with `imap-shell-host', and %l with
+`imap-default-user'.  The program should read IMAP commands from stdin
+and write IMAP response to stdout.  Each entry in the list is tried
+until a successful connection is made."
+  :group 'imap
+  :type '(repeat string))
+
+(defcustom imap-process-connection-type nil
+  "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL.
+The `process-connection-type' variable controls the type of device
+used to communicate with subprocesses.  Values are nil to use a
+pipe, or t or `pty' to use a pty.  The value has no effect if the
+system has no ptys or if all ptys are busy: then a pipe is used
+in any case.  The value takes effect when an IMAP server is
+opened; changing it after that has no effect."
+  :version "22.1"
+  :group 'imap
+  :type 'boolean)
+
+(defcustom imap-use-utf7 t
+  "If non-nil, do utf7 encoding/decoding of mailbox names.
+Since the UTF7 decoding currently only decodes into ISO-8859-1
+characters, you may disable this decoding if you need to access UTF7
+encoded mailboxes which doesn't translate into ISO-8859-1."
+  :group 'imap
+  :type 'boolean)
+
+(defcustom imap-log nil
+  "If non-nil, an imap session trace is placed in `imap-log-buffer'.
+Note that username, passwords and other privacy sensitive
+information (such as e-mail) may be stored in the buffer.
+It is not written to disk, however.  Do not enable this
+variable unless you are comfortable with that.
+
+See also `imap-debug'."
+  :group 'imap
+  :type 'boolean)
+
+(defcustom imap-debug nil
+  "If non-nil, trace imap- functions into `imap-debug-buffer'.
+Uses `trace-function-background', so you can turn it off with,
+say, `untrace-all'.
+
+Note that username, passwords and other privacy sensitive
+information (such as e-mail) may be stored in the buffer.
+It is not written to disk, however.  Do not enable this
+variable unless you are comfortable with that.
+
+This variable only takes effect when loading the `imap' library.
+See also `imap-log'."
+  :group 'imap
+  :type 'boolean)
+
+(defcustom imap-shell-host "gateway"
+  "Hostname of rlogin proxy."
+  :group 'imap
+  :type 'string)
+
+(defcustom imap-default-user (user-login-name)
+  "Default username to use."
+  :group 'imap
+  :type 'string)
+
+(defcustom imap-read-timeout (if (string-match
+                                 "windows-nt\\|os/2\\|emx\\|cygwin"
+                                 (symbol-name system-type))
+                                1.0
+                              0.1)
+  "*How long to wait between checking for the end of output.
+Shorter values mean quicker response, but is more CPU intensive."
+  :type 'number
+  :group 'imap)
+
+(defcustom imap-store-password nil
+  "If non-nil, store session password without prompting."
+  :group 'imap
+  :type 'boolean)
+
+;; Various variables.
+
+(defvar imap-fetch-data-hook nil
+  "Hooks called after receiving each FETCH response.")
+
+(defvar imap-streams '(gssapi kerberos4 starttls tls ssl network shell)
+  "Priority of streams to consider when opening connection to server.")
+
+(defvar imap-stream-alist
+  '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
+    (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
+    (tls       imap-tls-p              imap-tls-open)
+    (ssl       imap-ssl-p              imap-ssl-open)
+    (network   imap-network-p          imap-network-open)
+    (shell     imap-shell-p            imap-shell-open)
+    (starttls  imap-starttls-p         imap-starttls-open))
+  "Definition of network streams.
+
+\(NAME CHECK OPEN)
+
+NAME names the stream, CHECK is a function returning non-nil if the
+server support the stream and OPEN is a function for opening the
+stream.")
+
+(defvar imap-authenticators '(gssapi
+                             kerberos4
+                             digest-md5
+                             cram-md5
+                             ;;sasl
+                             login
+                             anonymous)
+  "Priority of authenticators to consider when authenticating to server.")
+
+(defvar imap-authenticator-alist
+  '((gssapi     imap-gssapi-auth-p    imap-gssapi-auth)
+    (kerberos4  imap-kerberos4-auth-p imap-kerberos4-auth)
+    (sasl      imap-sasl-auth-p      imap-sasl-auth)
+    (cram-md5   imap-cram-md5-p       imap-cram-md5-auth)
+    (login      imap-login-p          imap-login-auth)
+    (anonymous  imap-anonymous-p      imap-anonymous-auth)
+    (digest-md5 imap-digest-md5-p     imap-digest-md5-auth))
+  "Definition of authenticators.
+
+\(NAME CHECK AUTHENTICATE)
+
+NAME names the authenticator.  CHECK is a function returning non-nil if
+the server support the authenticator and AUTHENTICATE is a function
+for doing the actual authentication.")
+
+(defvar imap-error nil
+  "Error codes from the last command.")
+
+(defvar imap-logout-timeout nil
+  "Close server immediately if it can't logout in this number of seconds.
+If it is nil, never close server until logout completes.  Normally,
+the value of this variable will be bound to a certain value to which
+an application program that uses this module specifies on a per-server
+basis.")
+
+;; Internal constants.  Change these and die.
+
+(defconst imap-default-port 143)
+(defconst imap-default-ssl-port 993)
+(defconst imap-default-tls-port 993)
+(defconst imap-default-stream 'network)
+(defconst imap-coding-system-for-read 'binary)
+(defconst imap-coding-system-for-write 'binary)
+(defconst imap-local-variables '(imap-server
+                                imap-port
+                                imap-client-eol
+                                imap-server-eol
+                                imap-auth
+                                imap-stream
+                                imap-username
+                                imap-password
+                                imap-current-mailbox
+                                imap-current-target-mailbox
+                                imap-message-data
+                                imap-capability
+                                imap-id
+                                imap-namespace
+                                imap-state
+                                imap-reached-tag
+                                imap-failed-tags
+                                imap-tag
+                                imap-process
+                                imap-calculate-literal-size-first
+                                imap-mailbox-data))
+(defconst imap-log-buffer "*imap-log*")
+(defconst imap-debug-buffer "*imap-debug*")
+
+;; Internal variables.
+
+(defvar imap-stream nil)
+(defvar imap-auth nil)
+(defvar imap-server nil)
+(defvar imap-port nil)
+(defvar imap-username nil)
+(defvar imap-password nil)
+(defvar imap-last-authenticator nil)
+(defvar imap-calculate-literal-size-first nil)
+(defvar imap-state 'closed
+  "IMAP state.
+Valid states are `closed', `initial', `nonauth', `auth', `selected'
+and `examine'.")
+
+(defvar imap-server-eol "\r\n"
+  "The EOL string sent from the server.")
+
+(defvar imap-client-eol "\r\n"
+  "The EOL string we send to the server.")
+
+(defvar imap-current-mailbox nil
+  "Current mailbox name.")
+
+(defvar imap-current-target-mailbox nil
+  "Current target mailbox for COPY and APPEND commands.")
+
+(defvar imap-mailbox-data nil
+  "Obarray with mailbox data.")
+
+(defvar imap-mailbox-prime 997
+  "Length of `imap-mailbox-data'.")
+
+(defvar imap-current-message nil
+  "Current message number.")
+
+(defvar imap-message-data nil
+  "Obarray with message data.")
+
+(defvar imap-message-prime 997
+  "Length of `imap-message-data'.")
+
+(defvar imap-capability nil
+  "Capability for server.")
+
+(defvar imap-id nil
+  "Identity of server.
+See RFC 2971.")
+
+(defvar imap-namespace nil
+  "Namespace for current server.")
+
+(defvar imap-reached-tag 0
+  "Lower limit on command tags that have been parsed.")
+
+(defvar imap-failed-tags nil
+  "Alist of tags that failed.
+Each element is a list with four elements; tag (a integer), response
+state (a symbol, `OK', `NO' or `BAD'), response code (a string), and
+human readable response text (a string).")
+
+(defvar imap-tag 0
+  "Command tag number.")
+
+(defvar imap-process nil
+  "Process.")
+
+(defvar imap-continuation nil
+  "Non-nil indicates that the server emitted a continuation request.
+The actual value is really the text on the continuation line.")
+
+(defvar imap-callbacks nil
+  "List of response tags and callbacks, on the form `(number . function)'.
+The function should take two arguments, the first the IMAP tag and the
+second the status (OK, NO, BAD etc) of the command.")
+
+(defvar imap-enable-exchange-bug-workaround nil
+  "Send FETCH UID commands as *:* instead of *.
+
+When non-nil, use an alternative UIDS form.  Enabling appears to
+be required for some servers (e.g., Microsoft Exchange 2007)
+which otherwise would trigger a response 'BAD The specified
+message set is invalid.'.  We don't unconditionally use this
+form, since this is said to be significantly inefficient.
+
+This variable is set to t automatically per server if the
+canonical form fails.")
+
+\f
+;; Utility functions:
+
+(defun imap-remassoc (key alist)
+  "Delete by side effect any elements of ALIST whose car is `equal' to KEY.
+The modified ALIST is returned.  If the first member
+of ALIST has a car that is `equal' to KEY, there is no way to remove it
+by side effect; therefore, write `(setq foo (remassoc key foo))' to be
+sure of changing the value of `foo'."
+  (when alist
+    (if (equal key (caar alist))
+       (cdr alist)
+      (setcdr alist (imap-remassoc key (cdr alist)))
+      alist)))
+
+(defsubst imap-disable-multibyte ()
+  "Enable multibyte in the current buffer."
+  (when (fboundp 'set-buffer-multibyte)
+    (set-buffer-multibyte nil)))
+
+(defsubst imap-utf7-encode (string)
+  (if imap-use-utf7
+      (and string
+          (condition-case ()
+              (utf7-encode string t)
+            (error (message
+                    "imap: Could not UTF7 encode `%s', using it unencoded..."
+                    string)
+                   string)))
+    string))
+
+(defsubst imap-utf7-decode (string)
+  (if imap-use-utf7
+      (and string
+          (condition-case ()
+              (utf7-decode string t)
+            (error (message
+                    "imap: Could not UTF7 decode `%s', using it undecoded..."
+                    string)
+                   string)))
+    string))
+
+(defsubst imap-ok-p (status)
+  (if (eq status 'OK)
+      t
+    (setq imap-error status)
+    nil))
+
+(defun imap-error-text (&optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (nth 3 (car imap-failed-tags))))
+
+\f
+;; Server functions; stream stuff:
+
+(defun imap-kerberos4-stream-p (buffer)
+  (imap-capability 'AUTH=KERBEROS_V4 buffer))
+
+(defun imap-kerberos4-open (name buffer server port)
+  (let ((cmds imap-kerberos4-program)
+       cmd done)
+    (while (and (not done) (setq cmd (pop cmds)))
+      (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
+      (erase-buffer)
+      (let* ((port (or port imap-default-port))
+            (coding-system-for-read imap-coding-system-for-read)
+            (coding-system-for-write imap-coding-system-for-write)
+            (process-connection-type imap-process-connection-type)
+            (process (start-process
+                      name buffer shell-file-name shell-command-switch
+                      (format-spec
+                       cmd
+                       (format-spec-make
+                        ?s server
+                        ?p (number-to-string port)
+                        ?l imap-default-user))))
+            response)
+       (when process
+         (with-current-buffer buffer
+           (setq imap-client-eol "\n"
+                 imap-calculate-literal-size-first t)
+           (while (and (memq (process-status process) '(open run))
+                       (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+                       (goto-char (point-min))
+                       ;; Athena IMTEST can output SSL verify errors
+                       (or (while (looking-at "^verify error:num=")
+                             (forward-line))
+                           t)
+                       (or (while (looking-at "^TLS connection established")
+                             (forward-line))
+                           t)
+                       ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
+                       (or (while (looking-at "^C:")
+                             (forward-line))
+                           t)
+                       ;; cyrus 1.6 imtest print "S: " before server greeting
+                       (or (not (looking-at "S: "))
+                           (forward-char 3)
+                           t)
+                       (not (and (imap-parse-greeting)
+                                 ;; success in imtest < 1.6:
+                                 (or (re-search-forward
+                                      "^__\\(.*\\)__\n" nil t)
+                                     ;; success in imtest 1.6:
+                                     (re-search-forward
+                                      "^\\(Authenticat.*\\)" nil t))
+                                 (setq response (match-string 1)))))
+             (accept-process-output process 1)
+             (sit-for 1))
+           (and imap-log
+                (with-current-buffer (get-buffer-create imap-log-buffer)
+                  (imap-disable-multibyte)
+                  (buffer-disable-undo)
+                  (goto-char (point-max))
+                  (insert-buffer-substring buffer)))
+           (erase-buffer)
+           (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
+                    (if response (concat "done, " response) "failed"))
+           (if (and response (let ((case-fold-search nil))
+                               (not (string-match "failed" response))))
+               (setq done process)
+             (if (memq (process-status process) '(open run))
+                 (imap-logout))
+             (delete-process process)
+             nil)))))
+    done))
+
+(defun imap-gssapi-stream-p (buffer)
+  (imap-capability 'AUTH=GSSAPI buffer))
+
+(defun imap-gssapi-open (name buffer server port)
+  (let ((cmds imap-gssapi-program)
+       cmd done)
+    (while (and (not done) (setq cmd (pop cmds)))
+      (message "Opening GSSAPI IMAP connection with `%s'..." cmd)
+      (erase-buffer)
+      (let* ((port (or port imap-default-port))
+            (coding-system-for-read imap-coding-system-for-read)
+            (coding-system-for-write imap-coding-system-for-write)
+            (process-connection-type imap-process-connection-type)
+            (process (start-process
+                      name buffer shell-file-name shell-command-switch
+                      (format-spec
+                       cmd
+                       (format-spec-make
+                        ?s server
+                        ?p (number-to-string port)
+                        ?l imap-default-user))))
+            response)
+       (when process
+         (with-current-buffer buffer
+           (setq imap-client-eol "\n"
+                 imap-calculate-literal-size-first t)
+           (while (and (memq (process-status process) '(open run))
+                       (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+                       (goto-char (point-min))
+                       ;; Athena IMTEST can output SSL verify errors
+                       (or (while (looking-at "^verify error:num=")
+                             (forward-line))
+                           t)
+                       (or (while (looking-at "^TLS connection established")
+                             (forward-line))
+                           t)
+                       ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
+                       (or (while (looking-at "^C:")
+                             (forward-line))
+                           t)
+                       ;; cyrus 1.6 imtest print "S: " before server greeting
+                       (or (not (looking-at "S: "))
+                           (forward-char 3)
+                           t)
+                       ;; GNU SASL may print 'Trying ...' first.
+                       (or (not (looking-at "Trying "))
+                           (forward-line)
+                           t)
+                       (not (and (imap-parse-greeting)
+                                 ;; success in imtest 1.6:
+                                 (re-search-forward
+                                  (concat "^\\(\\(Authenticat.*\\)\\|\\("
+                                          "Client authentication "
+                                          "finished.*\\)\\)")
+                                  nil t)
+                                 (setq response (match-string 1)))))
+             (accept-process-output process 1)
+             (sit-for 1))
+           (and imap-log
+                (with-current-buffer (get-buffer-create imap-log-buffer)
+                  (imap-disable-multibyte)
+                  (buffer-disable-undo)
+                  (goto-char (point-max))
+                  (insert-buffer-substring buffer)))
+           (erase-buffer)
+           (message "GSSAPI IMAP connection: %s" (or response "failed"))
+           (if (and response (let ((case-fold-search nil))
+                               (not (string-match "failed" response))))
+               (setq done process)
+             (if (memq (process-status process) '(open run))
+                 (imap-logout))
+             (delete-process process)
+             nil)))))
+    done))
+
+(defun imap-ssl-p (buffer)
+  nil)
+
+(defun imap-ssl-open (name buffer server port)
+  "Open an SSL connection to SERVER."
+  (let ((cmds (if (listp imap-ssl-program) imap-ssl-program
+               (list imap-ssl-program)))
+       cmd done)
+    (while (and (not done) (setq cmd (pop cmds)))
+      (message "imap: Opening SSL connection with `%s'..." cmd)
+      (erase-buffer)
+      (let* ((port (or port imap-default-ssl-port))
+            (coding-system-for-read imap-coding-system-for-read)
+            (coding-system-for-write imap-coding-system-for-write)
+            (process-connection-type imap-process-connection-type)
+            (set-process-query-on-exit-flag
+             (if (fboundp 'set-process-query-on-exit-flag)
+                 'set-process-query-on-exit-flag
+               'process-kill-without-query))
+            process)
+       (when (progn
+               (setq process (start-process
+                              name buffer shell-file-name
+                              shell-command-switch
+                              (format-spec cmd
+                                           (format-spec-make
+                                            ?s server
+                                            ?p (number-to-string port)))))
+               (funcall set-process-query-on-exit-flag process nil)
+               process)
+         (with-current-buffer buffer
+           (goto-char (point-min))
+           (while (and (memq (process-status process) '(open run))
+                       (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+                       (goto-char (point-max))
+                       (forward-line -1)
+                       (not (imap-parse-greeting)))
+             (accept-process-output process 1)
+             (sit-for 1))
+           (and imap-log
+                (with-current-buffer (get-buffer-create imap-log-buffer)
+                  (imap-disable-multibyte)
+                  (buffer-disable-undo)
+                  (goto-char (point-max))
+                  (insert-buffer-substring buffer)))
+           (erase-buffer)
+           (when (memq (process-status process) '(open run))
+             (setq done process))))))
+    (if done
+       (progn
+         (message "imap: Opening SSL connection with `%s'...done" cmd)
+         done)
+      (message "imap: Opening SSL connection with `%s'...failed" cmd)
+      nil)))
+
+(defun imap-tls-p (buffer)
+  nil)
+
+(defun imap-tls-open (name buffer server port)
+  (let* ((port (or port imap-default-tls-port))
+        (coding-system-for-read imap-coding-system-for-read)
+        (coding-system-for-write imap-coding-system-for-write)
+        (process (open-tls-stream name buffer server port)))
+    (when process
+      (while (and (memq (process-status process) '(open run))
+                 ;; FIXME: Per the "blue moon" comment, the process/buffer
+                 ;; handling here, and elsewhere in functions which open
+                 ;; streams, looks confused.  Obviously we can change buffers
+                 ;; if a different process handler kicks in from
+                 ;; `accept-process-output' or `sit-for' below, and TRT seems
+                 ;; to be to `save-buffer' around those calls.  (I wonder why
+                 ;; `sit-for' is used with a non-zero wait.)  -- fx
+                 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+                 (goto-char (point-max))
+                 (forward-line -1)
+                 (not (imap-parse-greeting)))
+       (accept-process-output process 1)
+       (sit-for 1))
+      (and imap-log
+          (with-current-buffer (get-buffer-create imap-log-buffer)
+            (imap-disable-multibyte)
+            (buffer-disable-undo)
+            (goto-char (point-max))
+            (insert-buffer-substring buffer)))
+      (when (memq (process-status process) '(open run))
+       process))))
+
+(defun imap-network-p (buffer)
+  t)
+
+(defun imap-network-open (name buffer server port)
+  (let* ((port (or port imap-default-port))
+        (coding-system-for-read imap-coding-system-for-read)
+        (coding-system-for-write imap-coding-system-for-write)
+        (process (open-network-stream name buffer server port)))
+    (when process
+      (while (and (memq (process-status process) '(open run))
+                 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+                 (goto-char (point-min))
+                 (not (imap-parse-greeting)))
+       (accept-process-output process 1)
+       (sit-for 1))
+      (and imap-log
+          (with-current-buffer (get-buffer-create imap-log-buffer)
+            (imap-disable-multibyte)
+            (buffer-disable-undo)
+            (goto-char (point-max))
+            (insert-buffer-substring buffer)))
+      (when (memq (process-status process) '(open run))
+       process))))
+
+(defun imap-shell-p (buffer)
+  nil)
+
+(defun imap-shell-open (name buffer server port)
+  (let ((cmds (if (listp imap-shell-program) imap-shell-program
+               (list imap-shell-program)))
+       cmd done)
+    (while (and (not done) (setq cmd (pop cmds)))
+      (message "imap: Opening IMAP connection with `%s'..." cmd)
+      (setq imap-client-eol "\n")
+      (let* ((port (or port imap-default-port))
+            (coding-system-for-read imap-coding-system-for-read)
+            (coding-system-for-write imap-coding-system-for-write)
+            (process (start-process
+                      name buffer shell-file-name shell-command-switch
+                      (format-spec
+                       cmd
+                       (format-spec-make
+                        ?s server
+                        ?g imap-shell-host
+                        ?p (number-to-string port)
+                        ?l imap-default-user)))))
+       (when process
+         (while (and (memq (process-status process) '(open run))
+                     (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+                     (goto-char (point-max))
+                     (forward-line -1)
+                     (not (imap-parse-greeting)))
+           (accept-process-output process 1)
+           (sit-for 1))
+         (and imap-log
+              (with-current-buffer (get-buffer-create imap-log-buffer)
+                (imap-disable-multibyte)
+                (buffer-disable-undo)
+                (goto-char (point-max))
+                (insert-buffer-substring buffer)))
+         (erase-buffer)
+         (when (memq (process-status process) '(open run))
+           (setq done process)))))
+    (if done
+       (progn
+         (message "imap: Opening IMAP connection with `%s'...done" cmd)
+         done)
+      (message "imap: Opening IMAP connection with `%s'...failed" cmd)
+      nil)))
+
+(defun imap-starttls-p (buffer)
+  (imap-capability 'STARTTLS buffer))
+
+(defun imap-starttls-open (name buffer server port)
+  (let* ((port (or port imap-default-port))
+        (coding-system-for-read imap-coding-system-for-read)
+        (coding-system-for-write imap-coding-system-for-write)
+        (process (starttls-open-stream name buffer server port))
+        done tls-info)
+    (message "imap: Connecting with STARTTLS...")
+    (when process
+      (while (and (memq (process-status process) '(open run))
+                 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+                 (goto-char (point-max))
+                 (forward-line -1)
+                 (not (imap-parse-greeting)))
+       (accept-process-output process 1)
+       (sit-for 1))
+      (imap-send-command "STARTTLS")
+      (while (and (memq (process-status process) '(open run))
+                 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
+                 (goto-char (point-max))
+                 (forward-line -1)
+                 (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
+       (accept-process-output process 1)
+       (sit-for 1))
+      (and imap-log
+          (with-current-buffer (get-buffer-create imap-log-buffer)
+            (buffer-disable-undo)
+            (goto-char (point-max))
+            (insert-buffer-substring buffer)))
+      (when (and (setq tls-info (starttls-negotiate process))
+                (memq (process-status process) '(open run)))
+       (setq done process)))
+    (if (stringp tls-info)
+       (message "imap: STARTTLS info: %s" tls-info))
+    (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
+    done))
+
+;; Server functions; authenticator stuff:
+
+(defun imap-interactive-login (buffer loginfunc)
+  "Login to server in BUFFER.
+LOGINFUNC is passed a username and a password, it should return t if
+it where successful authenticating itself to the server, nil otherwise.
+Returns t if login was successful, nil otherwise."
+  (with-current-buffer buffer
+    (make-local-variable 'imap-username)
+    (make-local-variable 'imap-password)
+    (let (user passwd ret)
+      ;;      (condition-case ()
+      (while (or (not user) (not passwd))
+       (setq user (or imap-username
+                      (read-from-minibuffer
+                       (concat "imap: username for " imap-server
+                               " (using stream `" (symbol-name imap-stream)
+                               "'): ")
+                       (or user imap-default-user))))
+       (setq passwd (or imap-password
+                        (read-passwd
+                         (concat "imap: password for " user "@"
+                                 imap-server " (using authenticator `"
+                                 (symbol-name imap-auth) "'): "))))
+       (when (and user passwd)
+         (if (funcall loginfunc user passwd)
+             (progn
+               (message "imap: Login successful...")
+               (setq ret t
+                     imap-username user)
+               (when (and (not imap-password)
+                          (or imap-store-password
+                              (y-or-n-p "imap: Store password for this IMAP session? ")))
+                 (setq imap-password passwd)))
+           (message "imap: Login failed...")
+           (setq passwd nil)
+           (setq imap-password nil)
+           (sit-for 1))))
+      ;;       (quit (with-current-buffer buffer
+      ;;               (setq user nil
+      ;;                     passwd nil)))
+      ;;       (error (with-current-buffer buffer
+      ;;                (setq user nil
+      ;;                      passwd nil))))
+      ret)))
+
+(defun imap-gssapi-auth-p (buffer)
+  (eq imap-stream 'gssapi))
+
+(defun imap-gssapi-auth (buffer)
+  (message "imap: Authenticating using GSSAPI...%s"
+          (if (eq imap-stream 'gssapi) "done" "failed"))
+  (eq imap-stream 'gssapi))
+
+(defun imap-kerberos4-auth-p (buffer)
+  (and (imap-capability 'AUTH=KERBEROS_V4 buffer)
+       (eq imap-stream 'kerberos4)))
+
+(defun imap-kerberos4-auth (buffer)
+  (message "imap: Authenticating using Kerberos 4...%s"
+          (if (eq imap-stream 'kerberos4) "done" "failed"))
+  (eq imap-stream 'kerberos4))
+
+(defun imap-cram-md5-p (buffer)
+  (imap-capability 'AUTH=CRAM-MD5 buffer))
+
+(defun imap-cram-md5-auth (buffer)
+  "Login to server using the AUTH CRAM-MD5 method."
+  (message "imap: Authenticating using CRAM-MD5...")
+  (let ((done (imap-interactive-login
+              buffer
+              (lambda (user passwd)
+                (imap-ok-p
+                 (imap-send-command-wait
+                  (list
+                   "AUTHENTICATE CRAM-MD5"
+                   (lambda (challenge)
+                     (let* ((decoded (base64-decode-string challenge))
+                            (hash (rfc2104-hash 'md5 64 16 passwd decoded))
+                            (response (concat user " " hash))
+                            (encoded (base64-encode-string response)))
+                       encoded)))))))))
+    (if done
+       (message "imap: Authenticating using CRAM-MD5...done")
+      (message "imap: Authenticating using CRAM-MD5...failed"))))
+
+(defun imap-login-p (buffer)
+  (and (not (imap-capability 'LOGINDISABLED buffer))
+       (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
+
+(defun imap-quote-specials (string)
+  (with-temp-buffer
+    (insert string)
+    (goto-char (point-min))
+    (while (re-search-forward "[\\\"]" nil t)
+      (forward-char -1)
+      (insert "\\")
+      (forward-char 1))
+    (buffer-string)))
+
+(defun imap-login-auth (buffer)
+  "Login to server using the LOGIN command."
+  (message "imap: Plaintext authentication...")
+  (imap-interactive-login buffer
+                         (lambda (user passwd)
+                           (imap-ok-p (imap-send-command-wait
+                                       (concat "LOGIN \""
+                                               (imap-quote-specials user)
+                                               "\" \""
+                                               (imap-quote-specials passwd)
+                                               "\""))))))
+
+(defun imap-anonymous-p (buffer)
+  t)
+
+(defun imap-anonymous-auth (buffer)
+  (message "imap: Logging in anonymously...")
+  (with-current-buffer buffer
+    (imap-ok-p (imap-send-command-wait
+               (concat "LOGIN anonymous \"" (concat (user-login-name) "@"
+                                                    (system-name)) "\"")))))
+
+;;; Compiler directives.
+
+(defvar imap-sasl-client)
+(defvar imap-sasl-step)
+
+(defun imap-sasl-make-mechanisms (buffer)
+  (let ((mecs '()))
+    (mapc (lambda (sym)
+           (let ((name (symbol-name sym)))
+             (if (and (> (length name) 5)
+                      (string-equal "AUTH=" (substring name 0 5 )))
+                 (setq mecs (cons (substring name 5) mecs)))))
+         (imap-capability nil buffer))
+    mecs))
+
+(declare-function sasl-find-mechanism "sasl" (mechanism))
+(declare-function sasl-mechanism-name "sasl" (mechanism))
+(declare-function sasl-make-client    "sasl" (mechanism name service server))
+(declare-function sasl-next-step      "sasl" (client step))
+(declare-function sasl-step-data      "sasl" (step))
+(declare-function sasl-step-set-data  "sasl" (step data))
+
+(defun imap-sasl-auth-p (buffer)
+  (and (condition-case ()
+          (require 'sasl)
+        (error nil))
+       (sasl-find-mechanism (imap-sasl-make-mechanisms buffer))))
+
+(defun imap-sasl-auth (buffer)
+  "Login to server using the SASL method."
+  (message "imap: Authenticating using SASL...")
+  (with-current-buffer buffer
+    (make-local-variable 'imap-username)
+    (make-local-variable 'imap-sasl-client)
+    (make-local-variable 'imap-sasl-step)
+    (let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))
+         logged user)
+      (while (not logged)
+       (setq user (or imap-username
+                      (read-from-minibuffer
+                       (concat "IMAP username for " imap-server " using SASL "
+                               (sasl-mechanism-name mechanism) ": ")
+                       (or user imap-default-user))))
+       (when user
+         (setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server)
+               imap-sasl-step (sasl-next-step imap-sasl-client nil))
+         (let ((tag (imap-send-command
+                     (if (sasl-step-data imap-sasl-step)
+                         (format "AUTHENTICATE %s %s"
+                                 (sasl-mechanism-name mechanism)
+                                 (sasl-step-data imap-sasl-step))
+                       (format "AUTHENTICATE %s" (sasl-mechanism-name mechanism)))
+                     buffer)))
+           (while (eq (imap-wait-for-tag tag) 'INCOMPLETE)
+             (sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation))
+             (setq imap-continuation nil
+                   imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step))
+             (imap-send-command-1 (if (sasl-step-data imap-sasl-step)
+                                      (base64-encode-string (sasl-step-data imap-sasl-step) t)
+                                    "")))
+           (if (imap-ok-p (imap-wait-for-tag tag))
+               (setq imap-username user
+                     logged t)
+             (message "Login failed...")
+             (sit-for 1)))))
+      logged)))
+
+(defun imap-digest-md5-p (buffer)
+  (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
+       (condition-case ()
+          (require 'digest-md5)
+        (error nil))))
+
+(defun imap-digest-md5-auth (buffer)
+  "Login to server using the AUTH DIGEST-MD5 method."
+  (message "imap: Authenticating using DIGEST-MD5...")
+  (imap-interactive-login
+   buffer
+   (lambda (user passwd)
+     (let ((tag
+           (imap-send-command
+            (list
+             "AUTHENTICATE DIGEST-MD5"
+             (lambda (challenge)
+               (digest-md5-parse-digest-challenge
+                (base64-decode-string challenge))
+               (let* ((digest-uri
+                       (digest-md5-digest-uri
+                        "imap" (digest-md5-challenge 'realm)))
+                      (response
+                       (digest-md5-digest-response
+                        user passwd digest-uri)))
+                 (base64-encode-string response 'no-line-break))))
+            )))
+       (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
+          nil
+        (setq imap-continuation nil)
+        (imap-send-command-1 "")
+        (imap-ok-p (imap-wait-for-tag tag)))))))
+
+;; Server functions:
+
+(defun imap-open-1 (buffer)
+  (with-current-buffer buffer
+    (erase-buffer)
+    (setq imap-current-mailbox nil
+         imap-current-message nil
+         imap-state 'initial
+         imap-process (condition-case ()
+                          (funcall (nth 2 (assq imap-stream
+                                                imap-stream-alist))
+                                   "imap" buffer imap-server imap-port)
+                        ((error quit) nil)))
+    (when imap-process
+      (set-process-filter imap-process 'imap-arrival-filter)
+      (set-process-sentinel imap-process 'imap-sentinel)
+      (while (and (eq imap-state 'initial)
+                 (memq (process-status imap-process) '(open run)))
+       (message "Waiting for response from %s..." imap-server)
+       (accept-process-output imap-process 1))
+      (message "Waiting for response from %s...done" imap-server)
+      (and (memq (process-status imap-process) '(open run))
+          imap-process))))
+
+(defun imap-open (server &optional port stream auth buffer)
+  "Open an IMAP connection to host SERVER at PORT returning a buffer.
+If PORT is unspecified, a default value is used (143 except
+for SSL which use 993).
+STREAM indicates the stream to use, see `imap-streams' for available
+streams.  If nil, it choices the best stream the server is capable of.
+AUTH indicates authenticator to use, see `imap-authenticators' for
+available authenticators.  If nil, it choices the best stream the
+server is capable of.
+BUFFER can be a buffer or a name of a buffer, which is created if
+necessary.  If nil, the buffer name is generated."
+  (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0))))
+  (with-current-buffer (get-buffer-create buffer)
+    (if (imap-opened buffer)
+       (imap-close buffer))
+    (mapc 'make-local-variable imap-local-variables)
+    (imap-disable-multibyte)
+    (buffer-disable-undo)
+    (setq imap-server (or server imap-server))
+    (setq imap-port (or port imap-port))
+    (setq imap-auth (or auth imap-auth))
+    (setq imap-stream (or stream imap-stream))
+    (message "imap: Connecting to %s..." imap-server)
+    (if (null (let ((imap-stream (or imap-stream imap-default-stream)))
+               (imap-open-1 buffer)))
+       (progn
+         (message "imap: Connecting to %s...failed" imap-server)
+         nil)
+      (when (null imap-stream)
+       ;; Need to choose stream.
+       (let ((streams imap-streams))
+         (while (setq stream (pop streams))
+           ;; OK to use this stream?
+           (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
+             ;; Stream changed?
+             (if (not (eq imap-default-stream stream))
+                 (with-current-buffer (get-buffer-create
+                                       (generate-new-buffer-name " *temp*"))
+                   (mapc 'make-local-variable imap-local-variables)
+                   (imap-disable-multibyte)
+                   (buffer-disable-undo)
+                   (setq imap-server (or server imap-server))
+                   (setq imap-port (or port imap-port))
+                   (setq imap-auth (or auth imap-auth))
+                   (message "imap: Reconnecting with stream `%s'..." stream)
+                   (if (null (let ((imap-stream stream))
+                               (imap-open-1 (current-buffer))))
+                       (progn
+                         (kill-buffer (current-buffer))
+                         (message
+                          "imap: Reconnecting with stream `%s'...failed"
+                          stream))
+                     ;; We're done, kill the first connection
+                     (imap-close buffer)
+                     (let ((name (if (stringp buffer)
+                                     buffer
+                                   (buffer-name buffer))))
+                       (kill-buffer buffer)
+                       (rename-buffer name)
+                       ;; set the passed buffer to the current one,
+                       ;; so that (imap-opened buffer) later will work
+                       (setq buffer (current-buffer)))
+                     (message "imap: Reconnecting with stream `%s'...done"
+                              stream)
+                     (setq imap-stream stream)
+                     (setq imap-capability nil)
+                     (setq streams nil)))
+               ;; We're done
+               (message "imap: Connecting to %s...done" imap-server)
+               (setq imap-stream stream)
+               (setq imap-capability nil)
+               (setq streams nil))))))
+      (when (imap-opened buffer)
+       (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
+      ;; (debug "opened+state+auth+buffer" (imap-opened buffer) imap-state imap-auth buffer)
+      (when imap-stream
+       buffer))))
+
+(defcustom imap-ping-server t
+  "If non-nil, check if IMAP is open.
+See the function `imap-ping-server'."
+  :version "23.1" ;; No Gnus
+  :group 'imap
+  :type 'boolean)
+
+(defun imap-opened (&optional buffer)
+  "Return non-nil if connection to imap server in BUFFER is open.
+If BUFFER is nil then the current buffer is used."
+  (and (setq buffer (get-buffer (or buffer (current-buffer))))
+       (buffer-live-p buffer)
+       (with-current-buffer buffer
+        (and imap-process
+             (memq (process-status imap-process) '(open run))
+             (if imap-ping-server
+                 (imap-ping-server)
+               t)))))
+
+(defun imap-ping-server (&optional buffer)
+  "Ping the IMAP server in BUFFER with a \"NOOP\" command.
+Return non-nil if the server responds, and nil if it does not
+respond.  If BUFFER is nil, the current buffer is used."
+  (condition-case ()
+      (imap-ok-p (imap-send-command-wait "NOOP" buffer))
+    (error nil)))
+
+(defun imap-authenticate (&optional user passwd buffer)
+  "Authenticate to server in BUFFER, using current buffer if nil.
+It uses the authenticator specified when opening the server.  If the
+authenticator requires username/passwords, they are queried from the
+user and optionally stored in the buffer.  If USER and/or PASSWD is
+specified, the user will not be questioned and the username and/or
+password is remembered in the buffer."
+  (with-current-buffer (or buffer (current-buffer))
+    (if (not (eq imap-state 'nonauth))
+       (or (eq imap-state 'auth)
+           (eq imap-state 'selected)
+           (eq imap-state 'examine))
+      (make-local-variable 'imap-username)
+      (make-local-variable 'imap-password)
+      (make-local-variable 'imap-last-authenticator)
+      (when user (setq imap-username user))
+      (when passwd (setq imap-password passwd))
+      (if imap-auth
+         (and (setq imap-last-authenticator 
+                    (assq imap-auth imap-authenticator-alist))
+              (funcall (nth 2 imap-last-authenticator) (current-buffer))
+              (setq imap-state 'auth))
+       ;; Choose authenticator.
+       (let ((auths imap-authenticators)
+             auth)
+         (while (setq auth (pop auths))
+           ;; OK to use authenticator?
+           (setq imap-last-authenticator
+                 (assq auth imap-authenticator-alist))
+           (when (funcall (nth 1 imap-last-authenticator) (current-buffer))
+             (message "imap: Authenticating to `%s' using `%s'..."
+                      imap-server auth)
+             (setq imap-auth auth)
+             (if (funcall (nth 2 imap-last-authenticator) (current-buffer))
+                 (progn
+                   (message "imap: Authenticating to `%s' using `%s'...done"
+                            imap-server auth)
+                   ;; set imap-state correctly on successful auth attempt
+                   (setq imap-state 'auth)
+                   ;; stop iterating through the authenticator list
+                   (setq auths nil))
+               (message "imap: Authenticating to `%s' using `%s'...failed"
+                        imap-server auth)))))
+       imap-state))))
+
+(defun imap-close (&optional buffer)
+  "Close connection to server in BUFFER.
+If BUFFER is nil, the current buffer is used."
+  (with-current-buffer (or buffer (current-buffer))
+    (when (imap-opened)
+      (condition-case nil
+         (imap-logout-wait)
+       (quit nil)))
+    (when (and imap-process
+              (memq (process-status imap-process) '(open run)))
+      (delete-process imap-process))
+    (setq imap-current-mailbox nil
+         imap-current-message nil
+         imap-process nil)
+    (erase-buffer)
+    t))
+
+(defun imap-capability (&optional identifier buffer)
+  "Return a list of identifiers which server in BUFFER support.
+If IDENTIFIER, return non-nil if it's among the servers capabilities.
+If BUFFER is nil, the current buffer is assumed."
+  (with-current-buffer (or buffer (current-buffer))
+    (unless imap-capability
+      (unless (imap-ok-p (imap-send-command-wait "CAPABILITY"))
+       (setq imap-capability '(IMAP2))))
+    (if identifier
+       (memq (intern (upcase (symbol-name identifier))) imap-capability)
+      imap-capability)))
+
+(defun imap-id (&optional list-of-values buffer)
+  "Identify client to server in BUFFER, and return server identity.
+LIST-OF-VALUES is nil, or a plist with identifier and value
+strings to send to the server to identify the client.
+
+Return a list of identifiers which server in BUFFER support, or
+nil if it doesn't support ID or returns no information.
+
+If BUFFER is nil, the current buffer is assumed."
+  (with-current-buffer (or buffer (current-buffer))
+    (when (and (imap-capability 'ID)
+              (imap-ok-p (imap-send-command-wait
+                          (if (null list-of-values)
+                              "ID NIL"
+                            (concat "ID (" (mapconcat (lambda (el)
+                                                        (concat "\"" el "\""))
+                                                      list-of-values
+                                                      " ") ")")))))
+      imap-id)))
+
+(defun imap-namespace (&optional buffer)
+  "Return a namespace hierarchy at server in BUFFER.
+If BUFFER is nil, the current buffer is assumed."
+  (with-current-buffer (or buffer (current-buffer))
+    (unless imap-namespace
+      (when (imap-capability 'NAMESPACE)
+       (imap-send-command-wait "NAMESPACE")))
+    imap-namespace))
+
+(defun imap-send-command-wait (command &optional buffer)
+  (imap-wait-for-tag (imap-send-command command buffer) buffer))
+
+(defun imap-logout (&optional buffer)
+  (or buffer (setq buffer (current-buffer)))
+  (if imap-logout-timeout
+      (with-timeout (imap-logout-timeout
+                    (condition-case nil
+                        (with-current-buffer buffer
+                          (delete-process imap-process))
+                      (error)))
+       (imap-send-command "LOGOUT" buffer))
+    (imap-send-command "LOGOUT" buffer)))
+
+(defun imap-logout-wait (&optional buffer)
+  (or buffer (setq buffer (current-buffer)))
+  (if imap-logout-timeout
+      (with-timeout (imap-logout-timeout
+                    (condition-case nil
+                        (with-current-buffer buffer
+                          (delete-process imap-process))
+                      (error)))
+       (imap-send-command-wait "LOGOUT" buffer))
+    (imap-send-command-wait "LOGOUT" buffer)))
+
+\f
+;; Mailbox functions:
+
+(defun imap-mailbox-put (propname value &optional mailbox buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (if imap-mailbox-data
+       (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
+            propname value)
+      (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
+            propname value mailbox (current-buffer)))
+    t))
+
+(defsubst imap-mailbox-get-1 (propname &optional mailbox)
+  (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
+       propname))
+
+(defun imap-mailbox-get (propname &optional mailbox buffer)
+  (let ((mailbox (imap-utf7-encode mailbox)))
+    (with-current-buffer (or buffer (current-buffer))
+      (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
+
+(defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (let (result)
+      (mapatoms
+       (lambda (s)
+        (push (funcall func (if mailbox-decoder
+                                (funcall mailbox-decoder (symbol-name s))
+                              (symbol-name s))) result))
+       imap-mailbox-data)
+      result)))
+
+(defun imap-mailbox-map (func &optional buffer)
+  "Map a function across each mailbox in `imap-mailbox-data', returning a list.
+Function should take a mailbox name (a string) as
+the only argument."
+  (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
+
+(defun imap-current-mailbox (&optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-utf7-decode imap-current-mailbox)))
+
+(defun imap-current-mailbox-p-1 (mailbox &optional examine)
+  (and (string= mailbox imap-current-mailbox)
+       (or (and examine
+               (eq imap-state 'examine))
+          (and (not examine)
+               (eq imap-state 'selected)))))
+
+(defun imap-current-mailbox-p (mailbox &optional examine buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-current-mailbox-p-1 (imap-utf7-encode mailbox) examine)))
+
+(defun imap-mailbox-select-1 (mailbox &optional examine)
+  "Select MAILBOX on server in BUFFER.
+If EXAMINE is non-nil, do a read-only select."
+  (if (imap-current-mailbox-p-1 mailbox examine)
+      imap-current-mailbox
+    (setq imap-current-mailbox mailbox)
+    (if (imap-ok-p (imap-send-command-wait
+                   (concat (if examine "EXAMINE" "SELECT") " \""
+                           mailbox "\"")))
+       (progn
+         (setq imap-message-data (make-vector imap-message-prime 0)
+               imap-state (if examine 'examine 'selected))
+         imap-current-mailbox)
+      ;; Failed SELECT/EXAMINE unselects current mailbox
+      (setq imap-current-mailbox nil))))
+
+(defun imap-mailbox-select (mailbox &optional examine buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-utf7-decode
+     (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine))))
+
+(defun imap-mailbox-examine-1 (mailbox &optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-mailbox-select-1 mailbox 'examine)))
+
+(defun imap-mailbox-examine (mailbox &optional buffer)
+  "Examine MAILBOX on server in BUFFER."
+  (imap-mailbox-select mailbox 'examine buffer))
+
+(defun imap-mailbox-unselect (&optional buffer)
+  "Close current folder in BUFFER, without expunging articles."
+  (with-current-buffer (or buffer (current-buffer))
+    (when (or (eq imap-state 'auth)
+             (and (imap-capability 'UNSELECT)
+                  (imap-ok-p (imap-send-command-wait "UNSELECT")))
+             (and (imap-ok-p
+                   (imap-send-command-wait (concat "EXAMINE \""
+                                                   imap-current-mailbox
+                                                   "\"")))
+                  (imap-ok-p (imap-send-command-wait "CLOSE"))))
+      (setq imap-current-mailbox nil
+           imap-message-data nil
+           imap-state 'auth)
+      t)))
+
+(defun imap-mailbox-expunge (&optional asynch buffer)
+  "Expunge articles in current folder in BUFFER.
+If ASYNCH, do not wait for successful completion of the command.
+If BUFFER is nil the current buffer is assumed."
+  (with-current-buffer (or buffer (current-buffer))
+    (when (and imap-current-mailbox (not (eq imap-state 'examine)))
+      (if asynch
+         (imap-send-command "EXPUNGE")
+      (imap-ok-p (imap-send-command-wait "EXPUNGE"))))))
+
+(defun imap-mailbox-close (&optional asynch buffer)
+  "Expunge articles and close current folder in BUFFER.
+If ASYNCH, do not wait for successful completion of the command.
+If BUFFER is nil the current buffer is assumed."
+  (with-current-buffer (or buffer (current-buffer))
+    (when imap-current-mailbox
+      (if asynch
+         (imap-add-callback (imap-send-command "CLOSE")
+                            `(lambda (tag status)
+                               (message "IMAP mailbox `%s' closed... %s"
+                                        imap-current-mailbox status)
+                               (when (eq ,imap-current-mailbox
+                                         imap-current-mailbox)
+                                 ;; Don't wipe out data if another mailbox
+                                 ;; was selected...
+                                 (setq imap-current-mailbox nil
+                                       imap-message-data nil
+                                       imap-state 'auth))))
+       (when (imap-ok-p (imap-send-command-wait "CLOSE"))
+         (setq imap-current-mailbox nil
+               imap-message-data nil
+               imap-state 'auth)))
+      t)))
+
+(defun imap-mailbox-create-1 (mailbox)
+  (imap-ok-p (imap-send-command-wait (list "CREATE \"" mailbox "\""))))
+
+(defun imap-mailbox-create (mailbox &optional buffer)
+  "Create MAILBOX on server in BUFFER.
+If BUFFER is nil the current buffer is assumed."
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-mailbox-create-1 (imap-utf7-encode mailbox))))
+
+(defun imap-mailbox-delete (mailbox &optional buffer)
+  "Delete MAILBOX on server in BUFFER.
+If BUFFER is nil the current buffer is assumed."
+  (let ((mailbox (imap-utf7-encode mailbox)))
+    (with-current-buffer (or buffer (current-buffer))
+      (imap-ok-p
+       (imap-send-command-wait (list "DELETE \"" mailbox "\""))))))
+
+(defun imap-mailbox-rename (oldname newname &optional buffer)
+  "Rename mailbox OLDNAME to NEWNAME on server in BUFFER.
+If BUFFER is nil the current buffer is assumed."
+  (let ((oldname (imap-utf7-encode oldname))
+       (newname (imap-utf7-encode newname)))
+    (with-current-buffer (or buffer (current-buffer))
+      (imap-ok-p
+       (imap-send-command-wait (list "RENAME \"" oldname "\" "
+                                    "\"" newname "\""))))))
+
+(defun imap-mailbox-lsub (&optional root reference add-delimiter buffer)
+  "Return a list of subscribed mailboxes on server in BUFFER.
+If ROOT is non-nil, only list matching mailboxes.  If ADD-DELIMITER is
+non-nil, a hierarchy delimiter is added to root.  REFERENCE is a
+implementation-specific string that has to be passed to lsub command."
+  (with-current-buffer (or buffer (current-buffer))
+    ;; Make sure we know the hierarchy separator for root's hierarchy
+    (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
+      (imap-send-command-wait (concat "LIST \"" reference "\" \""
+                                     (imap-utf7-encode root) "\"")))
+    ;; clear list data (NB not delimiter and other stuff)
+    (imap-mailbox-map-1 (lambda (mailbox)
+                         (imap-mailbox-put 'lsub nil mailbox)))
+    (when (imap-ok-p
+          (imap-send-command-wait
+           (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root)
+                   (and add-delimiter (imap-mailbox-get-1 'delimiter root))
+                   "%\"")))
+      (let (out)
+       (imap-mailbox-map-1 (lambda (mailbox)
+                             (when (imap-mailbox-get-1 'lsub mailbox)
+                               (push (imap-utf7-decode mailbox) out))))
+       (nreverse out)))))
+
+(defun imap-mailbox-list (root &optional reference add-delimiter buffer)
+  "Return a list of mailboxes matching ROOT on server in BUFFER.
+If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to
+root.  REFERENCE is a implementation-specific string that has to be
+passed to list command."
+  (with-current-buffer (or buffer (current-buffer))
+    ;; Make sure we know the hierarchy separator for root's hierarchy
+    (when (and add-delimiter (null (imap-mailbox-get-1 'delimiter root)))
+      (imap-send-command-wait (concat "LIST \"" reference "\" \""
+                                     (imap-utf7-encode root) "\"")))
+    ;; clear list data (NB not delimiter and other stuff)
+    (imap-mailbox-map-1 (lambda (mailbox)
+                         (imap-mailbox-put 'list nil mailbox)))
+    (when (imap-ok-p
+          (imap-send-command-wait
+           (concat "LIST \"" reference "\" \"" (imap-utf7-encode root)
+                   (and add-delimiter (imap-mailbox-get-1 'delimiter root))
+                   "%\"")))
+      (let (out)
+       (imap-mailbox-map-1 (lambda (mailbox)
+                             (when (imap-mailbox-get-1 'list mailbox)
+                               (push (imap-utf7-decode mailbox) out))))
+       (nreverse out)))))
+
+(defun imap-mailbox-subscribe (mailbox &optional buffer)
+  "Send the SUBSCRIBE command on the MAILBOX to server in BUFFER.
+Returns non-nil if successful."
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \""
+                                              (imap-utf7-encode mailbox)
+                                              "\"")))))
+
+(defun imap-mailbox-unsubscribe (mailbox &optional buffer)
+  "Send the SUBSCRIBE command on the MAILBOX to server in BUFFER.
+Returns non-nil if successful."
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE "
+                                              (imap-utf7-encode mailbox)
+                                              "\"")))))
+
+(defun imap-mailbox-status (mailbox items &optional buffer)
+  "Get status items ITEM in MAILBOX from server in BUFFER.
+ITEMS can be a symbol or a list of symbols, valid symbols are one of
+the STATUS data items -- i.e. `messages', `recent', `uidnext', `uidvalidity',
+or `unseen'.  If ITEMS is a list of symbols, a list of values is
+returned, if ITEMS is a symbol only its value is returned."
+  (with-current-buffer (or buffer (current-buffer))
+    (when (imap-ok-p
+          (imap-send-command-wait (list "STATUS \""
+                                        (imap-utf7-encode mailbox)
+                                        "\" "
+                                        (upcase
+                                         (format "%s"
+                                                 (if (listp items)
+                                                     items
+                                                   (list items)))))))
+      (if (listp items)
+         (mapcar (lambda (item)
+                   (imap-mailbox-get item mailbox))
+                 items)
+       (imap-mailbox-get items mailbox)))))
+
+(defun imap-mailbox-status-asynch (mailbox items &optional buffer)
+  "Send status item request ITEM on MAILBOX to server in BUFFER.
+ITEMS can be a symbol or a list of symbols, valid symbols are one of
+the STATUS data items -- i.e. 'messages, 'recent, 'uidnext, 'uidvalidity
+or 'unseen.  The IMAP command tag is returned."
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-send-command (list "STATUS \""
+                            (imap-utf7-encode mailbox)
+                            "\" "
+                            (upcase
+                             (format "%s"
+                                     (if (listp items)
+                                         items
+                                       (list items))))))))
+
+(defun imap-mailbox-acl-get (&optional mailbox buffer)
+  "Get ACL on MAILBOX from server in BUFFER."
+  (let ((mailbox (imap-utf7-encode mailbox)))
+    (with-current-buffer (or buffer (current-buffer))
+      (when (imap-ok-p
+            (imap-send-command-wait (list "GETACL \""
+                                          (or mailbox imap-current-mailbox)
+                                          "\"")))
+       (imap-mailbox-get-1 'acl (or mailbox imap-current-mailbox))))))
+
+(defun imap-mailbox-acl-set (identifier rights &optional mailbox buffer)
+  "Change/set ACL for IDENTIFIER to RIGHTS in MAILBOX from server in BUFFER."
+  (let ((mailbox (imap-utf7-encode mailbox)))
+    (with-current-buffer (or buffer (current-buffer))
+      (imap-ok-p
+       (imap-send-command-wait (list "SETACL \""
+                                    (or mailbox imap-current-mailbox)
+                                    "\" "
+                                    identifier
+                                    " "
+                                    rights))))))
+
+(defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
+  "Remove any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in BUFFER."
+  (let ((mailbox (imap-utf7-encode mailbox)))
+    (with-current-buffer (or buffer (current-buffer))
+      (imap-ok-p
+       (imap-send-command-wait (list "DELETEACL \""
+                                    (or mailbox imap-current-mailbox)
+                                    "\" "
+                                    identifier))))))
+
+\f
+;; Message functions:
+
+(defun imap-current-message (&optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    imap-current-message))
+
+(defun imap-list-to-message-set (list)
+  (mapconcat (lambda (item)
+              (number-to-string item))
+            (if (listp list)
+                list
+              (list list))
+            ","))
+
+(defun imap-range-to-message-set (range)
+  (mapconcat
+   (lambda (item)
+     (if (consp item)
+        (format "%d:%d"
+                (car item) (cdr item))
+       (format "%d" item)))
+   (if (and (listp range) (not (listp (cdr range))))
+       (list range) ;; make (1 . 2) into ((1 . 2))
+     range)
+   ","))
+
+(defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
+                              (if (listp uids)
+                                  (imap-list-to-message-set uids)
+                                uids)
+                              props))))
+
+(defun imap-fetch (uids props &optional receive nouidfetch buffer)
+  "Fetch properties PROPS from message set UIDS from server in BUFFER.
+UIDS can be a string, number or a list of numbers.  If RECEIVE
+is non-nil return these properties."
+  (with-current-buffer (or buffer (current-buffer))
+    (when (imap-ok-p (imap-send-command-wait
+                     (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
+                             (if (listp uids)
+                                 (imap-list-to-message-set uids)
+                               uids)
+                             props)))
+      (if (or (null receive) (stringp uids))
+         t
+       (if (listp uids)
+           (mapcar (lambda (uid)
+                     (if (listp receive)
+                         (mapcar (lambda (prop)
+                                   (imap-message-get uid prop))
+                                 receive)
+                       (imap-message-get uid receive)))
+                   uids)
+         (imap-message-get uids receive))))))
+
+(defun imap-message-put (uid propname value &optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (if imap-message-data
+       (put (intern (number-to-string uid) imap-message-data)
+            propname value)
+      (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
+            uid propname value (current-buffer)))
+    t))
+
+(defun imap-message-get (uid propname &optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (get (intern-soft (number-to-string uid) imap-message-data)
+        propname)))
+
+(defun imap-message-map (func propname &optional buffer)
+  "Map a function across each message in `imap-message-data', returning a list."
+  (with-current-buffer (or buffer (current-buffer))
+    (let (result)
+      (mapatoms
+       (lambda (s)
+        (push (funcall func (get s 'UID) (get s propname)) result))
+       imap-message-data)
+      result)))
+
+(defmacro imap-message-envelope-date (uid &optional buffer)
+  `(with-current-buffer (or ,buffer (current-buffer))
+     (elt (imap-message-get ,uid 'ENVELOPE) 0)))
+
+(defmacro imap-message-envelope-subject (uid &optional buffer)
+  `(with-current-buffer (or ,buffer (current-buffer))
+     (elt (imap-message-get ,uid 'ENVELOPE) 1)))
+
+(defmacro imap-message-envelope-from (uid &optional buffer)
+  `(with-current-buffer (or ,buffer (current-buffer))
+     (elt (imap-message-get ,uid 'ENVELOPE) 2)))
+
+(defmacro imap-message-envelope-sender (uid &optional buffer)
+  `(with-current-buffer (or ,buffer (current-buffer))
+     (elt (imap-message-get ,uid 'ENVELOPE) 3)))
+
+(defmacro imap-message-envelope-reply-to (uid &optional buffer)
+  `(with-current-buffer (or ,buffer (current-buffer))
+     (elt (imap-message-get ,uid 'ENVELOPE) 4)))
+
+(defmacro imap-message-envelope-to (uid &optional buffer)
+  `(with-current-buffer (or ,buffer (current-buffer))
+     (elt (imap-message-get ,uid 'ENVELOPE) 5)))
+
+(defmacro imap-message-envelope-cc (uid &optional buffer)
+  `(with-current-buffer (or ,buffer (current-buffer))
+     (elt (imap-message-get ,uid 'ENVELOPE) 6)))
+
+(defmacro imap-message-envelope-bcc (uid &optional buffer)
+  `(with-current-buffer (or ,buffer (current-buffer))
+     (elt (imap-message-get ,uid 'ENVELOPE) 7)))
+
+(defmacro imap-message-envelope-in-reply-to (uid &optional buffer)
+  `(with-current-buffer (or ,buffer (current-buffer))
+     (elt (imap-message-get ,uid 'ENVELOPE) 8)))
+
+(defmacro imap-message-envelope-message-id (uid &optional buffer)
+  `(with-current-buffer (or ,buffer (current-buffer))
+     (elt (imap-message-get ,uid 'ENVELOPE) 9)))
+
+(defmacro imap-message-body (uid &optional buffer)
+  `(with-current-buffer (or ,buffer (current-buffer))
+     (imap-message-get ,uid 'BODY)))
+
+;; FIXME: Should this try to use CHARSET?  -- fx
+(defun imap-search (predicate &optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-mailbox-put 'search 'dummy)
+    (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate)))
+      (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy)
+         (progn
+           (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...")
+           nil)
+       (imap-mailbox-get-1 'search imap-current-mailbox)))))
+
+(defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
+  "Return t if FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
+  (with-current-buffer (or buffer (current-buffer))
+    (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
+       (member flag (imap-mailbox-get 'permanentflags mailbox)))))
+
+(defun imap-message-flags-set (articles flags &optional silent buffer)
+  (when (and articles flags)
+    (with-current-buffer (or buffer (current-buffer))
+      (imap-ok-p (imap-send-command-wait
+                 (concat "UID STORE " articles
+                         " FLAGS" (if silent ".SILENT") " (" flags ")"))))))
+
+(defun imap-message-flags-del (articles flags &optional silent buffer)
+  (when (and articles flags)
+    (with-current-buffer (or buffer (current-buffer))
+      (imap-ok-p (imap-send-command-wait
+                 (concat "UID STORE " articles
+                         " -FLAGS" (if silent ".SILENT") " (" flags ")"))))))
+
+(defun imap-message-flags-add (articles flags &optional silent buffer)
+  (when (and articles flags)
+    (with-current-buffer (or buffer (current-buffer))
+      (imap-ok-p (imap-send-command-wait
+                 (concat "UID STORE " articles
+                         " +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
+
+;; Cf. http://thread.gmane.org/gmane.emacs.gnus.general/65317/focus=65343
+;; Signal an error if we'd get an integer overflow.
+;;
+;; FIXME: Identify relevant calls to `string-to-number' and replace them with
+;; `imap-string-to-integer'.
+(defun imap-string-to-integer (string &optional base)
+  (let ((number (string-to-number string base)))
+    (if (> number most-positive-fixnum)
+       (error
+        (format "String %s cannot be converted to a Lisp integer" number))
+      number)))
+
+(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer)
+  "Like `imap-fetch', but DTRT with Exchange 2007 bug.
+However, UIDS here is a cons, where the car is the canonical form
+of the UIDS specification, and the cdr is the one which works with
+Exchange 2007 or, potentially, other buggy servers.
+See `imap-enable-exchange-bug-workaround'."
+  ;; The first time we get here for a given, we'll try the canonical
+  ;; form.  If we get the known error from the buggy server, set the
+  ;; flag buffer-locally (to account for connections to multiple
+  ;; servers), then re-try with the alternative UIDS spec.  We don't
+  ;; unconditionally use the alternative form, since the
+  ;; currently-used alternatives are seriously inefficient with some
+  ;; servers (although they are valid).
+  ;;
+  ;; FIXME:  Maybe it would be cleaner to have a flag to not signal
+  ;; the error (which otherwise gives a message), and test
+  ;; `imap-failed-tags'.  Also, Other IMAP clients use other forms of
+  ;; request which work with Exchange, e.g. Claws does "UID FETCH 1:*
+  ;; (UID)" rather than "FETCH UID 1,*".  Is there a good reason not
+  ;; to do the same?
+  (condition-case data
+      ;; Binding `debug-on-error' allows us to get the error from
+      ;; `imap-parse-response' -- it's normally caught by Emacs around
+      ;; execution of a process filter.
+      (let ((debug-on-error t))
+       (imap-fetch (if imap-enable-exchange-bug-workaround
+                       (cdr uids)
+                     (car uids))
+                   props receive nouidfetch buffer))
+    (error
+     (if (and (not imap-enable-exchange-bug-workaround)
+             ;; This is the Exchange 2007 response.  It may be more
+             ;; robust just to check for a BAD response to the
+             ;; attempted fetch.
+             (string-match "The specified message set is invalid"
+                           (cadr data)))
+        (with-current-buffer (or buffer (current-buffer))
+          (set (make-local-variable 'imap-enable-exchange-bug-workaround)
+               t)
+          (imap-fetch (cdr uids) props receive nouidfetch))
+       (signal (car data) (cdr data))))))
+
+(defun imap-message-copyuid-1 (mailbox)
+  (if (imap-capability 'UIDPLUS)
+      (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
+           (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
+    (let ((old-mailbox imap-current-mailbox)
+         (state imap-state)
+         (imap-message-data (make-vector 2 0)))
+      (when (imap-mailbox-examine-1 mailbox)
+       (prog1
+           (and (imap-fetch-safe '("*" . "*:*") "UID")
+                (list (imap-mailbox-get-1 'uidvalidity mailbox)
+                      (apply 'max (imap-message-map
+                                   (lambda (uid prop) uid) 'UID))))
+         (if old-mailbox
+             (imap-mailbox-select old-mailbox (eq state 'examine))
+           (imap-mailbox-unselect)))))))
+
+(defun imap-message-copyuid (mailbox &optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-message-copyuid-1 (imap-utf7-decode mailbox))))
+
+(defun imap-message-copy (articles mailbox
+                                  &optional dont-create no-copyuid buffer)
+  "Copy ARTICLES to MAILBOX on server in BUFFER.
+ARTICLES is a string message set.  Create mailbox if it doesn't exist,
+unless DONT-CREATE is non-nil.  On success, return a list with
+the UIDVALIDITY of the mailbox the article(s) was copied to as the
+first element.  The rest of list contains the saved articles' UIDs."
+  (when articles
+    (with-current-buffer (or buffer (current-buffer))
+      (let ((mailbox (imap-utf7-encode mailbox)))
+       (if (let ((cmd (concat "UID COPY " articles " \"" mailbox "\""))
+                 (imap-current-target-mailbox mailbox))
+             (if (imap-ok-p (imap-send-command-wait cmd))
+                 t
+               (when (and (not dont-create)
+                          ;; removed because of buggy Oracle server
+                          ;; that doesn't send TRYCREATE tags (which
+                          ;; is a MUST according to specifications):
+                          ;;(imap-mailbox-get-1 'trycreate mailbox)
+                          (imap-mailbox-create-1 mailbox))
+                 (imap-ok-p (imap-send-command-wait cmd)))))
+           (or no-copyuid
+               (imap-message-copyuid-1 mailbox)))))))
+
+;; FIXME: Amalgamate with imap-message-copyuid-1, using an extra arg, since it
+;; shares most of the code?  -- fx
+(defun imap-message-appenduid-1 (mailbox)
+  (if (imap-capability 'UIDPLUS)
+      (imap-mailbox-get-1 'appenduid mailbox)
+    (let ((old-mailbox imap-current-mailbox)
+         (state imap-state)
+         (imap-message-data (make-vector 2 0)))
+      (when (imap-mailbox-examine-1 mailbox)
+       (prog1
+           (and (imap-fetch-safe '("*" . "*:*") "UID")
+                (list (imap-mailbox-get-1 'uidvalidity mailbox)
+                      (apply 'max (imap-message-map
+                                   (lambda (uid prop) uid) 'UID))))
+         (if old-mailbox
+             (imap-mailbox-select old-mailbox (eq state 'examine))
+           (imap-mailbox-unselect)))))))
+
+(defun imap-message-appenduid (mailbox &optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (imap-message-appenduid-1 (imap-utf7-encode mailbox))))
+
+(defun imap-message-append (mailbox article &optional flags date-time buffer)
+  "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER.
+FLAGS and DATE-TIME is currently not used.  Return a cons holding
+uidvalidity of MAILBOX and UID the newly created article got, or nil
+on failure."
+  (let ((mailbox (imap-utf7-encode mailbox)))
+    (with-current-buffer (or buffer (current-buffer))
+      (and (let ((imap-current-target-mailbox mailbox))
+            (imap-ok-p
+             (imap-send-command-wait
+              (list "APPEND \"" mailbox "\" "  article))))
+          (imap-message-appenduid-1 mailbox)))))
+
+(defun imap-body-lines (body)
+  "Return number of lines in article by looking at the mime bodystructure BODY."
+  (if (listp body)
+      (if (stringp (car body))
+         (cond ((and (string= (upcase (car body)) "TEXT")
+                     (numberp (nth 7 body)))
+                (nth 7 body))
+               ((and (string= (upcase (car body)) "MESSAGE")
+                     (numberp (nth 9 body)))
+                (nth 9 body))
+               (t 0))
+       (apply '+ (mapcar 'imap-body-lines body)))
+    0))
+
+(defun imap-envelope-from (from)
+  "Return a from string line."
+  (and from
+       (concat (aref from 0)
+              (if (aref from 0) " <")
+              (aref from 2)
+              "@"
+              (aref from 3)
+              (if (aref from 0) ">"))))
+
+\f
+;; Internal functions.
+
+(defun imap-add-callback (tag func)
+  (setq imap-callbacks (append (list (cons tag func)) imap-callbacks)))
+
+(defun imap-send-command-1 (cmdstr)
+  (setq cmdstr (concat cmdstr imap-client-eol))
+  (and imap-log
+       (with-current-buffer (get-buffer-create imap-log-buffer)
+        (imap-disable-multibyte)
+        (buffer-disable-undo)
+        (goto-char (point-max))
+        (insert cmdstr)))
+  (process-send-string imap-process cmdstr))
+
+(defun imap-send-command (command &optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (if (not (listp command)) (setq command (list command)))
+    (let ((tag (setq imap-tag (1+ imap-tag)))
+         cmd cmdstr)
+      (setq cmdstr (concat (number-to-string imap-tag) " "))
+      (while (setq cmd (pop command))
+       (cond ((stringp cmd)
+              (setq cmdstr (concat cmdstr cmd)))
+             ((bufferp cmd)
+              (let ((eol imap-client-eol)
+                    (calcfirst imap-calculate-literal-size-first)
+                    size)
+                (with-current-buffer cmd
+                  (if calcfirst
+                      (setq size (buffer-size)))
+                  (when (not (equal eol "\r\n"))
+                    ;; XXX modifies buffer!
+                    (goto-char (point-min))
+                    (while (search-forward "\r\n" nil t)
+                      (replace-match eol)))
+                  (if (not calcfirst)
+                      (setq size (buffer-size))))
+                (setq cmdstr
+                      (concat cmdstr (format "{%d}" size))))
+              (unwind-protect
+                  (progn
+                    (imap-send-command-1 cmdstr)
+                    (setq cmdstr nil)
+                    (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
+                        (setq command nil) ;; abort command if no cont-req
+                      (let ((process imap-process)
+                            (stream imap-stream)
+                            (eol imap-client-eol))
+                        (with-current-buffer cmd
+                          (and imap-log
+                               (with-current-buffer (get-buffer-create
+                                                     imap-log-buffer)
+                                 (imap-disable-multibyte)
+                                 (buffer-disable-undo)
+                                 (goto-char (point-max))
+                                 (insert-buffer-substring cmd)))
+                          (process-send-region process (point-min)
+                                               (point-max)))
+                        (process-send-string process imap-client-eol))))
+                (setq imap-continuation nil)))
+             ((functionp cmd)
+              (imap-send-command-1 cmdstr)
+              (setq cmdstr nil)
+              (unwind-protect
+                  (setq command
+                        (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
+                            nil ;; abort command if no cont-req
+                          (cons (funcall cmd imap-continuation)
+                                command)))
+                (setq imap-continuation nil)))
+             (t
+              (error "Unknown command type"))))
+      (if cmdstr
+         (imap-send-command-1 cmdstr))
+      tag)))
+
+(defun imap-wait-for-tag (tag &optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (let (imap-have-messaged)
+      (while (and (null imap-continuation)
+                 (memq (process-status imap-process) '(open run))
+                 (< imap-reached-tag tag))
+       (let ((len (/ (buffer-size) 1024))
+             message-log-max)
+         (unless (< len 10)
+           (setq imap-have-messaged t)
+           (message "imap read: %dk" len))
+         (accept-process-output imap-process
+                                (truncate imap-read-timeout)
+                                (truncate (* (- imap-read-timeout
+                                                (truncate imap-read-timeout))
+                                             1000)))))
+      ;; A process can die _before_ we have processed everything it
+      ;; has to say.  Moreover, this can happen in between the call to
+      ;; accept-process-output and the call to process-status in an
+      ;; iteration of the loop above.
+      (when (and (null imap-continuation)
+                (< imap-reached-tag tag))
+       (accept-process-output imap-process 0 0))
+      (when imap-have-messaged
+       (message ""))
+      (and (memq (process-status imap-process) '(open run))
+          (or (assq tag imap-failed-tags)
+              (if imap-continuation
+                  'INCOMPLETE
+                'OK))))))
+
+(defun imap-sentinel (process string)
+  (delete-process process))
+
+(defun imap-find-next-line ()
+  "Return point at end of current line, taking into account literals.
+Return nil if no complete line has arrived."
+  (when (re-search-forward (concat imap-server-eol "\\|{\\([0-9]+\\)}"
+                                  imap-server-eol)
+                          nil t)
+    (if (match-string 1)
+       (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
+           nil
+         (goto-char (+ (point) (string-to-number (match-string 1))))
+         (imap-find-next-line))
+      (point))))
+
+(defun imap-arrival-filter (proc string)
+  "IMAP process filter."
+  ;; Sometimes, we are called even though the process has died.
+  ;; Better abstain from doing stuff in that case.
+  (when (buffer-name (process-buffer proc))
+    (with-current-buffer (process-buffer proc)
+      (goto-char (point-max))
+      (insert string)
+      (and imap-log
+          (with-current-buffer (get-buffer-create imap-log-buffer)
+            (imap-disable-multibyte)
+            (buffer-disable-undo)
+            (goto-char (point-max))
+            (insert string)))
+      (let (end)
+       (goto-char (point-min))
+       (while (setq end (imap-find-next-line))
+         (save-restriction
+           (narrow-to-region (point-min) end)
+           (delete-backward-char (length imap-server-eol))
+           (goto-char (point-min))
+           (unwind-protect
+               (cond ((eq imap-state 'initial)
+                      (imap-parse-greeting))
+                     ((or (eq imap-state 'auth)
+                          (eq imap-state 'nonauth)
+                          (eq imap-state 'selected)
+                          (eq imap-state 'examine))
+                      (imap-parse-response))
+                     (t
+                      (message "Unknown state %s in arrival filter"
+                               imap-state)))
+             (delete-region (point-min) (point-max)))))))))
+
+\f
+;; Imap parser.
+
+(defsubst imap-forward ()
+  (or (eobp) (forward-char)))
+
+;;   number          = 1*DIGIT
+;;                       ; Unsigned 32-bit integer
+;;                       ; (0 <= n < 4,294,967,296)
+
+(defsubst imap-parse-number ()
+  (when (looking-at "[0-9]+")
+    (prog1
+       (string-to-number (match-string 0))
+      (goto-char (match-end 0)))))
+
+;;   literal         = "{" number "}" CRLF *CHAR8
+;;                       ; Number represents the number of CHAR8s
+
+(defsubst imap-parse-literal ()
+  (when (looking-at "{\\([0-9]+\\)}\r\n")
+    (let ((pos (match-end 0))
+         (len (string-to-number (match-string 1))))
+      (if (< (point-max) (+ pos len))
+         nil
+       (goto-char (+ pos len))
+       (buffer-substring pos (+ pos len))))))
+
+;;   string          = quoted / literal
+;;
+;;   quoted          = DQUOTE *QUOTED-CHAR DQUOTE
+;;
+;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
+;;                     "\" quoted-specials
+;;
+;;   quoted-specials = DQUOTE / "\"
+;;
+;;   TEXT-CHAR       = <any CHAR except CR and LF>
+
+(defsubst imap-parse-string ()
+  (cond ((eq (char-after) ?\")
+        (forward-char 1)
+        (let ((p (point)) (name ""))
+          (skip-chars-forward "^\"\\\\")
+          (setq name (buffer-substring p (point)))
+          (while (eq (char-after) ?\\)
+            (setq p (1+ (point)))
+            (forward-char 2)
+            (skip-chars-forward "^\"\\\\")
+            (setq name (concat name (buffer-substring p (point)))))
+          (forward-char 1)
+          name))
+       ((eq (char-after) ?{)
+        (imap-parse-literal))))
+
+;;   nil             = "NIL"
+
+(defsubst imap-parse-nil ()
+  (if (looking-at "NIL")
+      (goto-char (match-end 0))))
+
+;;   nstring         = string / nil
+
+(defsubst imap-parse-nstring ()
+  (or (imap-parse-string)
+      (and (imap-parse-nil)
+          nil)))
+
+;;   astring         = atom / string
+;;
+;;   atom            = 1*ATOM-CHAR
+;;
+;;   ATOM-CHAR       = <any CHAR except atom-specials>
+;;
+;;   atom-specials   = "(" / ")" / "{" / SP / CTL / list-wildcards /
+;;                     quoted-specials
+;;
+;;   list-wildcards  = "%" / "*"
+;;
+;;   quoted-specials = DQUOTE / "\"
+
+(defsubst imap-parse-astring ()
+  (or (imap-parse-string)
+      (buffer-substring (point)
+                       (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
+                           (goto-char (1- (match-end 0)))
+                         (end-of-line)
+                         (point)))))
+
+;;   address         = "(" addr-name SP addr-adl SP addr-mailbox SP
+;;                      addr-host ")"
+;;
+;;   addr-adl        = nstring
+;;                       ; Holds route from [RFC-822] route-addr if
+;;                       ; non-nil
+;;
+;;   addr-host       = nstring
+;;                       ; nil indicates [RFC-822] group syntax.
+;;                       ; Otherwise, holds [RFC-822] domain name
+;;
+;;   addr-mailbox    = nstring
+;;                       ; nil indicates end of [RFC-822] group; if
+;;                       ; non-nil and addr-host is nil, holds
+;;                       ; [RFC-822] group name.
+;;                       ; Otherwise, holds [RFC-822] local-part
+;;                       ; after removing [RFC-822] quoting
+;;
+;;   addr-name       = nstring
+;;                       ; If non-nil, holds phrase from [RFC-822]
+;;                       ; mailbox after removing [RFC-822] quoting
+;;
+
+(defsubst imap-parse-address ()
+  (let (address)
+    (when (eq (char-after) ?\()
+      (imap-forward)
+      (setq address (vector (prog1 (imap-parse-nstring)
+                             (imap-forward))
+                           (prog1 (imap-parse-nstring)
+                             (imap-forward))
+                           (prog1 (imap-parse-nstring)
+                             (imap-forward))
+                           (imap-parse-nstring)))
+      (when (eq (char-after) ?\))
+       (imap-forward)
+       address))))
+
+;;   address-list    = "(" 1*address ")" / nil
+;;
+;;   nil             = "NIL"
+
+(defsubst imap-parse-address-list ()
+  (if (eq (char-after) ?\()
+      (let (address addresses)
+       (imap-forward)
+       (while (and (not (eq (char-after) ?\)))
+                   ;; next line for MS Exchange bug
+                   (progn (and (eq (char-after) ? ) (imap-forward)) t)
+                   (setq address (imap-parse-address)))
+         (setq addresses (cons address addresses)))
+       (when (eq (char-after) ?\))
+         (imap-forward)
+         (nreverse addresses)))
+    ;; With assert, the code might not be eval'd.
+    ;; (assert (imap-parse-nil) t "In imap-parse-address-list")
+    (imap-parse-nil)))
+
+;;   mailbox         = "INBOX" / astring
+;;                       ; INBOX is case-insensitive.  All case variants of
+;;                       ; INBOX (e.g. "iNbOx") MUST be interpreted as INBOX
+;;                       ; not as an astring.  An astring which consists of
+;;                       ; the case-insensitive sequence "I" "N" "B" "O" "X"
+;;                       ; is considered to be INBOX and not an astring.
+;;                       ;  Refer to section 5.1 for further
+;;                       ; semantic details of mailbox names.
+
+(defsubst imap-parse-mailbox ()
+  (let ((mailbox (imap-parse-astring)))
+    (if (string-equal "INBOX" (upcase mailbox))
+       "INBOX"
+      mailbox)))
+
+;;   greeting        = "*" SP (resp-cond-auth / resp-cond-bye) CRLF
+;;
+;;   resp-cond-auth  = ("OK" / "PREAUTH") SP resp-text
+;;                       ; Authentication condition
+;;
+;;   resp-cond-bye   = "BYE" SP resp-text
+
+(defun imap-parse-greeting ()
+  "Parse an IMAP greeting."
+  (cond ((looking-at "\\* OK ")
+        (setq imap-state 'nonauth))
+       ((looking-at "\\* PREAUTH ")
+        (setq imap-state 'auth))
+       ((looking-at "\\* BYE ")
+        (setq imap-state 'closed))))
+
+;;   response        = *(continue-req / response-data) response-done
+;;
+;;   continue-req    = "+" SP (resp-text / base64) CRLF
+;;
+;;   response-data   = "*" SP (resp-cond-state / resp-cond-bye /
+;;                     mailbox-data / message-data / capability-data) CRLF
+;;
+;;   response-done   = response-tagged / response-fatal
+;;
+;;   response-fatal  = "*" SP resp-cond-bye CRLF
+;;                       ; Server closes connection immediately
+;;
+;;   response-tagged = tag SP resp-cond-state CRLF
+;;
+;;   resp-cond-state = ("OK" / "NO" / "BAD") SP resp-text
+;;                       ; Status condition
+;;
+;;   resp-cond-bye   = "BYE" SP resp-text
+;;
+;;   mailbox-data    =  "FLAGS" SP flag-list /
+;;                     "LIST" SP mailbox-list /
+;;                      "LSUB" SP mailbox-list /
+;;                     "SEARCH" *(SP nz-number) /
+;;                      "STATUS" SP mailbox SP "("
+;;                           [status-att SP number *(SP status-att SP number)] ")" /
+;;                      number SP "EXISTS" /
+;;                     number SP "RECENT"
+;;
+;;   message-data    = nz-number SP ("EXPUNGE" / ("FETCH" SP msg-att))
+;;
+;;   capability-data = "CAPABILITY" *(SP capability) SP "IMAP4rev1"
+;;                     *(SP capability)
+;;                       ; IMAP4rev1 servers which offer RFC 1730
+;;                       ; compatibility MUST list "IMAP4" as the first
+;;                       ; capability.
+
+(defun imap-parse-response ()
+  "Parse a IMAP command response."
+  (let (token)
+    (case (setq token (read (current-buffer)))
+      (+ (setq imap-continuation
+              (or (buffer-substring (min (point-max) (1+ (point)))
+                                    (point-max))
+                  t)))
+      (* (case (prog1 (setq token (read (current-buffer)))
+                (imap-forward))
+          (OK         (imap-parse-resp-text))
+          (NO         (imap-parse-resp-text))
+          (BAD        (imap-parse-resp-text))
+          (BYE        (imap-parse-resp-text))
+          (FLAGS      (imap-mailbox-put 'flags (imap-parse-flag-list)))
+          (LIST       (imap-parse-data-list 'list))
+          (LSUB       (imap-parse-data-list 'lsub))
+          (SEARCH     (imap-mailbox-put
+                       'search
+                       (read (concat "(" (buffer-substring (point) (point-max)) ")"))))
+          (STATUS     (imap-parse-status))
+          (CAPABILITY (setq imap-capability
+                              (read (concat "(" (upcase (buffer-substring
+                                                         (point) (point-max)))
+                                            ")"))))
+          (ID         (setq imap-id (read (buffer-substring (point)
+                                                            (point-max)))))
+          (ACL        (imap-parse-acl))
+          (t       (case (prog1 (read (current-buffer))
+                           (imap-forward))
+                     (EXISTS  (imap-mailbox-put 'exists token))
+                     (RECENT  (imap-mailbox-put 'recent token))
+                     (EXPUNGE t)
+                     (FETCH   (imap-parse-fetch token))
+                     (t       (message "Garbage: %s" (buffer-string)))))))
+      (t (let (status)
+          (if (not (integerp token))
+              (message "Garbage: %s" (buffer-string))
+            (case (prog1 (setq status (read (current-buffer)))
+                    (imap-forward))
+              (OK  (progn
+                     (setq imap-reached-tag (max imap-reached-tag token))
+                     (imap-parse-resp-text)))
+              (NO  (progn
+                     (setq imap-reached-tag (max imap-reached-tag token))
+                     (save-excursion
+                       (imap-parse-resp-text))
+                     (let (code text)
+                       (when (eq (char-after) ?\[)
+                         (setq code (buffer-substring (point)
+                                                      (search-forward "]")))
+                         (imap-forward))
+                       (setq text (buffer-substring (point) (point-max)))
+                       (push (list token status code text)
+                             imap-failed-tags))))
+              (BAD (progn
+                     (setq imap-reached-tag (max imap-reached-tag token))
+                     (save-excursion
+                       (imap-parse-resp-text))
+                     (let (code text)
+                       (when (eq (char-after) ?\[)
+                         (setq code (buffer-substring (point)
+                                                      (search-forward "]")))
+                         (imap-forward))
+                       (setq text (buffer-substring (point) (point-max)))
+                       (push (list token status code text) imap-failed-tags)
+                       (error "Internal error, tag %s status %s code %s text %s"
+                              token status code text))))
+              (t   (message "Garbage: %s" (buffer-string))))
+            (when (assq token imap-callbacks)
+              (funcall (cdr (assq token imap-callbacks)) token status)
+              (setq imap-callbacks
+                    (imap-remassoc token imap-callbacks)))))))))
+
+;;   resp-text       = ["[" resp-text-code "]" SP] text
+;;
+;;   text            = 1*TEXT-CHAR
+;;
+;;   TEXT-CHAR       = <any CHAR except CR and LF>
+
+(defun imap-parse-resp-text ()
+  (imap-parse-resp-text-code))
+
+;;   resp-text-code  = "ALERT" /
+;;                     "BADCHARSET [SP "(" astring *(SP astring) ")" ] /
+;;                     "NEWNAME" SP string SP string /
+;;                    "PARSE" /
+;;                     "PERMANENTFLAGS" SP "("
+;;                               [flag-perm *(SP flag-perm)] ")" /
+;;                     "READ-ONLY" /
+;;                    "READ-WRITE" /
+;;                    "TRYCREATE" /
+;;                     "UIDNEXT" SP nz-number /
+;;                    "UIDVALIDITY" SP nz-number /
+;;                     "UNSEEN" SP nz-number /
+;;                     resp-text-atom [SP 1*<any TEXT-CHAR except "]">]
+;;
+;;   resp_code_apnd  = "APPENDUID" SPACE nz_number SPACE uniqueid
+;;
+;;   resp_code_copy  = "COPYUID" SPACE nz_number SPACE set SPACE set
+;;
+;;   set             = sequence-num / (sequence-num ":" sequence-num) /
+;;                        (set "," set)
+;;                          ; Identifies a set of messages.  For message
+;;                          ; sequence numbers, these are consecutive
+;;                          ; numbers from 1 to the number of messages in
+;;                          ; the mailbox
+;;                          ; Comma delimits individual numbers, colon
+;;                          ; delimits between two numbers inclusive.
+;;                          ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13,
+;;                          ; 14,15 for a mailbox with 15 messages.
+;;
+;;   sequence-num    = nz-number / "*"
+;;                          ; * is the largest number in use.  For message
+;;                          ; sequence numbers, it is the number of messages
+;;                          ; in the mailbox.  For unique identifiers, it is
+;;                          ; the unique identifier of the last message in
+;;                          ; the mailbox.
+;;
+;;   flag-perm       = flag / "\*"
+;;
+;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
+;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
+;;                       ; Does not include "\Recent"
+;;
+;;   flag-extension  = "\" atom
+;;                       ; Future expansion.  Client implementations
+;;                       ; MUST accept flag-extension flags.  Server
+;;                       ; implementations MUST NOT generate
+;;                       ; flag-extension flags except as defined by
+;;                       ; future standard or standards-track
+;;                       ; revisions of this specification.
+;;
+;;   flag-keyword    = atom
+;;
+;;   resp-text-atom  = 1*<any ATOM-CHAR except "]">
+
+(defun imap-parse-resp-text-code ()
+  ;; xxx next line for stalker communigate pro 3.3.1 bug
+  (when (looking-at " \\[")
+    (imap-forward))
+  (when (eq (char-after) ?\[)
+    (imap-forward)
+    (cond ((search-forward "PERMANENTFLAGS " nil t)
+          (imap-mailbox-put 'permanentflags (imap-parse-flag-list)))
+         ((search-forward "UIDNEXT \\([0-9]+\\)" nil t)
+          (imap-mailbox-put 'uidnext (match-string 1)))
+         ((search-forward "UNSEEN " nil t)
+          (imap-mailbox-put 'first-unseen (read (current-buffer))))
+         ((looking-at "UIDVALIDITY \\([0-9]+\\)")
+          (imap-mailbox-put 'uidvalidity (match-string 1)))
+         ((search-forward "READ-ONLY" nil t)
+          (imap-mailbox-put 'read-only t))
+         ((search-forward "NEWNAME " nil t)
+          (let (oldname newname)
+            (setq oldname (imap-parse-string))
+            (imap-forward)
+            (setq newname (imap-parse-string))
+            (imap-mailbox-put 'newname newname oldname)))
+         ((search-forward "TRYCREATE" nil t)
+          (imap-mailbox-put 'trycreate t imap-current-target-mailbox))
+         ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
+          (imap-mailbox-put 'appenduid
+                            (list (match-string 1)
+                                  (string-to-number (match-string 2)))
+                            imap-current-target-mailbox))
+         ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
+          (imap-mailbox-put 'copyuid (list (match-string 1)
+                                           (match-string 2)
+                                           (match-string 3))
+                            imap-current-target-mailbox))
+         ((search-forward "ALERT] " nil t)
+          (message "Imap server %s information: %s" imap-server
+                   (buffer-substring (point) (point-max)))))))
+
+;;   mailbox-list    = "(" [mbx-list-flags] ")" SP
+;;                      (DQUOTE QUOTED-CHAR DQUOTE / nil) SP mailbox
+;;
+;;   mbx-list-flags  = *(mbx-list-oflag SP) mbx-list-sflag
+;;                     *(SP mbx-list-oflag) /
+;;                     mbx-list-oflag *(SP mbx-list-oflag)
+;;
+;;   mbx-list-oflag  = "\Noinferiors" / flag-extension
+;;                       ; Other flags; multiple possible per LIST response
+;;
+;;   mbx-list-sflag  = "\Noselect" / "\Marked" / "\Unmarked"
+;;                       ; Selectability flags; only one per LIST response
+;;
+;;   QUOTED-CHAR     = <any TEXT-CHAR except quoted-specials> /
+;;                     "\" quoted-specials
+;;
+;;   quoted-specials = DQUOTE / "\"
+
+(defun imap-parse-data-list (type)
+  (let (flags delimiter mailbox)
+    (setq flags (imap-parse-flag-list))
+    (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
+      (setq delimiter (match-string 1))
+      (goto-char (1+ (match-end 0)))
+      (when (setq mailbox (imap-parse-mailbox))
+       (imap-mailbox-put type t mailbox)
+       (imap-mailbox-put 'list-flags flags mailbox)
+       (imap-mailbox-put 'delimiter delimiter mailbox)))))
+
+;;  msg_att         ::= "(" 1#("ENVELOPE" SPACE envelope /
+;;                      "FLAGS" SPACE "(" #(flag / "\Recent") ")" /
+;;                      "INTERNALDATE" SPACE date_time /
+;;                      "RFC822" [".HEADER" / ".TEXT"] SPACE nstring /
+;;                      "RFC822.SIZE" SPACE number /
+;;                      "BODY" ["STRUCTURE"] SPACE body /
+;;                      "BODY" section ["<" number ">"] SPACE nstring /
+;;                      "UID" SPACE uniqueid) ")"
+;;
+;;  date_time       ::= <"> date_day_fixed "-" date_month "-" date_year
+;;                      SPACE time SPACE zone <">
+;;
+;;  section         ::= "[" [section_text / (nz_number *["." nz_number]
+;;                      ["." (section_text / "MIME")])] "]"
+;;
+;;  section_text    ::= "HEADER" / "HEADER.FIELDS" [".NOT"]
+;;                      SPACE header_list / "TEXT"
+;;
+;;  header_fld_name ::= astring
+;;
+;;  header_list     ::= "(" 1#header_fld_name ")"
+
+(defsubst imap-parse-header-list ()
+  (when (eq (char-after) ?\()
+    (let (strlist)
+      (while (not (eq (char-after) ?\)))
+       (imap-forward)
+       (push (imap-parse-astring) strlist))
+      (imap-forward)
+      (nreverse strlist))))
+
+(defsubst imap-parse-fetch-body-section ()
+  (let ((section
+        (buffer-substring (point) (1- (re-search-forward "[] ]" nil t)))))
+    (if (eq (char-before) ? )
+       (prog1
+           (mapconcat 'identity (cons section (imap-parse-header-list)) " ")
+         (search-forward "]" nil t))
+      section)))
+
+(defun imap-parse-fetch (response)
+  (when (eq (char-after) ?\()
+    (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
+             rfc822size body bodydetail bodystructure flags-empty)
+      ;; Courier can insert spurious blank characters which will
+      ;; confuse `read', so skip past them.
+      (while (let ((moved (skip-chars-forward " \t")))
+              (prog1 (not (eq (char-after) ?\)))
+                (unless (= moved 0) (backward-char))))
+       (imap-forward)
+       (let ((token (read (current-buffer))))
+         (imap-forward)
+         (cond ((eq token 'UID)
+                (setq uid (condition-case ()
+                              (read (current-buffer))
+                            (error))))
+               ((eq token 'FLAGS)
+                (setq flags (imap-parse-flag-list))
+                (if (not flags)
+                    (setq flags-empty 't)))
+               ((eq token 'ENVELOPE)
+                (setq envelope (imap-parse-envelope)))
+               ((eq token 'INTERNALDATE)
+                (setq internaldate (imap-parse-string)))
+               ((eq token 'RFC822)
+                (setq rfc822 (imap-parse-nstring)))
+               ((eq token 'RFC822.HEADER)
+                (setq rfc822header (imap-parse-nstring)))
+               ((eq token 'RFC822.TEXT)
+                (setq rfc822text (imap-parse-nstring)))
+               ((eq token 'RFC822.SIZE)
+                (setq rfc822size (read (current-buffer))))
+               ((eq token 'BODY)
+                (if (eq (char-before) ?\[)
+                    (push (list
+                           (upcase (imap-parse-fetch-body-section))
+                           (and (eq (char-after) ?<)
+                                (buffer-substring (1+ (point))
+                                                  (search-forward ">" nil t)))
+                           (progn (imap-forward)
+                                  (imap-parse-nstring)))
+                          bodydetail)
+                  (setq body (imap-parse-body))))
+               ((eq token 'BODYSTRUCTURE)
+                (setq bodystructure (imap-parse-body))))))
+      (when uid
+       (setq imap-current-message uid)
+       (imap-message-put uid 'UID uid)
+       (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags))
+       (and envelope (imap-message-put uid 'ENVELOPE envelope))
+       (and internaldate (imap-message-put uid 'INTERNALDATE internaldate))
+       (and rfc822 (imap-message-put uid 'RFC822 rfc822))
+       (and rfc822header (imap-message-put uid 'RFC822.HEADER rfc822header))
+       (and rfc822text (imap-message-put uid 'RFC822.TEXT rfc822text))
+       (and rfc822size (imap-message-put uid 'RFC822.SIZE rfc822size))
+       (and body (imap-message-put uid 'BODY body))
+       (and bodydetail (imap-message-put uid 'BODYDETAIL bodydetail))
+       (and bodystructure (imap-message-put uid 'BODYSTRUCTURE bodystructure))
+       (run-hooks 'imap-fetch-data-hook)))))
+
+;;   mailbox-data    =  ...
+;;                      "STATUS" SP mailbox SP "("
+;;                           [status-att SP number
+;;                            *(SP status-att SP number)] ")"
+;;                      ...
+;;
+;;   status-att      = "MESSAGES" / "RECENT" / "UIDNEXT" / "UIDVALIDITY" /
+;;                     "UNSEEN"
+
+(defun imap-parse-status ()
+  (let ((mailbox (imap-parse-mailbox)))
+    (if (eq (char-after) ? )
+       (forward-char))
+    (when (and mailbox (eq (char-after) ?\())
+      (while (and (not (eq (char-after) ?\)))
+                 (or (forward-char) t)
+                 (looking-at "\\([A-Za-z]+\\) "))
+       (let ((token (upcase (match-string 1))))
+         (goto-char (match-end 0))
+         (cond ((string= token "MESSAGES")
+                (imap-mailbox-put 'messages (read (current-buffer)) mailbox))
+               ((string= token "RECENT")
+                (imap-mailbox-put 'recent (read (current-buffer)) mailbox))
+               ((string= token "UIDNEXT")
+                (and (looking-at "[0-9]+")
+                     (imap-mailbox-put 'uidnext (match-string 0) mailbox)
+                     (goto-char (match-end 0))))
+               ((string= token "UIDVALIDITY")
+                (and (looking-at "[0-9]+")
+                     (imap-mailbox-put 'uidvalidity (match-string 0) mailbox)
+                     (goto-char (match-end 0))))
+               ((string= token "UNSEEN")
+                (imap-mailbox-put 'unseen (read (current-buffer)) mailbox))
+               (t
+                (message "Unknown status data %s in mailbox %s ignored"
+                         token mailbox)
+                (read (current-buffer)))))))))
+
+;;   acl_data        ::= "ACL" SPACE mailbox *(SPACE identifier SPACE
+;;                        rights)
+;;
+;;   identifier      ::= astring
+;;
+;;   rights          ::= astring
+
+(defun imap-parse-acl ()
+  (let ((mailbox (imap-parse-mailbox))
+       identifier rights acl)
+    (while (eq (char-after) ?\ )
+      (imap-forward)
+      (setq identifier (imap-parse-astring))
+      (imap-forward)
+      (setq rights (imap-parse-astring))
+      (setq acl (append acl (list (cons identifier rights)))))
+    (imap-mailbox-put 'acl acl mailbox)))
+
+;;   flag-list       = "(" [flag *(SP flag)] ")"
+;;
+;;   flag            = "\Answered" / "\Flagged" / "\Deleted" /
+;;                     "\Seen" / "\Draft" / flag-keyword / flag-extension
+;;                       ; Does not include "\Recent"
+;;
+;;   flag-keyword    = atom
+;;
+;;   flag-extension  = "\" atom
+;;                       ; Future expansion.  Client implementations
+;;                       ; MUST accept flag-extension flags.  Server
+;;                       ; implementations MUST NOT generate
+;;                       ; flag-extension flags except as defined by
+;;                       ; future standard or standards-track
+;;                       ; revisions of this specification.
+
+(defun imap-parse-flag-list ()
+  (let (flag-list start)
+    (assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1")
+    (while (and (not (eq (char-after) ?\)))
+               (setq start (progn
+                             (imap-forward)
+                             ;; next line for Courier IMAP bug.
+                             (skip-chars-forward " ")
+                             (point)))
+               (> (skip-chars-forward "^ )" (point-at-eol)) 0))
+      (push (buffer-substring start (point)) flag-list))
+    (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2")
+    (imap-forward)
+    (nreverse flag-list)))
+
+;;   envelope        = "(" env-date SP env-subject SP env-from SP env-sender SP
+;;                     env-reply-to SP env-to SP env-cc SP env-bcc SP
+;;                     env-in-reply-to SP env-message-id ")"
+;;
+;;   env-bcc         = "(" 1*address ")" / nil
+;;
+;;   env-cc          = "(" 1*address ")" / nil
+;;
+;;   env-date        = nstring
+;;
+;;   env-from        = "(" 1*address ")" / nil
+;;
+;;   env-in-reply-to = nstring
+;;
+;;   env-message-id  = nstring
+;;
+;;   env-reply-to    = "(" 1*address ")" / nil
+;;
+;;   env-sender      = "(" 1*address ")" / nil
+;;
+;;   env-subject     = nstring
+;;
+;;   env-to          = "(" 1*address ")" / nil
+
+(defun imap-parse-envelope ()
+  (when (eq (char-after) ?\()
+    (imap-forward)
+    (vector (prog1 (imap-parse-nstring)        ;; date
+             (imap-forward))
+           (prog1 (imap-parse-nstring) ;; subject
+             (imap-forward))
+           (prog1 (imap-parse-address-list) ;; from
+             (imap-forward))
+           (prog1 (imap-parse-address-list) ;; sender
+             (imap-forward))
+           (prog1 (imap-parse-address-list) ;; reply-to
+             (imap-forward))
+           (prog1 (imap-parse-address-list) ;; to
+             (imap-forward))
+           (prog1 (imap-parse-address-list) ;; cc
+             (imap-forward))
+           (prog1 (imap-parse-address-list) ;; bcc
+             (imap-forward))
+           (prog1 (imap-parse-nstring) ;; in-reply-to
+             (imap-forward))
+           (prog1 (imap-parse-nstring) ;; message-id
+             (imap-forward)))))
+
+;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
+
+(defsubst imap-parse-string-list ()
+  (cond ((eq (char-after) ?\() ;; body-fld-param
+        (let (strlist str)
+          (imap-forward)
+          (while (setq str (imap-parse-string))
+            (push str strlist)
+            ;; buggy stalker communigate pro 3.0 doesn't print SPC
+            ;; between body-fld-param's sometimes
+            (or (eq (char-after) ?\")
+                (imap-forward)))
+          (nreverse strlist)))
+       ((imap-parse-nil)
+        nil)))
+
+;;   body-extension  = nstring / number /
+;;                      "(" body-extension *(SP body-extension) ")"
+;;                       ; Future expansion.  Client implementations
+;;                       ; MUST accept body-extension fields.  Server
+;;                       ; implementations MUST NOT generate
+;;                       ; body-extension fields except as defined by
+;;                       ; future standard or standards-track
+;;                       ; revisions of this specification.
+
+(defun imap-parse-body-extension ()
+  (if (eq (char-after) ?\()
+      (let (b-e)
+       (imap-forward)
+       (push (imap-parse-body-extension) b-e)
+       (while (eq (char-after) ?\ )
+         (imap-forward)
+         (push (imap-parse-body-extension) b-e))
+       (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension")
+       (imap-forward)
+       (nreverse b-e))
+    (or (imap-parse-number)
+       (imap-parse-nstring))))
+
+;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
+;;                     *(SP body-extension)]]
+;;                       ; MUST NOT be returned on non-extensible
+;;                       ; "BODY" fetch
+;;
+;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
+;;                     *(SP body-extension)]]
+;;                       ; MUST NOT be returned on non-extensible
+;;                       ; "BODY" fetch
+
+(defsubst imap-parse-body-ext ()
+  (let (ext)
+    (when (eq (char-after) ?\ )        ;; body-fld-dsp
+      (imap-forward)
+      (let (dsp)
+       (if (eq (char-after) ?\()
+           (progn
+             (imap-forward)
+             (push (imap-parse-string) dsp)
+             (imap-forward)
+             (push (imap-parse-string-list) dsp)
+             (imap-forward))
+         ;; With assert, the code might not be eval'd.
+         ;; (assert (imap-parse-nil) t "In imap-parse-body-ext")
+         (imap-parse-nil))
+       (push (nreverse dsp) ext))
+      (when (eq (char-after) ?\ ) ;; body-fld-lang
+       (imap-forward)
+       (if (eq (char-after) ?\()
+           (push (imap-parse-string-list) ext)
+         (push (imap-parse-nstring) ext))
+       (while (eq (char-after) ?\ ) ;; body-extension
+         (imap-forward)
+         (setq ext (append (imap-parse-body-extension) ext)))))
+    ext))
+
+;;   body            = "(" body-type-1part / body-type-mpart ")"
+;;
+;;   body-ext-1part  = body-fld-md5 [SP body-fld-dsp [SP body-fld-lang
+;;                     *(SP body-extension)]]
+;;                       ; MUST NOT be returned on non-extensible
+;;                       ; "BODY" fetch
+;;
+;;   body-ext-mpart  = body-fld-param [SP body-fld-dsp [SP body-fld-lang
+;;                     *(SP body-extension)]]
+;;                       ; MUST NOT be returned on non-extensible
+;;                       ; "BODY" fetch
+;;
+;;   body-fields     = body-fld-param SP body-fld-id SP body-fld-desc SP
+;;                     body-fld-enc SP body-fld-octets
+;;
+;;   body-fld-desc   = nstring
+;;
+;;   body-fld-dsp    = "(" string SP body-fld-param ")" / nil
+;;
+;;   body-fld-enc    = (DQUOTE ("7BIT" / "8BIT" / "BINARY" / "BASE64"/
+;;                     "QUOTED-PRINTABLE") DQUOTE) / string
+;;
+;;   body-fld-id     = nstring
+;;
+;;   body-fld-lang   = nstring / "(" string *(SP string) ")"
+;;
+;;   body-fld-lines  = number
+;;
+;;   body-fld-md5    = nstring
+;;
+;;   body-fld-octets = number
+;;
+;;   body-fld-param  = "(" string SP string *(SP string SP string) ")" / nil
+;;
+;;   body-type-1part = (body-type-basic / body-type-msg / body-type-text)
+;;                     [SP body-ext-1part]
+;;
+;;   body-type-basic = media-basic SP body-fields
+;;                       ; MESSAGE subtype MUST NOT be "RFC822"
+;;
+;;   body-type-msg   = media-message SP body-fields SP envelope
+;;                     SP body SP body-fld-lines
+;;
+;;   body-type-text  = media-text SP body-fields SP body-fld-lines
+;;
+;;   body-type-mpart = 1*body SP media-subtype
+;;                     [SP body-ext-mpart]
+;;
+;;   media-basic     = ((DQUOTE ("APPLICATION" / "AUDIO" / "IMAGE" /
+;;                     "MESSAGE" / "VIDEO") DQUOTE) / string) SP media-subtype
+;;                       ; Defined in [MIME-IMT]
+;;
+;;   media-message   = DQUOTE "MESSAGE" DQUOTE SP DQUOTE "RFC822" DQUOTE
+;;                      ; Defined in [MIME-IMT]
+;;
+;;   media-subtype   = string
+;;                       ; Defined in [MIME-IMT]
+;;
+;;   media-text      = DQUOTE "TEXT" DQUOTE SP media-subtype
+;;                       ; Defined in [MIME-IMT]
+
+(defun imap-parse-body ()
+  (let (body)
+    (when (eq (char-after) ?\()
+      (imap-forward)
+      (if (eq (char-after) ?\()
+         (let (subbody)
+           (while (and (eq (char-after) ?\()
+                       (setq subbody (imap-parse-body)))
+             ;; buggy stalker communigate pro 3.0 inserts a SPC between
+             ;; parts in multiparts
+             (when (and (eq (char-after) ?\ )
+                        (eq (char-after (1+ (point))) ?\())
+               (imap-forward))
+             (push subbody body))
+           (imap-forward)
+           (push (imap-parse-string) body) ;; media-subtype
+           (when (eq (char-after) ?\ ) ;; body-ext-mpart:
+             (imap-forward)
+             (if (eq (char-after) ?\() ;; body-fld-param
+                 (push (imap-parse-string-list) body)
+               (push (and (imap-parse-nil) nil) body))
+             (setq body
+                   (append (imap-parse-body-ext) body))) ;; body-ext-...
+           (assert (eq (char-after) ?\)) nil "In imap-parse-body")
+           (imap-forward)
+           (nreverse body))
+
+       (push (imap-parse-string) body) ;; media-type
+       (imap-forward)
+       (push (imap-parse-string) body) ;; media-subtype
+       (imap-forward)
+       ;; next line for Sun SIMS bug
+       (and (eq (char-after) ? ) (imap-forward))
+       (if (eq (char-after) ?\() ;; body-fld-param
+           (push (imap-parse-string-list) body)
+         (push (and (imap-parse-nil) nil) body))
+       (imap-forward)
+       (push (imap-parse-nstring) body) ;; body-fld-id
+       (imap-forward)
+       (push (imap-parse-nstring) body) ;; body-fld-desc
+       (imap-forward)
+       ;; Next `or' for Sun SIMS bug.  It regards body-fld-enc as a
+       ;; nstring and returns nil instead of defaulting back to 7BIT
+       ;; as the standard says.
+       ;; Exchange (2007, at least) does this as well.
+       (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc
+       (imap-forward)
+       ;; Exchange 2007 can return -1, contrary to the spec...
+       (if (eq (char-after) ?-)
+           (progn
+             (skip-chars-forward "-0-9")
+             (push nil body))
+         (push (imap-parse-number) body)) ;; body-fld-octets
+
+       ;; Ok, we're done parsing the required parts, what comes now is one of
+       ;; three things:
+       ;;
+       ;; envelope       (then we're parsing body-type-msg)
+       ;; body-fld-lines (then we're parsing body-type-text)
+       ;; body-ext-1part (then we're parsing body-type-basic)
+       ;;
+       ;; The problem is that the two first are in turn optionally followed
+       ;; by the third.  So we parse the first two here (if there are any)...
+
+       (when (eq (char-after) ?\ )
+         (imap-forward)
+         (let (lines)
+           (cond ((eq (char-after) ?\() ;; body-type-msg:
+                  (push (imap-parse-envelope) body) ;; envelope
+                  (imap-forward)
+                  (push (imap-parse-body) body) ;; body
+                  ;; buggy stalker communigate pro 3.0 doesn't print
+                  ;; number of lines in message/rfc822 attachment
+                  (if (eq (char-after) ?\))
+                      (push 0 body)
+                    (imap-forward)
+                    (push (imap-parse-number) body))) ;; body-fld-lines
+                 ((setq lines (imap-parse-number)) ;; body-type-text:
+                  (push lines body)) ;; body-fld-lines
+                 (t
+                  (backward-char))))) ;; no match...
+
+       ;; ...and then parse the third one here...
+
+       (when (eq (char-after) ?\ ) ;; body-ext-1part:
+         (imap-forward)
+         (push (imap-parse-nstring) body) ;; body-fld-md5
+         (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part..
+
+       (assert (eq (char-after) ?\)) nil "In imap-parse-body 2")
+       (imap-forward)
+       (nreverse body)))))
+
+(when imap-debug                       ; (untrace-all)
+  (require 'trace)
+  (buffer-disable-undo (get-buffer-create imap-debug-buffer))
+  (mapc (lambda (f) (trace-function-background f imap-debug-buffer))
+       '(
+         imap-utf7-encode
+         imap-utf7-decode
+         imap-error-text
+         imap-kerberos4s-p
+         imap-kerberos4-open
+         imap-ssl-p
+         imap-ssl-open
+         imap-network-p
+         imap-network-open
+         imap-interactive-login
+         imap-kerberos4a-p
+         imap-kerberos4-auth
+         imap-cram-md5-p
+         imap-cram-md5-auth
+         imap-login-p
+         imap-login-auth
+         imap-anonymous-p
+         imap-anonymous-auth
+         imap-open-1
+         imap-open
+         imap-opened
+         imap-ping-server
+         imap-authenticate
+         imap-close
+         imap-capability
+         imap-namespace
+         imap-send-command-wait
+         imap-mailbox-put
+         imap-mailbox-get
+         imap-mailbox-map-1
+         imap-mailbox-map
+         imap-current-mailbox
+         imap-current-mailbox-p-1
+         imap-current-mailbox-p
+         imap-mailbox-select-1
+         imap-mailbox-select
+         imap-mailbox-examine-1
+         imap-mailbox-examine
+         imap-mailbox-unselect
+         imap-mailbox-expunge
+         imap-mailbox-close
+         imap-mailbox-create-1
+         imap-mailbox-create
+         imap-mailbox-delete
+         imap-mailbox-rename
+         imap-mailbox-lsub
+         imap-mailbox-list
+         imap-mailbox-subscribe
+         imap-mailbox-unsubscribe
+         imap-mailbox-status
+         imap-mailbox-acl-get
+         imap-mailbox-acl-set
+         imap-mailbox-acl-delete
+         imap-current-message
+         imap-list-to-message-set
+         imap-fetch-asynch
+         imap-fetch
+         imap-fetch-safe
+         imap-message-put
+         imap-message-get
+         imap-message-map
+         imap-search
+         imap-message-flag-permanent-p
+         imap-message-flags-set
+         imap-message-flags-del
+         imap-message-flags-add
+         imap-message-copyuid-1
+         imap-message-copyuid
+         imap-message-copy
+         imap-message-appenduid-1
+         imap-message-appenduid
+         imap-message-append
+         imap-body-lines
+         imap-envelope-from
+         imap-send-command-1
+         imap-send-command
+         imap-wait-for-tag
+         imap-sentinel
+         imap-find-next-line
+         imap-arrival-filter
+         imap-parse-greeting
+         imap-parse-response
+         imap-parse-resp-text
+         imap-parse-resp-text-code
+         imap-parse-data-list
+         imap-parse-fetch
+         imap-parse-status
+         imap-parse-acl
+         imap-parse-flag-list
+         imap-parse-envelope
+         imap-parse-body-extension
+         imap-parse-body
+         )))
+
+(provide 'imap)
+
+;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7
+;;; imap.el ends here
index 403447f..ac19799 100644 (file)
 ;;; smiley.el --- displaying smiley faces
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000
+;;        Free Software Foundation, Inc.
 
-;; Copyright (C) 2000-2016 Free Software Foundation, Inc.
-
-;; Author: Dave Love <fx@gnu.org>
-;; Keywords: news mail multimedia
+;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
+;; Keywords: fun
 
 ;; This file is part of GNU Emacs.
 
-;; GNU Emacs is free software: you can redistribute it and/or modify
+;; GNU Emacs is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
 
 ;; GNU Emacs is distributed in the hope that it will be useful,
 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.         See the
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
 
 ;;; Commentary:
 
-;; A re-written, simplified version of Wes Hardaker's XEmacs smiley.el
-;; which might be merged back to smiley.el if we get an assignment for
-;; that.  We don't have assignments for the images smiley.el uses, but
-;; I'm not sure we need that degree of rococoness and defaults like a
-;; yellow background.  Also, using PBM means we can display the images
-;; more generally.  -- fx
-;; `smiley.el' was replaced by `smiley-ems.el' on 2002-01-26 (after fx'
-;; comment).
-
-;; Test smileys:
-;; smile             ^:-) ^:)
-;; blink             ;-)  ;)
-;; forced            :-]
-;; braindamaged      8-)
-;; indifferent       :-|
-;; wry               :-/  :-\
-;; sad               :-(
-;; frown             :-{
-;; evil              >:-)
-;; cry               ;-(
-;; dead              X-)
-;; grin              :-D
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'nnheader)
-(require 'gnus-art)
+;;
+;; comments go here.
+;;
+
+;;; Test smileys:  :-] :-o :-) ;-) :-\ :-| :-d :-P 8-| :-(
+
+;; To use:
+;; (require 'smiley)
+;; (setq gnus-treat-display-smileys t)
+
+;; The smilies were drawn by Joe Reiss <jreiss@vt.edu>.
+
+(require 'cl)
+(require 'custom)
+
+(eval-and-compile
+  (when (featurep 'xemacs)
+    (require 'annotations)
+    (require 'messagexmas)))
 
 (defgroup smiley nil
   "Turn :-)'s into real images."
   :group 'gnus-visual)
 
-(defvar smiley-data-directory)
-
-(defcustom smiley-style
-  (if (or (and (fboundp 'face-attribute)
-              ;; In batch mode, attributes can be unspecified.
-              (condition-case nil
-                  (>= (face-attribute 'default :height) 160)
-                (error nil)))
-         (and (fboundp 'face-height)
-              (>= (face-height 'default) 14)))
-      'medium
-    'low-color)
-  "Smiley style."
-  :type '(choice (const :tag "small, 3 colors" low-color) ;; 13x14
-                (const :tag "medium, ~10 colors" medium) ;; 16x16
-                (const :tag "dull, grayscale" grayscale));; 14x14
-  :set (lambda (symbol value)
-        (set-default symbol value)
-        (setq smiley-data-directory (smiley-directory))
-        (smiley-update-cache))
-  :initialize 'custom-initialize-default
-  :version "23.1" ;; No Gnus
-  :group 'smiley)
-
-;; For compatibility, honor the variable `smiley-data-directory' if the user
-;; has set it.
-
-(defun smiley-directory (&optional style)
-  "Return a the location of the smiley faces files.
-STYLE specifies which style to use, see `smiley-style'.  If STYLE
-is nil, use `smiley-style'."
-  (unless style (setq style smiley-style))
-  (nnheader-find-etc-directory
-   (concat "images/smilies"
-          (cond ((eq smiley-style 'low-color) "")
-                ((eq smiley-style 'medium) "/medium")
-                ((eq smiley-style 'grayscale) "/grayscale")))))
-
-(defcustom smiley-data-directory (smiley-directory)
+;; FIXME: Where is the directory when using Emacs?
+(defcustom smiley-data-directory 
+  (if (featurep 'xemacs)
+    (message-xmas-find-glyph-directory "smilies")
+    "/usr/local/lib/xemacs/xemacs-packages/etc/smilies")
   "*Location of the smiley faces files."
-  :set (lambda (symbol value)
-        (set-default symbol value)
-        (smiley-update-cache))
-  :initialize 'custom-initialize-default
   :type 'directory
   :group 'smiley)
 
-;; The XEmacs version has a baroque, if not rococo, set of these.
-(defcustom smiley-regexp-alist
-  '(("\\(;-)\\)\\W" 1 "blink")
-    ("[^;]\\(;)\\)\\W" 1 "blink")
-    ("\\(:-]\\)\\W" 1 "forced")
-    ("\\(8-)\\)\\W" 1 "braindamaged")
-    ("\\(:-|\\)\\W" 1 "indifferent")
-    ("\\(:-[/\\]\\)\\W" 1 "wry")
-    ("\\(:-(\\)\\W" 1 "sad")
-    ("\\(X-)\\)\\W" 1 "dead")
-    ("\\(:-{\\)\\W" 1 "frown")
-    ("\\(>:-)\\)\\W" 1 "evil")
-    ("\\(;-(\\)\\W" 1 "cry")
-    ("\\(:-D\\)\\W" 1 "grin")
-    ;; "smile" must be come after "evil"
-    ("\\(\\^?:-?)\\)\\W" 1 "smile"))
-  "*A list of regexps to map smilies to images.
-The elements are (REGEXP MATCH IMAGE), where MATCH is the submatch in
-regexp to replace with IMAGE.  IMAGE is the name of an image file in
-`smiley-data-directory'."
-  :version "24.1"
+;; Notice the subtle differences in the regular expressions in the
+;; two alists below.
+
+(defcustom smiley-deformed-regexp-alist
+  '(("\\(\\^_?\\^;;;\\)\\W" 1 "WideFaceAse3.xbm")
+    ("\\(\\^_?\\^;;\\)\\W" 1 "WideFaceAse2.xbm")
+    ("\\(\\^_?\\^;\\)\\W" 1 "WideFaceAse1.xbm")
+    ("\\(\\^_?\\^\\)\\W" 1 "WideFaceSmile.xbm")
+    ("\\(;_;\\)\\W" 1 "WideFaceWeep.xbm")
+    ("\\(T_T\\)\\W" 1 "WideFaceWeep.xbm")
+    ("\\(:-*[<«]+\\)\\W" 1 "FaceAngry.xpm")
+    ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
+    ("\\(:-*D\\)\\W" 1 "FaceGrinning.xpm")
+    ("\\(:-*[)>}»]+\\)\\W" 1 "FaceHappy.xpm")
+    ("\\(=[)»]+\\)\\W" 1 "FaceHappy.xpm")
+    ("\\(:-*[/\\\"]\\)[^/]\\W" 1 "FaceIronic.xpm")
+    ("[^.0-9]\\([8|]-*[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
+    ("\\([:|]-*#+\\)\\W" 1 "FaceNyah.xpm")
+    ("\\(:-*[({]+\\)\\W" 1 "FaceSad.xpm")
+    ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
+    ("\\(:-*[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
+    ("\\(:-*|\\)\\W" 1 "FaceStraight.xpm")
+    ("\\(:-*p\\)\\W" 1 "FaceTalking.xpm")
+    ("\\(:-*d\\)\\W" 1 "FaceTasty.xpm")
+    ("\\(;-*[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
+    ("\\(:-*[Vvµ]\\)\\W" 1 "FaceWry.xpm")
+    ("\\([:|]-*P\\)\\W" 1 "FaceYukky.xpm"))
+  "*Normal and deformed faces for smilies."
   :type '(repeat (list regexp
-                      (integer :tag "Regexp match number")
-                      (string :tag "Image name")))
-  :set (lambda (symbol value)
-        (set-default symbol value)
-        (smiley-update-cache))
-  :initialize 'custom-initialize-default
+                      (integer :tag "Match")
+                      (string :tag "Image")))
+  :group 'smiley)
+
+(defcustom smiley-nosey-regexp-alist
+  '(("\\(:-+[<«]+\\)\\W" 1 "FaceAngry.xpm")
+    ("\\(:-+\\]+\\)\\W" 1 "FaceGoofy.xpm")
+    ("\\(:-+D\\)\\W" 1 "FaceGrinning.xpm")
+    ("\\(:-+[}»]+\\)\\W" 1 "FaceHappy.xpm")
+    ("\\(:-*)+\\)\\W" 1 "FaceHappy.xpm")
+    ("\\(=[)]+\\)\\W" 1 "FaceHappy.xpm")
+    ("\\(:-+[/\\\"]+\\)\\W" 1 "FaceIronic.xpm")
+    ("\\([8|]-+[|Oo%]\\)\\W" 1 "FaceKOed.xpm")
+    ("\\([:|]-+#+\\)\\W" 1 "FaceNyah.xpm")
+    ("\\(:-+[({]+\\)\\W" 1 "FaceSad.xpm")
+    ("\\(=[({]+\\)\\W" 1 "FaceSad.xpm")
+    ("\\(:-+[Oo\*]\\)\\W" 1 "FaceStartled.xpm")
+    ("\\(:-+|\\)\\W" 1 "FaceStraight.xpm")
+    ("\\(:-+p\\)\\W" 1 "FaceTalking.xpm")
+    ("\\(:-+d\\)\\W" 1 "FaceTasty.xpm")
+    ("\\(;-+[>)}»]+\\)\\W" 1 "FaceWinking.xpm")
+    ("\\(:-+[Vvµ]\\)\\W" 1 "FaceWry.xpm")
+    ("\\(][:8B]-[)>]\\)\\W" 1 "FaceDevilish.xpm")
+    ("\\([:|]-+P\\)\\W" 1 "FaceYukky.xpm"))
+  "*Smileys with noses.  These get less false matches."
+  :type '(repeat (list regexp
+                      (integer :tag "Match")
+                      (string :tag "Image")))
+  :group 'smiley)
+
+(defcustom smiley-regexp-alist smiley-deformed-regexp-alist
+  "*A list of regexps to map smilies to real images.
+Defaults to the contents of `smiley-deformed-regexp-alist'.
+An alternative is `smiley-nosey-regexp-alist' that matches less
+aggressively.
+If this is a symbol, take its value."
+  :type '(radio (variable-item smiley-deformed-regexp-alist)
+               (variable-item smiley-nosey-regexp-alist)
+               symbol
+               (repeat (list regexp
+                             (integer :tag "Match")
+                             (string :tag "Image"))))
+  :group 'smiley)
+
+(defcustom smiley-flesh-color "yellow"
+  "*Flesh color."
+  :type 'string
+  :group 'smiley)
+
+(defcustom smiley-features-color "black"
+  "*Features color."
+  :type 'string
+  :group 'smiley)
+
+(defcustom smiley-tongue-color "red"
+  "*Tongue color."
+  :type 'string
+  :group 'smiley)
+
+(defcustom smiley-circle-color "black"
+  "*Circle color."
+  :type 'string
   :group 'smiley)
 
-(defcustom gnus-smiley-file-types
-  (let ((types (list "pbm")))
-    (when (gnus-image-type-available-p 'xpm)
-      (push "xpm" types))
-    (when (gnus-image-type-available-p 'gif)
-      (push "gif" types))
-    types)
-  "*List of suffixes on smiley file names to try."
-  :version "24.1"
-  :type '(repeat string)
+(defcustom smiley-mouse-face 'highlight
+  "*Face used for mouse highlighting in the smiley buffer.
+
+Smiley buttons will be displayed in this face when the cursor is
+above them."
+  :type 'face
   :group 'smiley)
 
-(defvar smiley-cached-regexp-alist nil)
-
-(defun smiley-update-cache ()
-  (setq smiley-cached-regexp-alist nil)
-  (dolist (elt (if (symbolp smiley-regexp-alist)
-                  (symbol-value smiley-regexp-alist)
-                smiley-regexp-alist))
-    (let ((types gnus-smiley-file-types)
-         file type)
-      (while (and (not file)
-                 (setq type (pop types)))
-       (unless (file-exists-p
-                (setq file (expand-file-name (concat (nth 2 elt) "." type)
-                                             smiley-data-directory)))
-         (setq file nil)))
-      (when type
-       (let ((image (gnus-create-image file (intern type) nil
-                                       :ascent 'center)))
-         (when image
-           (push (list (car elt) (cadr elt) image)
-                 smiley-cached-regexp-alist)))))))
-
-;; Not implemented:
-;; (defvar smiley-mouse-map
-;;   (let ((map (make-sparse-keymap)))
-;;     (define-key map [down-mouse-2] 'ignore) ; override widget
-;;     (define-key map [mouse-2]
-;;       'smiley-mouse-toggle-buffer)
-;;     map))
+(defvar smiley-glyph-cache nil)
+
+(defvar smiley-map (make-sparse-keymap "smiley-keys")
+  "Keymap to toggle smiley states.")
+
+(define-key smiley-map [(button2)] 'smiley-toggle-extent)
+(define-key smiley-map [(button3)] 'smiley-popup-menu)
+
+(defun smiley-popup-menu (e)
+  (interactive "e")
+  (popup-menu
+   `("Smilies"
+     ["Toggle This Smiley" (smiley-toggle-extent ,e) t]
+     ["Toggle All Smilies" (smiley-toggle-extents ,e) t])))
+
+(defun smiley-create-glyph (smiley pixmap)
+  (or
+   (cdr-safe (assoc pixmap smiley-glyph-cache))
+   (let* ((xpm-color-symbols
+          (and (featurep 'xpm)
+               (append `(("flesh" ,smiley-flesh-color)
+                         ("features" ,smiley-features-color)
+                         ("tongue" ,smiley-tongue-color))
+                       xpm-color-symbols)))
+         (glyph (make-glyph
+                 (list
+                  (cons (if (featurep 'gtk) 'gtk 'x)
+                        (expand-file-name pixmap smiley-data-directory))
+                  (cons 'mswindows
+                        (expand-file-name pixmap smiley-data-directory))
+                  (cons 'tty smiley)))))
+     (setq smiley-glyph-cache (cons (cons pixmap glyph) smiley-glyph-cache))
+     (set-glyph-face glyph 'default)
+     glyph)))
 
 ;;;###autoload
-(defun smiley-region (start end)
-  "Replace in the region `smiley-regexp-alist' matches with corresponding images.
-A list of images is returned."
+(defun smiley-region (beg end)
+  "Smilify the region between point and mark."
   (interactive "r")
-  (when (gnus-graphic-display-p)
-    (unless smiley-cached-regexp-alist
-      (smiley-update-cache))
+  (smiley-buffer (current-buffer) beg end))
+
+(defun smiley-toggle-extent (event)
+  "Toggle smiley at given point."
+  (interactive "e")
+  (let* ((ant (event-glyph-extent event))
+        (pt (event-closest-point event))
+        ext)
+    (if (annotationp ant)
+       (when (extentp (setq ext (extent-property ant 'smiley-extent)))
+         (set-extent-property ext 'invisible nil)
+         (hide-annotation ant))
+      (when pt
+       (while (setq ext (extent-at pt (event-buffer event) nil ext 'at))
+         (when (annotationp (setq ant
+                                  (extent-property ext 'smiley-annotation)))
+           (reveal-annotation ant)
+           (set-extent-property ext 'invisible t)))))))
+
+(defun smiley-toggle-extents (e)
+  (interactive "e")
+  (map-extents
+   (lambda (e void)
+     (let (ant)
+       (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
+          (if (eq (extent-property e 'invisible) nil)
+              (progn
+                (reveal-annotation ant)
+                (set-extent-property e 'invisible t)
+                )
+            (hide-annotation ant)
+            (set-extent-property e 'invisible nil)))
+       nil))
+   (event-buffer e)))
+
+;;;###autoload
+(defun smiley-buffer (&optional buffer st nd)
+  (interactive)
+  (when (featurep '(or x gtk mswindows))
     (save-excursion
-      (let ((beg (or start (point-min)))
-           group image images string)
-       (dolist (entry smiley-cached-regexp-alist)
-         (setq group (nth 1 entry)
-               image (nth 2 entry))
+      (when buffer
+       (set-buffer buffer))
+      (let ((buffer-read-only nil)
+           (alist (if (symbolp smiley-regexp-alist)
+                      (symbol-value smiley-regexp-alist)
+                    smiley-regexp-alist))
+           (case-fold-search nil)
+           entry regexp beg group file)
+       (map-extents
+        (lambda (e void)
+          (when (or (extent-property e 'smiley-extent)
+                    (extent-property e 'smiley-annotation))
+            (delete-extent e)))
+        buffer st nd)
+       (goto-char (or st (point-min)))
+       (setq beg (point))
+       ;; loop through alist
+       (while (setq entry (pop alist))
+         (setq regexp (car entry)
+               group (cadr entry)
+               file (caddr entry))
          (goto-char beg)
-         (while (re-search-forward (car entry) end t)
-           (setq string (match-string group))
-           (goto-char (match-end group))
-           (delete-region (match-beginning group) (match-end group))
-           (when image
-             (push image images)
-             (gnus-add-wash-type 'smiley)
-             (gnus-add-image 'smiley image)
-             (gnus-put-image image string 'smiley))))
-       images))))
+         (while (re-search-forward regexp nd t)
+           (let* ((start (match-beginning group))
+                  (end (match-end group))
+                  (glyph (smiley-create-glyph (buffer-substring start end)
+                                              file)))
+             (when glyph
+               (mapcar 'delete-annotation (annotations-at end))
+               (let ((ext (make-extent start end))
+                     (ant (make-annotation glyph end 'text)))
+                 ;; set text extent params
+                 (set-extent-property ext 'end-open t)
+                 (set-extent-property ext 'start-open t)
+                 (set-extent-property ext 'invisible t)
+                 (set-extent-property ext 'keymap smiley-map)
+                 (set-extent-property ext 'mouse-face smiley-mouse-face)
+                 (set-extent-property ext 'intangible t)
+                 ;; set annotation params
+                 (set-extent-property ant 'mouse-face smiley-mouse-face)
+                 (set-extent-property ant 'keymap smiley-map)
+                 ;; remember each other
+                 (set-extent-property ant 'smiley-extent ext)
+                 (set-extent-property ext 'smiley-annotation ant)
+                 ;; Help
+                 (set-extent-property
+                  ext 'help-echo
+                  "button2 toggles smiley, button3 pops up menu")
+                 (set-extent-property
+                  ant 'help-echo
+                  "button2 toggles smiley, button3 pops up menu")
+                 (set-extent-property ext 'balloon-help
+                                      "Mouse button2 - toggle smiley
+Mouse button3 - menu")
+                 (set-extent-property ant 'balloon-help
+                                      "Mouse button2 - toggle smiley
+Mouse button3 - menu"))
+               (when (smiley-end-paren-p start end)
+                 (make-annotation ")" end 'text))
+               (goto-char end)))))))))
 
-;;;###autoload
-(defun smiley-buffer (&optional buffer)
-  "Run `smiley-region' at the BUFFER, specified in the argument or
-interactively.  If there's no argument, do it at the current buffer."
-  (interactive "bBuffer to run smiley-region: ")
+(defun smiley-end-paren-p (start end)
+  "Try to guess whether the current smiley is an end-paren smiley."
   (save-excursion
-    (if buffer
-       (set-buffer (get-buffer buffer)))
-    (smiley-region (point-min) (point-max))))
+    (goto-char start)
+    (when (and (re-search-backward "[()]" nil t)
+              (eq (char-after) ?\()
+              (goto-char end)
+              (or (not (re-search-forward "[()]" nil t))
+                  (eq (char-after (1- (point))) ?\()))
+      t)))
 
-(defun smiley-toggle-buffer (&optional arg)
-  "Toggle displaying smiley faces in article buffer.
+(defun smiley-toggle-buffer (&optional arg buffer st nd)
+  "Toggle displaying smiley faces.
 With arg, turn displaying on if and only if arg is positive."
   (interactive "P")
-  (gnus-with-article-buffer
-    (if (if (numberp arg)
-           (> arg 0)
-         (not (memq 'smiley gnus-article-wash-types)))
-       (smiley-region (point-min) (point-max))
-      (gnus-delete-images 'smiley))))
-
-(defun smiley-mouse-toggle-buffer (event)
-  "Toggle displaying smiley faces.
+  (let (on off)
+    (map-extents
+     (lambda (e void)
+       (let (ant)
+        (if (annotationp (setq ant (extent-property e 'smiley-annotation)))
+            (if (eq (extent-property e 'invisible) nil)
+                (setq off (cons (cons ant e) off))
+              (setq on (cons (cons ant e) on)))))
+       nil)
+     buffer st nd)
+    (if (and (not (and (numberp arg) (< arg 0)))
+            (or (and (numberp arg) (> arg 0))
+                (null on)))
+       (if off
+           (while off
+             (reveal-annotation (caar off))
+             (set-extent-property (cdar off) 'invisible t)
+             (setq off (cdr off)))
+         (smiley-buffer))
+      (while on
+       (hide-annotation (caar on))
+       (set-extent-property (cdar on) 'invisible nil)
+       (setq on (cdr on))))))
+
+(defvar gnus-article-buffer)
+;;;###autoload
+(defun gnus-smiley-display (&optional arg)
+  "Display \"smileys\" as small graphical icons.
 With arg, turn displaying on if and only if arg is positive."
-  (interactive "e")
+  (interactive "P")
   (save-excursion
-    (save-window-excursion
-      (mouse-set-point event)
-      (smiley-toggle-buffer))))
+    (article-goto-body)
+    (let (buffer-read-only)
+      (smiley-toggle-buffer arg (current-buffer) (point) (point-max)))))
 
 (provide 'smiley)
 
+;; Local Variables:
+;; coding: iso-8859-1
+;; End:
+
 ;;; smiley.el ends here