X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fimap.el;h=a83cee19cce605149f5d38aa70b659c657bbe283;hb=c5f7362aa49943397fec729fdcfca40679946ec8;hp=4413fb57d9ba6eb2c75c7fcd68ac0a7661fc3a5c;hpb=ebdecdf203f300217a9a7f533dcf43fec5d427b4;p=elisp%2Fgnus.git- diff --git a/lisp/imap.el b/lisp/imap.el index 4413fb5..a83cee1 100644 --- a/lisp/imap.el +++ b/lisp/imap.el @@ -1,5 +1,5 @@ ;;; imap.el --- imap library -;; Copyright (C) 1998, 1999, 2000, 2001, 2002 +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Simon Josefsson @@ -138,7 +138,6 @@ (eval-when-compile (require 'cl)) (eval-and-compile - (autoload 'open-ssl-stream "ssl") (autoload 'base64-decode-string "base64") (autoload 'base64-encode-string "base64") (autoload 'starttls-open-stream "starttls") @@ -153,6 +152,7 @@ (autoload 'utf7-decode "utf7") (autoload 'format-spec "format-spec") (autoload 'format-spec-make "format-spec") + (autoload 'open-tls-stream "tls") ;; 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) @@ -179,7 +179,12 @@ the list is tried until a successful connection is made." :group 'imap :type '(repeat string)) -(defcustom imap-gssapi-program '("imtest -m gssapi -u %l -p %p %s") +(defcustom imap-gssapi-program (list + (concat "gsasl --client --connect %s:%p " + "--imap --application-data " + "--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 @@ -247,17 +252,28 @@ encoded mailboxes which doesn't translate into ISO-8859-1." :group 'imap :type 'string) +(defcustom imap-read-timeout (if (string-match + "windows-nt\\|os/2\\|emx\\|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) + ;; 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) @@ -300,6 +316,7 @@ for doing the actual authentication.") (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) @@ -417,22 +434,6 @@ sure of changing the value of `foo'." (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))) - (defsubst imap-utf7-encode (string) (if imap-use-utf7 (and string @@ -498,7 +499,7 @@ If ARGS, PROMPT is used as an argument to `format'." (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:") + (or (while (looking-at "^C:") (forward-line)) t) ;; cyrus 1.6 imtest print "S: " before server greeting @@ -541,6 +542,7 @@ If ARGS, PROMPT is used as an argument to `format'." 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) @@ -562,7 +564,7 @@ If ARGS, PROMPT is used as an argument to `format'." (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:") + (or (while (looking-at "^C:") (forward-line)) t) ;; cyrus 1.6 imtest print "S: " before server greeting @@ -572,7 +574,10 @@ If ARGS, PROMPT is used as an argument to `format'." (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)) @@ -601,24 +606,24 @@ If ARGS, PROMPT is used as an argument to `format'." (let ((cmds (if (listp imap-ssl-program) imap-ssl-program (list imap-ssl-program))) cmd done) - (condition-case () - (require 'ssl) - (error)) (while (and (not done) (setq cmd (pop cmds))) (message "imap: Opening SSL connection with `%s'..." cmd) + (erase-buffer) (let* ((port (or port imap-default-ssl-port)) (coding-system-for-read imap-coding-system-for-read) (coding-system-for-write imap-coding-system-for-write) - (ssl-program-name shell-file-name) - (ssl-program-arguments - (list shell-command-switch - (format-spec cmd (format-spec-make - ?s server - ?p (number-to-string port))))) + (process-connection-type nil) process) - (when (setq process (condition-case () - (open-ssl-stream name buffer server port) - (error))) + (when (progn + (setq process (start-process + name buffer shell-file-name + shell-command-switch + (format-spec cmd + (format-spec-make + ?s server + ?p (number-to-string port))))) + (process-kill-without-query process) + process) (with-current-buffer buffer (goto-char (point-min)) (while (and (memq (process-status process) '(open run)) @@ -644,6 +649,31 @@ If ARGS, PROMPT is used as an argument to `format'." (message "imap: Opening SSL connection with `%s'...failed" cmd) nil))) +(defun imap-tls-p (buffer) + nil) + +(defun imap-tls-open (name buffer server port) + (let* ((port (or port imap-default-tls-port)) + (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) + (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))) + (when (memq (process-status process) '(open run)) + process)))) + (defun imap-network-p (buffer) t) @@ -773,7 +803,7 @@ Returns t if login was successful, nil otherwise." "'): ") (or user imap-default-user)))) (setq passwd (or imap-password - (imap-read-passwd + (read-passwd (concat "IMAP password for " user "@" imap-server " (using authenticator `" (symbol-name imap-auth) "'): ")))) @@ -1304,7 +1334,7 @@ Returns non-nil if successful." 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 it's value is returned." +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 \"" @@ -1719,7 +1749,11 @@ on failure." (unless (< len 10) (setq imap-have-messaged t) (message "imap read: %dk" len)) - (accept-process-output imap-process 1))) + (accept-process-output imap-process + (truncate imap-read-timeout) + (truncate (* (- imap-read-timeout + (truncate imap-read-timeout)) + 1000))))) (when imap-have-messaged (message "")) (and (memq (process-status imap-process) '(open run)) @@ -2646,7 +2680,6 @@ Return nil if no complete line has arrived." (buffer-disable-undo (get-buffer-create imap-debug-buffer)) (mapcar (lambda (f) (trace-function-background f imap-debug-buffer)) '( - imap-read-passwd imap-utf7-encode imap-utf7-decode imap-error-text