comparison lisp/net/imap.el @ 100993:a16e9f7c2536

Merge from gnus--devo--0 Revision: [e-mail]/emacs--devo--0--patch-1513

100992:5cb6d276b93a

;;; imap.el --- imap library

;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.

;; Author: Simon Josefsson <[e-mail]>
;; Keywords: mail

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify

;; 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 a 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

;;
;; 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 support RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1), 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'), 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 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 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

;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <[e-mail]>^M\r...."
;;
;; Todo:
;;
;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow.
;; 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 <[e-mail]>
;;             NB! you need SLIM for starttls.el and digest-md5.el
;;  - 19991023 commited to pgnus
;;

;;; Code:

(eval-when-compile (require 'cl))

				"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 control 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 a IMAP server is
opened, changing it after that has no effect."
  :version "22.1"
  :group 'imap
  :type 'boolean)

(defcustom imap-use-utf7 t

encoded mailboxes which doesn't translate into ISO-8859-1."
  :group 'imap
  :type 'boolean)

(defcustom imap-log nil
  "If non-nil, a 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 *imap-log*
buffer.  It is not written to disk, however.  Do not enable this
variable unless you are comfortable with that."
  :group 'imap
  :type 'boolean)

(defcustom imap-debug nil
  "If non-nil, random debug spews are placed in *imap-debug* buffer.
Note that username, passwords and other privacy sensitive
information (such as e-mail) may be stored in the *imap-debug*
buffer.  It is not written to disk, however.  Do not enable this
variable unless you are comfortable with that."
  :group 'imap
  :type 'boolean)

(defcustom imap-shell-host "gateway"
  "Hostname of rlogin proxy."

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 promting."
  :group 'imap
  :type 'boolean)

;; Various variables.

(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

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 *.
Enabling this appears to be required for some servers (e.g.,
Microsoft Exchange) which otherwise would trigger a response 'BAD
The specified message set is invalid.'.")


;; Utility functions:

(defun imap-remassoc (key alist)
  "Delete by side effect any elements of LIST whose car is `equal' to KEY.
The modified LIST is returned.  If the first member
of LIST 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)

(defun imap-ssl-p (buffer)
  nil)

(defun imap-ssl-open (name buffer server port)
  "Open a 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)

	 (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))
		  (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)

      (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 a 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

	    imap-state 'auth)
      t)))

(defun imap-mailbox-expunge (&optional asynch buffer)
  "Expunge articles in current folder in BUFFER.
If ASYNCH, do not wait for succesful 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 succesful 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")

			      (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 -- ie '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)

	(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 -- ie '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)
			     "\" "

				      (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)

				     identifier
				     " "
				     rights))))))

(defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
  "Removes 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)

(defmacro imap-message-body (uid &optional buffer)
  `(with-current-buffer (or ,buffer (current-buffer))
     (imap-message-get ,uid 'BODY)))

(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)

;; `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-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
		  (if imap-enable-exchange-bug-workaround "*:*" "*") "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))

  (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 (a string message set) to MAILBOX on server in
BUFFER, creating mailbox if it doesn't exist.  If dont-create is
non-nil, it will not create a mailbox.  On success, return a list with
the UIDVALIDITY of the mailbox the article(s) was copied to as the
first element, rest of list contain 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))

			   (imap-mailbox-create-1 mailbox))
		  (imap-ok-p (imap-send-command-wait cmd)))))
	    (or no-copyuid
		(imap-message-copyuid-1 mailbox)))))))

(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
		  (if imap-enable-exchange-bug-workaround "*:*" "*") "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))

;;                       ; Authentication condition
;;
;;   resp-cond-bye   = "BYE" SP resp-text

(defun imap-parse-greeting ()
  "Parse a IMAP greeting."
  (cond ((looking-at "\\* OK ")
	 (setq imap-state 'nonauth))
	((looking-at "\\* PREAUTH ")
	 (setq imap-state 'auth))
	((looking-at "\\* BYE ")

;;                       ; 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")
    (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")
    (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

      (imap-forward)
      (if (eq (char-after) ?\()
	  (let (subbody)
	    (while (and (eq (char-after) ?\()
			(setq subbody (imap-parse-body)))
	     ;; buggy stalker communigate pro 3.0 insert 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-nstring) body) ;; body-fld-id
	(imap-forward)
	(push (imap-parse-nstring) body) ;; body-fld-desc
	(imap-forward)
	;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
	;; nstring and return nil instead of defaulting back to 7BIT
	;; as the standard says.
	(push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc
	(imap-forward)
	(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:

100993:a16e9f7c2536

;;; imap.el --- imap library

;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.

;; Author: Simon Josefsson <[e-mail]>
;; Keywords: mail

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify

;; 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

;;
;; 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

;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: <[e-mail]>^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 <[e-mail]>
;;             NB! you need SLIM for starttls.el and digest-md5.el
;;  - 19991023 committed to pgnus
;;

;;; Code:

(eval-when-compile (require 'cl))

				"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

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."

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-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

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.")


;; 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)

(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)

	 (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)

      (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

	    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")

			      (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)

	(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)
			     "\" "

				      (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)

				     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)

(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)

;; `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'."
  ;; We don't unconditionally use the alternative (valid) form, since
  ;; this is said to be significantly inefficient.  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.
  (condition-case data
      (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)
	      (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))

  (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))

			   (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))

;;                       ; 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 ")

;;                       ; 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

      (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-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: