Commit b2108a36 authored by Ted Zlatanov's avatar Ted Zlatanov Committed by Katsumi Yamaoka
Browse files

net/imap.el: Bring it back.

parent 35f52ed6
......@@ -2,6 +2,11 @@
 
* makefile.w32-in (TRAMP_SRC): Remove tramp-imap.el.
 
2011-02-13 Teodor Zlatanov <tzz@lifelogs.com>
* net/imap.el: Bring it back (revert
84d800cd31de3064f0ed39617d725709a2f8f42f).
2011-02-13 Alan Mackenzie <acm@muc.de>
 
* progmodes/cc-fonts.el (c-font-lock-declarations): Remove a
......
;;; imap.el --- imap library
;; 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
;; 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
;; 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 '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\\|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.")
;; 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)))
(defmacro imap-disable-multibyte ()
"Enable multibyte in the current buffer."
(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
"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))))
;; 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))
(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))
(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))