;;; 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 <jas@pdc.kth.se>
(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)
: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
: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)
(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)
(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
(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
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)
(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
(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))
cmd done)
(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)
(process-connection-type nil)
process)
(when (progn
- (setq process (start-process
+ (setq process (start-process
name buffer shell-file-name
shell-command-switch
- (format-spec cmd
+ (format-spec cmd
(format-spec-make
?s server
?p (number-to-string port)))))
(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)
(when process
(while (and (memq (process-status process) '(open run))
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug
- (goto-char (point-min))
+ (goto-char (point-max))
+ (forward-line -1)
(not (imap-parse-greeting)))
(accept-process-output process 1)
(sit-for 1))
+ (imap-send-command "STARTTLS")
+ (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 (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)))
- (let ((imap-process process))
- (unwind-protect
- (progn
- (set-process-filter imap-process 'imap-arrival-filter)
- (when (and (eq imap-stream 'starttls)
- (imap-ok-p (imap-send-command-wait "STARTTLS")))
- (starttls-negotiate imap-process)))
- (set-process-filter imap-process nil)))
+ (message "imap: STARTTLS info: %s" (starttls-negotiate process))
(when (memq (process-status process) '(open run))
(setq done process)))
- (if done
- (progn
- (message "imap: Connecting with STARTTLS...done")
- done)
- (message "imap: Connecting with STARTTLS...failed")
- nil)))
+ (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
+ done))
;; Server functions; authenticator stuff:
"'): ")
(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) "'): "))))
(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)))))
+ ;; A process can die _before_ we have processed everything it
+ ;; has to say. Moreover, this can happen in between the call to
+ ;; accept-process-output and the call to process-status in an
+ ;; iteration of the loop above.
+ (when (and (null imap-continuation)
+ (< imap-reached-tag tag))
+ (accept-process-output imap-process 0 0))
(when imap-have-messaged
(message ""))
(and (memq (process-status imap-process) '(open run))
(defun imap-arrival-filter (proc string)
"IMAP process filter."
- (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)))
- (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))
- (goto-char (point-min))
- (unwind-protect
- (cond ((eq imap-state 'initial)
- (imap-parse-greeting))
- ((or (eq imap-state 'auth)
- (eq imap-state 'nonauth)
- (eq imap-state 'selected)
- (eq imap-state 'examine))
- (imap-parse-response))
- (t
- (message "Unknown state %s in arrival filter"
- imap-state)))
- (delete-region (point-min) (point-max))))))))
+ ;; Sometimes, we are called even though the process has died.
+ ;; Better abstain from doing stuff in that case.
+ (when (buffer-name (process-buffer proc))
+ (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)))
+ (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))
+ (goto-char (point-min))
+ (unwind-protect
+ (cond ((eq imap-state 'initial)
+ (imap-parse-greeting))
+ ((or (eq imap-state 'auth)
+ (eq imap-state 'nonauth)
+ (eq imap-state 'selected)
+ (eq imap-state 'examine))
+ (imap-parse-response))
+ (t
+ (message "Unknown state %s in arrival filter"
+ imap-state)))
+ (delete-region (point-min) (point-max)))))))))
\f
;; Imap parser.
(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
projects / gnus / blobdiff