;;; imap.el --- imap library
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
-;; Author: Simon Josefsson <jas@pdc.kth.se>
+;; 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
+;; 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, or (at your option)
-;; any later version.
+;; 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
+;; 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; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; 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.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
;; 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.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'), RFC2971 (ID). It also
+;; 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 short interactive session for demonstration
+;; 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 all without this, but it would
+;; `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.
;;
;; 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.
;; - 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 commited to pgnus
+;; - 19991023 committed to pgnus
;;
;;; Code:
(eval-when-compile (require 'cl))
(eval-and-compile
+ ;; For Emacs <22.2 and XEmacs.
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
(autoload 'starttls-open-stream "starttls")
(autoload 'starttls-negotiate "starttls")
(autoload 'sasl-find-mechanism "sasl")
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
+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
+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 a IMAP server is
-opened, changing it after that has no effect."
+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)
:type 'boolean)
(defcustom imap-log nil
- "If non-nil, a imap session trace is placed in *imap-log* buffer.
+ "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 *imap-log*
-buffer. It is not written to disk, however. Do not enable this
-variable unless you are comfortable with that."
+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, random debug spews are placed in *imap-debug* buffer.
+ "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 *imap-debug*
-buffer. It is not written to disk, however. Do not enable this
-variable unless you are comfortable with that."
+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)
:type 'string)
(defcustom imap-read-timeout (if (string-match
- "windows-nt\\|os/2\\|emx\\|cygwin"
+ "windows-nt\\|os/2\\|cygwin"
(symbol-name system-type))
1.0
0.1)
:group 'imap)
(defcustom imap-store-password nil
- "If non-nil, store session password without promting."
+ "If non-nil, store session password without prompting."
:group 'imap
:type 'boolean)
(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.
"Obarray with mailbox data.")
(defvar imap-mailbox-prime 997
- "Length of imap-mailbox-data.")
+ "Length of `imap-mailbox-data'.")
(defvar imap-current-message nil
"Current message number.")
"Obarray with message data.")
(defvar imap-message-prime 997
- "Length of imap-message-data.")
+ "Length of `imap-message-data'.")
(defvar imap-capability nil
"Capability for server.")
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 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
+ "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
(setcdr alist (imap-remassoc key (cdr alist)))
alist)))
-(defsubst imap-disable-multibyte ()
+(defmacro imap-disable-multibyte ()
"Enable multibyte in the current buffer."
- (when (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil)))
+ (unless (featurep 'xemacs)
+ '(set-buffer-multibyte nil)))
(defsubst imap-utf7-encode (string)
(if imap-use-utf7
\f
;; Server functions; stream stuff:
+(defun imap-log (string-or-buffer)
+ (when imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (if (bufferp string-or-buffer)
+ (insert-buffer-substring string-or-buffer)
+ (insert string-or-buffer)))))
+
(defun imap-kerberos4-stream-p (buffer)
(imap-capability 'AUTH=KERBEROS_V4 buffer))
(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"))
(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)))
+ (imap-log buffer)
(erase-buffer)
(message "GSSAPI IMAP connection: %s" (or response "failed"))
(if (and response (let ((case-fold-search nil))
nil)
(defun imap-ssl-open (name buffer server port)
- "Open a SSL connection to server."
+ "Open an SSL connection to SERVER."
(let ((cmds (if (listp imap-ssl-program) imap-ssl-program
(list imap-ssl-program)))
cmd done)
(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)))
+ (imap-log buffer)
(erase-buffer)
(when (memq (process-status process) '(open run))
(setq done process))))))
(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)))
+ (imap-log buffer)
(when (memq (process-status process) '(open run))
process))))
(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)))
+ (imap-log buffer)
(when (memq (process-status process) '(open run))
process))))
(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)))
+ (imap-log buffer)
(erase-buffer)
(when (memq (process-status process) '(open run))
(setq done process)))))
(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)))
+ (imap-log buffer)
(when (and (setq tls-info (starttls-negotiate process))
(memq (process-status process) '(open run)))
(setq done process)))
(while (or (not user) (not passwd))
(setq user (or imap-username
(read-from-minibuffer
- (concat "IMAP username for " imap-server
+ (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 "@"
+ (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 "Store password for this session? ")))
+ (y-or-n-p "imap: Store password for this IMAP session? ")))
(setq imap-password passwd)))
- (message "Login failed...")
+ (message "imap: Login failed...")
(setq passwd nil)
(setq imap-password nil)
(sit-for 1))))
(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)
imap-process))))
(defun imap-open (server &optional port stream auth buffer)
- "Open a IMAP connection to host SERVER at PORT returning a 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
(with-current-buffer (get-buffer-create buffer)
(if (imap-opened buffer)
(imap-close buffer))
- (mapcar 'make-local-variable imap-local-variables)
+ (mapc 'make-local-variable imap-local-variables)
(imap-disable-multibyte)
(buffer-disable-undo)
(setq imap-server (or server imap-server))
(if (not (eq imap-default-stream stream))
(with-current-buffer (get-buffer-create
(generate-new-buffer-name " *temp*"))
- (mapcar 'make-local-variable imap-local-variables)
+ (mapc 'make-local-variable imap-local-variables)
(imap-disable-multibyte)
(buffer-disable-undo)
(setq imap-server (or server imap-server))
buffer
(buffer-name buffer))))
(kill-buffer buffer)
- (rename-buffer name))
+ (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 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."
(buffer-live-p buffer)
(with-current-buffer buffer
(and imap-process
- (memq (process-status imap-process) '(open run))))))
+ (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.
(eq imap-state 'examine))
(make-local-variable 'imap-username)
(make-local-variable 'imap-password)
- (if user (setq imap-username user))
- (if passwd (setq imap-password passwd))
+ (make-local-variable 'imap-last-authenticator)
+ (when user (setq imap-username user))
+ (when passwd (setq imap-password passwd))
(if imap-auth
- (and (funcall (nth 2 (assq imap-auth
- imap-authenticator-alist)) buffer)
+ (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?
- (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer)
+ (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 (assq auth imap-authenticator-alist)) buffer)
+ (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)))))
(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 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)))
(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 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
(nreverse out)))))
(defun imap-mailbox-subscribe (mailbox &optional buffer)
- "Send the SUBSCRIBE command on the mailbox to server in 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 \""
"\"")))))
(defun imap-mailbox-unsubscribe (mailbox &optional buffer)
- "Send the SUBSCRIBE command on the mailbox to server in 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 "
(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
+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
(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
+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)
"\" "
- (format "%s"
- (if (listp items)
- items
- (list items)))))))
+ (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."
+ "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
rights))))))
(defun imap-mailbox-acl-delete (identifier &optional mailbox buffer)
- "Removes any <identifier,rights> pair for IDENTIFIER in MAILBOX from server in 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
propname)))
(defun imap-message-map (func propname &optional buffer)
- "Map a function across each mailbox in `imap-message-data', returning a list."
+ "Map a function across each message in `imap-message-data', returning a list."
(with-current-buffer (or buffer (current-buffer))
(let (result)
(mapatoms
`(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)
(imap-mailbox-get-1 'search imap-current-mailbox)))))
(defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
- "Return t iff FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in 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)))))
(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))
(imap-message-data (make-vector 2 0)))
(when (imap-mailbox-examine-1 mailbox)
(prog1
- (and (imap-fetch "*" "UID")
+ (and (imap-fetch-safe '("*" . "*:*") "UID")
(list (imap-mailbox-get-1 'uidvalidity mailbox)
(apply 'max (imap-message-map
(lambda (uid prop) uid) 'UID))))
(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
+ "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, rest of list contain the saved articles' UIDs."
+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)))
(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)
(imap-message-data (make-vector 2 0)))
(when (imap-mailbox-examine-1 mailbox)
(prog1
- (and (imap-fetch "*" "UID")
+ (and (imap-fetch-safe '("*" . "*:*") "UID")
(list (imap-mailbox-get-1 'uidvalidity mailbox)
(apply 'max (imap-message-map
(lambda (uid prop) uid) 'UID))))
(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)))
+ (imap-log cmdstr)
(process-send-string imap-process cmdstr))
(defun imap-send-command (command &optional buffer)
(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)))
+ (imap-log cmd)
(process-send-region process (point-min)
(point-max)))
(process-send-string process imap-client-eol))))
(imap-send-command-1 cmdstr)
(setq cmdstr nil)
(unwind-protect
- (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
- (setq command nil) ;; abort command if no cont-req
- (setq command (cons (funcall cmd imap-continuation)
- command)))
+ (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"))))
(while (and (null imap-continuation)
(memq (process-status imap-process) '(open run))
(< imap-reached-tag tag))
- (let ((len (/ (point-max) 1024))
+ (let ((len (/ (buffer-size) 1024))
message-log-max)
(unless (< len 10)
(setq imap-have-messaged t)
(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)))
+ (imap-log 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))
+ (delete-char (- (length imap-server-eol)))
(goto-char (point-min))
(unwind-protect
(cond ((eq imap-state 'initial)
;; resp-cond-bye = "BYE" SP resp-text
(defun imap-parse-greeting ()
- "Parse a IMAP greeting."
+ "Parse an IMAP greeting."
(cond ((looking-at "\\* OK ")
(setq imap-state 'nonauth))
((looking-at "\\* PREAUTH ")
(when (eq (char-after) ?\()
(let (uid flags envelope internaldate rfc822 rfc822header rfc822text
rfc822size body bodydetail bodystructure flags-empty)
- (while (not (eq (char-after) ?\)))
+ ;; 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)
(while (and (not (eq (char-after) ?\)))
(or (forward-char) t)
(looking-at "\\([A-Za-z]+\\) "))
- (let ((token (match-string 1)))
+ (let ((token (upcase (match-string 1))))
(goto-char (match-end 0))
(cond ((string= token "MESSAGES")
(imap-mailbox-put 'messages (read (current-buffer)) mailbox))
(defun imap-parse-flag-list ()
(let (flag-list start)
- (assert (eq (char-after) ?\() nil "In imap-parse-flag-list")
+ (assert (eq (char-after) ?\() nil "In imap-parse-flag-list 1")
(while (and (not (eq (char-after) ?\)))
(setq start (progn
(imap-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")
+ (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list 2")
(imap-forward)
(nreverse flag-list)))
(let (subbody)
(while (and (eq (char-after) ?\()
(setq subbody (imap-parse-body)))
- ;; buggy stalker communigate pro 3.0 insert a SPC between
+ ;; 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 (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
+ ;; 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)
- (push (imap-parse-number) body) ;; body-fld-octets
+ ;; 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:
+ ;; 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)...
+ ;; 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)
(when imap-debug ; (untrace-all)
(require 'trace)
(buffer-disable-undo (get-buffer-create imap-debug-buffer))
- (mapcar (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-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-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
- )))
+ (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
projects / gnus / blobdiff