X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fimap.el;h=f26590fda4aa0f41a660a7ae39589a316a521f78;hb=4cacb5f23eb830e6950dba987063f413977708d7;hp=c204a475eca55ad9f518cbc2f25462a60e79ae32;hpb=29afe7091b059510d5d606316720f175695055c8;p=elisp%2Fgnus.git- diff --git a/lisp/imap.el b/lisp/imap.el index c204a47..f26590f 100644 --- a/lisp/imap.el +++ b/lisp/imap.el @@ -1,6 +1,7 @@ ;;; imap.el --- imap library -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Keywords: mail @@ -19,8 +20,8 @@ ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -69,7 +70,7 @@ ;; 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. ;; @@ -145,12 +146,12 @@ (eval-and-compile (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") @@ -221,7 +222,8 @@ 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.." +opened, changing it after that has no effect." + :version "22.1" :group 'imap :type 'boolean) @@ -234,12 +236,20 @@ encoded mailboxes which doesn't translate into ISO-8859-1." :type 'boolean) (defcustom imap-log nil - "If non-nil, a imap session trace is placed in *imap-log* buffer." + "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." + "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) @@ -263,6 +273,11 @@ 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-fetch-data-hook nil @@ -291,6 +306,7 @@ stream.") kerberos4 digest-md5 cram-md5 + ;;sasl login anonymous) "Priority of authenticators to consider when authenticating to server.") @@ -298,6 +314,7 @@ stream.") (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) @@ -313,7 +330,7 @@ for doing the actual authentication.") (defvar imap-error nil "Error codes from the last command.") -;; Internal constants. Change theese and die. +;; Internal constants. Change these and die. (defconst imap-default-port 143) (defconst imap-default-ssl-port 993) @@ -618,7 +635,11 @@ sure of changing the value of `foo'." (message "imap: Opening SSL connection with `%s'..." cmd) (erase-buffer) (let ((port (or port imap-default-ssl-port)) - (process-connection-type nil) + (process-connection-type imap-process-connection-type) + (set-process-query-on-exit-flag + (if (fboundp 'set-process-query-on-exit-flag) + 'set-process-query-on-exit-flag + 'process-kill-without-query)) process) (when (prog1 (setq process (as-binary-process @@ -629,7 +650,7 @@ sure of changing the value of `foo'." (format-spec-make ?s server ?p (number-to-string port)))))) - (process-kill-without-query process)) + (funcall set-process-query-on-exit-flag process nil)) (with-current-buffer buffer (goto-char (point-min)) (while (and (memq (process-status process) '(open run)) @@ -812,9 +833,10 @@ Returns t if login was successful, nil otherwise." (progn (setq ret t imap-username user) - (if (and (not imap-password) - (y-or-n-p "Store password for this session? ")) - (setq imap-password passwd))) + (when (and (not imap-password) + (or imap-store-password + (y-or-n-p "Store password for this session? "))) + (setq imap-password passwd))) (message "Login failed...") (setq passwd nil) (setq imap-password nil) @@ -897,6 +919,66 @@ Returns t if login was successful, nil otherwise." (concat "LOGIN anonymous \"" (concat (user-login-name) "@" (system-name)) "\""))))) +;;; Compiler directives. + +(defvar imap-sasl-client) +(defvar imap-sasl-step) + +(defun imap-sasl-make-mechanisms (buffer) + (let ((mecs '())) + (mapc (lambda (sym) + (let ((name (symbol-name sym))) + (if (and (> (length name) 5) + (string-equal "AUTH=" (substring name 0 5 ))) + (setq mecs (cons (substring name 5) mecs))))) + (imap-capability nil buffer)) + mecs)) + +(defun imap-sasl-auth-p (buffer) + (and (condition-case () + (require 'sasl) + (error nil)) + (sasl-find-mechanism (imap-sasl-make-mechanisms buffer)))) + +(defun imap-sasl-auth (buffer) + "Login to server using the SASL method." + (message "imap: Authenticating using SASL...") + (with-current-buffer buffer + (make-local-variable 'imap-username) + (make-local-variable 'imap-sasl-client) + (make-local-variable 'imap-sasl-step) + (let ((mechanism (sasl-find-mechanism (imap-sasl-make-mechanisms buffer))) + logged user) + (while (not logged) + (setq user (or imap-username + (read-from-minibuffer + (concat "IMAP username for " imap-server " using SASL " + (sasl-mechanism-name mechanism) ": ") + (or user imap-default-user)))) + (when user + (setq imap-sasl-client (sasl-make-client mechanism user "imap2" imap-server) + imap-sasl-step (sasl-next-step imap-sasl-client nil)) + (let ((tag (imap-send-command + (if (sasl-step-data imap-sasl-step) + (format "AUTHENTICATE %s %s" + (sasl-mechanism-name mechanism) + (sasl-step-data imap-sasl-step)) + (format "AUTHENTICATE %s" (sasl-mechanism-name mechanism))) + buffer))) + (while (eq (imap-wait-for-tag tag) 'INCOMPLETE) + (sasl-step-set-data imap-sasl-step (base64-decode-string imap-continuation)) + (setq imap-continuation nil + imap-sasl-step (sasl-next-step imap-sasl-client imap-sasl-step)) + (imap-send-command-1 (if (sasl-step-data imap-sasl-step) + (base64-encode-string (sasl-step-data imap-sasl-step) t) + ""))) + (if (imap-ok-p (imap-wait-for-tag tag)) + (setq imap-username user + logged t) + (message "Login failed...") + (sit-for 1))))) + logged))) + (defun imap-digest-md5-p (buffer) (and (imap-capability 'AUTH=DIGEST-MD5 buffer) (condition-case () @@ -1044,7 +1126,7 @@ password is remembered in the buffer." (with-current-buffer (or buffer (current-buffer)) (if (not (eq imap-state 'nonauth)) (or (eq imap-state 'auth) - (eq imap-state 'select) + (eq imap-state 'selected) (eq imap-state 'examine)) (make-local-variable 'imap-username) (make-local-variable 'imap-password) @@ -1462,7 +1544,7 @@ or 'unseen. The IMAP command tag is returned." (defun imap-fetch (uids props &optional receive nouidfetch buffer) "Fetch properties PROPS from message set UIDS from server in BUFFER. UIDS can be a string, number or a list of numbers. If RECEIVE -is non-nil return theese properties." +is non-nil return these properties." (with-current-buffer (or buffer (current-buffer)) (when (imap-ok-p (imap-send-command-wait (format "%sFETCH %s %s" (if nouidfetch "" "UID ") @@ -1990,7 +2072,9 @@ Return nil if no complete line has arrived." (when (eq (char-after) ?\)) (imap-forward) (nreverse addresses))) - (assert (imap-parse-nil) t "In imap-parse-address-list"))) + ;; With assert, the code might not be eval'd. + ;; (assert (imap-parse-nil) t "In imap-parse-address-list") + (imap-parse-nil))) ;; mailbox = "INBOX" / astring ;; ; INBOX is case-insensitive. All case variants of @@ -2555,7 +2639,9 @@ Return nil if no complete line has arrived." (imap-forward) (push (imap-parse-string-list) dsp) (imap-forward)) - (assert (imap-parse-nil) t "In imap-parse-body-ext")) + ;; With assert, the code might not be eval'd. + ;; (assert (imap-parse-nil) t "In imap-parse-body-ext") + (imap-parse-nil)) (push (nreverse dsp) ext)) (when (eq (char-after) ?\ ) ;; body-fld-lang (imap-forward)