;;; imap.el --- imap library
-;; Copyright (C) 1998, 1999, 2000
-;; Free Software Foundation, Inc.
-;; Author: Simon Josefsson <jas@pdc.kth.se>
+;; Copyright (C) 1998-2011 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
+;; 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 2, 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, 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
;;
;; Mailbox commands:
;;
-;; imap-mailbox-get, imap-mailbox-map, imap-current-mailbox,
+;; 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-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-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-append, imap-envelope-from
;; imap-body-lines
;;
-;; It is my hope that theese commands should be pretty self
+;; 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 (IMAP4/IMAP4rev1), implemented IMAP
-;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
+;; 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'). It also take advantage
-;; the UNSELECT extension in Cyrus IMAPD.
+;; 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.
;;
;; => "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 commited to pgnus
+;; - 19991023 committed to pgnus
;;
;;; Code:
(eval-when-compile (require 'cl))
(eval-and-compile
- (autoload 'open-ssl-stream "ssl")
- (autoload 'base64-decode-string "base64")
- (autoload 'base64-encode-string "base64")
+ ;; 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")
(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 'md5 "md5")
(autoload 'utf7-encode "utf7")
(autoload 'utf7-decode "utf7")
(autoload 'format-spec "format-spec")
(autoload 'format-spec-make "format-spec")
- ;; Avoid use gnus-point-at-eol so we're independent of Gnus. These
- ;; days we have point-at-eol anyhow.
- (if (fboundp 'point-at-eol)
- (defalias 'imap-point-at-eol 'point-at-eol)
- (defun imap-point-at-eol ()
- (save-excursion
- (end-of-line)
- (point)))))
+ (autoload 'open-tls-stream "tls"))
;; User variables.
:group 'imap
:type '(repeat string))
-(defcustom imap-gssapi-program '("imtest -m gssapi -u %l -p %p %s")
+(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
:group 'imap
:type '(repeat string))
-(defcustom imap-ssl-program '("openssl s_client -ssl3 -connect %s:%p"
- "openssl s_client -ssl2 -connect %s:%p"
- "s_client -ssl3 -connect %s:%p"
- "s_client -ssl2 -connect %s:%p")
+(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
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))
-(defvar imap-shell-host "gateway"
- "Hostname of rlogin proxy.")
+(defcustom imap-process-connection-type nil
+ "*Value for `process-connection-type' to use for Kerberos4, GSSAPI, shell, 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)
-(defvar imap-default-user (user-login-name)
- "Default username to use.")
+(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)
-(defvar imap-error nil
- "Error codes from the last command.")
+(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\\|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 ssl network shell)
+(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 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
+(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
+(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 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 actuall authentification.")
+for doing the actual authentication.")
-(defvar 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.")
+(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 theese and die.
+;; 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)
imap-current-target-mailbox
imap-message-data
imap-capability
+ imap-id
imap-namespace
imap-state
imap-reached-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-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
+(defvar imap-state 'closed
"IMAP state.
Valid states are `closed', `initial', `nonauth', `auth', `selected'
and `examine'.")
"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.")
+(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
+(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
(defvar imap-continuation nil
"Non-nil indicates that the server emitted a continuation request.
-The actually value is really the text on the continuation line.")
+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 *.
-(defvar imap-log nil
- "Name of buffer for imap session trace.
-For example: (setq imap-log \"*imap-log*\")")
+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.
-(defvar imap-debug nil ;"*imap-debug*"
- "Name of buffer for random debug spew.
-For example: (setq imap-debug \"*imap-debug*\")")
+This variable is set to t automatically per server if the
+canonical form fails.")
\f
;; Utility functions:
-(defsubst imap-disable-multibyte ()
+(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)))
+
+(defmacro imap-disable-multibyte ()
"Enable multibyte in the current buffer."
- (when (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil)))
-
-(defun imap-read-passwd (prompt &rest args)
- "Read a password using PROMPT.
-If ARGS, PROMPT is used as an argument to `format'."
- (let ((prompt (if args
- (apply 'format prompt args)
- prompt)))
- (funcall (if (or (fboundp 'read-passwd)
- (and (load "subr" t)
- (fboundp 'read-passwd))
- (and (load "passwd" t)
- (fboundp 'read-passwd)))
- 'read-passwd
- (autoload 'ange-ftp-read-passwd "ange-ftp")
- 'ange-ftp-read-passwd)
- prompt)))
+ (unless (featurep 'xemacs)
+ '(set-buffer-multibyte nil)))
(defsubst imap-utf7-encode (string)
(if imap-use-utf7
(and string
(condition-case ()
(utf7-encode string t)
- (error (message
+ (error (message
"imap: Could not UTF7 encode `%s', using it unencoded..."
string)
string)))
\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))
(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
+ (process-connection-type imap-process-connection-type)
+ (process (start-process
name buffer shell-file-name shell-command-switch
(format-spec
cmd
(while (and (memq (process-status process) '(open run))
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug
(goto-char (point-min))
- ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
- (or (while (looking-at "^C:")
+ ;; 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
(setq response (match-string 1)))))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log)
- (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"))
(not (string-match "failed" response))))
(setq done process)
(if (memq (process-status process) '(open run))
- (imap-send-command-wait "LOGOUT"))
+ (imap-logout))
(delete-process process)
nil)))))
done))
-
+
(defun imap-gssapi-stream-p (buffer)
(imap-capability 'AUTH=GSSAPI buffer))
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 (start-process
+ (process-connection-type imap-process-connection-type)
+ (process (start-process
name buffer shell-file-name shell-command-switch
(format-spec
cmd
(while (and (memq (process-status process) '(open run))
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug
(goto-char (point-min))
- ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
- (or (while (looking-at "^C:")
+ ;; 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
- "^\\(Authenticat.*\\)" nil t)
+ (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)
- (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))
(not (string-match "failed" response))))
(setq done process)
projects / gnus / blobdiff