X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fimap.el;h=7f77dfe624073198a42a7c28de42c3696dd75c35;hp=76f9956d6bcce4f27b1953b891ed8d30493a1246;hb=125d88b46ad2efa065f06d5dac37a245b488985a;hpb=bce4153cd878daae1e454bb1384b3d287795f64d diff --git a/lisp/imap.el b/lisp/imap.el index 76f9956d6..7f77dfe62 100644 --- a/lisp/imap.el +++ b/lisp/imap.el @@ -1,5 +1,5 @@ ;;; imap.el --- imap library -;; Copyright (C) 1998, 1999, 2000 +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004 ;; Free Software Foundation, Inc. ;; Author: Simon Josefsson @@ -44,7 +44,7 @@ ;; ;; 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 @@ -57,7 +57,7 @@ ;; 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 @@ -73,13 +73,13 @@ ;; 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 support RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1), 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'), RFC2971 (ID). It also +;; take advantage 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. @@ -120,11 +120,12 @@ ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: ^M\r...." ;; ;; Todo: -;; +;; ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow. ;; 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: ;; @@ -138,29 +139,19 @@ (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") (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. @@ -179,7 +170,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 @@ -215,75 +211,116 @@ until a successful connection is made." :type '(repeat string)) (defcustom imap-process-connection-type nil - "*Value for `process-connection-type' to use for Kerberos4 and GSSAPI." + "*Value for `process-connection-type' to use for Kerberos4, GSSAPI and SSL. +The `process-connection-type' variable control 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 a IMAP server is +opened, changing it after that has no effect.." + :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) -(defvar imap-shell-host "gateway" - "Hostname of rlogin proxy.") +(defcustom imap-log nil + "If non-nil, a imap session trace is placed in *imap-log* buffer." + :group 'imap + :type 'boolean) -(defvar imap-default-user (user-login-name) - "Default username to use.") +(defcustom imap-debug nil + "If non-nil, random debug spews are placed in *imap-debug* buffer." + :group 'imap + :type 'boolean) -(defvar imap-error nil - "Error codes from the last command.") +(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\\|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) + +(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 "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.") ;; Internal constants. Change theese 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) @@ -299,6 +336,7 @@ encoded mailboxes which doesn't translate into ISO-8859-1.") imap-current-target-mailbox imap-message-data imap-capability + imap-id imap-namespace imap-state imap-reached-tag @@ -307,6 +345,8 @@ encoded mailboxes which doesn't translate into ISO-8859-1.") imap-process imap-calculate-literal-size-first imap-mailbox-data)) +(defconst imap-log-buffer "*imap-log*") +(defconst imap-debug-buffer "*imap-debug*") ;; Internal variables. @@ -317,7 +357,7 @@ encoded mailboxes which doesn't translate into ISO-8859-1.") (defvar imap-username nil) (defvar imap-password 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'.") @@ -352,13 +392,17 @@ and `examine'.") (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 @@ -372,46 +416,39 @@ human readable response text (a string).") (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.") - -(defvar imap-log nil - "Name of buffer for imap session trace. -For example: (setq imap-log \"*imap-log*\")") +The actual value is really the text on the continuation line.") -(defvar imap-debug nil ;"*imap-debug*" - "Name of buffer for random debug spew. -For example: (setq imap-debug \"*imap-debug*\")") +(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.") ;; Utility functions: +(defun imap-remassoc (key alist) + "Delete by side effect any elements of LIST whose car is `equal' to KEY. +The modified LIST is returned. If the first member +of LIST 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))) + (defsubst 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))) - (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))) @@ -454,7 +491,7 @@ If ARGS, PROMPT is used as an argument to `format'." (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 + (process (start-process name buffer shell-file-name shell-command-switch (format-spec cmd @@ -470,8 +507,15 @@ If ARGS, PROMPT is used as an argument to `format'." (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 @@ -489,7 +533,7 @@ If ARGS, PROMPT is used as an argument to `format'." (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -501,11 +545,11 @@ If ARGS, PROMPT is used as an argument to `format'." (not (string-match "failed" response)))) (setq done process) (if (memq (process-status process) '(open run)) - (imap-send-command-wait "LOGOUT")) + (imap-send-command "LOGOUT")) (delete-process process) nil))))) done)) - + (defun imap-gssapi-stream-p (buffer) (imap-capability 'AUTH=GSSAPI buffer)) @@ -514,11 +558,12 @@ 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) (process-connection-type imap-process-connection-type) - (process (start-process + (process (start-process name buffer shell-file-name shell-command-switch (format-spec cmd @@ -534,8 +579,8 @@ If ARGS, PROMPT is used as an argument to `format'." (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:") + ;; 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 @@ -545,12 +590,15 @@ 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)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -561,7 +609,7 @@ If ARGS, PROMPT is used as an argument to `format'." (not (string-match "failed" response)))) (setq done process) (if (memq (process-status process) '(open run)) - (imap-send-command-wait "LOGOUT")) + (imap-send-command "LOGOUT")) (delete-process process) nil))))) done)) @@ -574,21 +622,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) - (ignore-errors (require 'ssl)) (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 (ignore-errors (open-ssl-stream - name buffer server port))) + (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)) @@ -599,7 +650,7 @@ If ARGS, PROMPT is used as an argument to `format'." (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -611,9 +662,34 @@ If ARGS, PROMPT is used as an argument to `format'." (progn (message "imap: Opening SSL connection with `%s'...done" cmd) done) - (message "imap: Opening SSL connection with `%s'...failed" cmd) + (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) @@ -630,7 +706,7 @@ If ARGS, PROMPT is used as an argument to `format'." (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -642,7 +718,8 @@ If ARGS, PROMPT is used as an argument to `format'." nil) (defun imap-shell-open (name buffer server port) - (let ((cmds imap-shell-program) + (let ((cmds (if (listp imap-shell-program) imap-shell-program + (list imap-shell-program))) cmd done) (while (and (not done) (setq cmd (pop cmds))) (message "imap: Opening IMAP connection with `%s'..." cmd) @@ -650,7 +727,7 @@ If ARGS, PROMPT is used as an argument to `format'." (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 (start-process name buffer shell-file-name shell-command-switch (format-spec cmd @@ -662,12 +739,13 @@ If ARGS, PROMPT is used as an argument to `format'." (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)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -679,84 +757,84 @@ If ARGS, PROMPT is used as an argument to `format'." (progn (message "imap: Opening IMAP connection with `%s'...done" cmd) done) - (message "imap: Opening IMAP connection with `%s'...failed" cmd) + (message "imap: Opening IMAP connection with `%s'...failed" cmd) nil))) (defun imap-starttls-p (buffer) - (and (imap-capability 'STARTTLS buffer) - (condition-case () - (progn - (require 'starttls) - (call-process "starttls")) - (error nil)))) + (imap-capability 'STARTTLS buffer)) (defun imap-starttls-open (name buffer server port) (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 (starttls-open-stream name buffer server port)) - done) + done tls-info) (message "imap: Connecting with STARTTLS...") (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) + (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))) - (when (memq (process-status process) '(open run)) + (when (and (setq tls-info (starttls-negotiate process)) + (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))) - + (if (stringp tls-info) + (message "imap: STARTTLS info: %s" tls-info)) + (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed")) + done)) + ;; Server functions; authenticator stuff: (defun imap-interactive-login (buffer loginfunc) "Login to server in BUFFER. LOGINFUNC is passed a username and a password, it should return t if -it where sucessful authenticating itself to the server, nil otherwise. +it where successful authenticating itself to the server, nil otherwise. Returns t if login was successful, nil otherwise." (with-current-buffer buffer - (make-variable-buffer-local 'imap-username) - (make-variable-buffer-local 'imap-password) + (make-local-variable 'imap-username) + (make-local-variable 'imap-password) (let (user passwd ret) ;; (condition-case () (while (or (not user) (not passwd)) (setq user (or imap-username - (read-from-minibuffer - (concat "IMAP username for " imap-server ": ") + (read-from-minibuffer + (concat "IMAP username for " imap-server + " (using stream `" (symbol-name imap-stream) + "'): ") (or user imap-default-user)))) (setq passwd (or imap-password - (imap-read-passwd - (concat "IMAP password for " user "@" - imap-server ": ")))) + (read-passwd + (concat "IMAP password for " user "@" + imap-server " (using authenticator `" + (symbol-name imap-auth) "'): ")))) (when (and user passwd) (if (funcall loginfunc user passwd) (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) (sit-for 1)))) ;; (quit (with-current-buffer buffer ;; (setq user nil @@ -767,7 +845,7 @@ Returns t if login was successful, nil otherwise." ret))) (defun imap-gssapi-auth-p (buffer) - (imap-capability 'AUTH=GSSAPI buffer)) + (eq imap-stream 'gssapi)) (defun imap-gssapi-auth (buffer) (message "imap: Authenticating using GSSAPI...%s" @@ -775,7 +853,8 @@ Returns t if login was successful, nil otherwise." (eq imap-stream 'gssapi)) (defun imap-kerberos4-auth-p (buffer) - (imap-capability 'AUTH=KERBEROS_V4 buffer)) + (and (imap-capability 'AUTH=KERBEROS_V4 buffer) + (eq imap-stream 'kerberos4))) (defun imap-kerberos4-auth (buffer) (message "imap: Authenticating using Kerberos 4...%s" @@ -812,22 +891,82 @@ Returns t if login was successful, nil otherwise." (defun imap-login-auth (buffer) "Login to server using the LOGIN command." (message "imap: Plaintext authentication...") - (imap-interactive-login buffer + (imap-interactive-login buffer (lambda (user passwd) - (imap-ok-p (imap-send-command-wait - (concat "LOGIN \"" user "\" \"" + (imap-ok-p (imap-send-command-wait + (concat "LOGIN \"" user "\" \"" passwd "\"")))))) (defun imap-anonymous-p (buffer) t) (defun imap-anonymous-auth (buffer) - (message "imap: Loging in anonymously...") + (message "imap: Logging in anonymously...") (with-current-buffer buffer (imap-ok-p (imap-send-command-wait - (concat "LOGIN anonymous \"" (concat (user-login-name) "@" + (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 () @@ -840,7 +979,7 @@ Returns t if login was successful, nil otherwise." (imap-interactive-login buffer (lambda (user passwd) - (let ((tag + (let ((tag (imap-send-command (list "AUTHENTICATE DIGEST-MD5" @@ -848,10 +987,10 @@ Returns t if login was successful, nil otherwise." (digest-md5-parse-digest-challenge (base64-decode-string challenge)) (let* ((digest-uri - (digest-md5-digest-uri + (digest-md5-digest-uri "imap" (digest-md5-challenge 'realm))) (response - (digest-md5-digest-response + (digest-md5-digest-response user passwd digest-uri))) (base64-encode-string response 'no-line-break)))) ))) @@ -870,7 +1009,7 @@ Returns t if login was successful, nil otherwise." imap-current-message nil imap-state 'initial imap-process (condition-case () - (funcall (nth 2 (assq imap-stream + (funcall (nth 2 (assq imap-stream imap-stream-alist)) "imap" buffer imap-server imap-port) ((error quit) nil))) @@ -895,12 +1034,12 @@ AUTH indicates authenticator to use, see `imap-authenticators' for available authenticators. If nil, it choices the best stream the server is capable of. BUFFER can be a buffer or a name of a buffer, which is created if -necessery. If nil, the buffer name is generated." +necessary. If nil, the buffer name is generated." (setq buffer (or buffer (format " *imap* %s:%d" server (or port 0)))) (with-current-buffer (get-buffer-create buffer) (if (imap-opened buffer) (imap-close buffer)) - (mapcar 'make-variable-buffer-local imap-local-variables) + (mapcar 'make-local-variable imap-local-variables) (imap-disable-multibyte) (buffer-disable-undo) (setq imap-server (or server imap-server)) @@ -908,46 +1047,53 @@ necessery. If nil, the buffer name is generated." (setq imap-auth (or auth imap-auth)) (setq imap-stream (or stream imap-stream)) (message "imap: Connecting to %s..." imap-server) - (if (let ((imap-stream (or imap-stream imap-default-stream))) - (imap-open-1 buffer)) - ;; Choose stream. - (let (stream-changed) - (message "imap: Connecting to %s...done" imap-server) - (when (null imap-stream) - (let ((streams imap-streams)) - (while (setq stream (pop streams)) - (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer) - (setq stream-changed (not (eq (or imap-stream - imap-default-stream) - stream)) - imap-stream stream - streams nil))) - (unless imap-stream - (error "Couldn't figure out a stream for server")))) - (when stream-changed - (message "imap: Reconnecting with stream `%s'..." imap-stream) - (imap-close buffer) - (if (imap-open-1 buffer) - (message "imap: Reconnecting with stream `%s'...done" - imap-stream) - (message "imap: Reconnecting with stream `%s'...failed" - imap-stream)) - (setq imap-capability nil)) - (if (imap-opened buffer) - ;; Choose authenticator - (when (and (null imap-auth) (not (eq imap-state 'auth))) - (let ((auths imap-authenticators)) - (while (setq auth (pop auths)) - (if (funcall (nth 1 (assq auth imap-authenticator-alist)) - buffer) - (setq imap-auth auth - auths nil))) - (unless imap-auth - (error "Couldn't figure out authenticator for server")))))) - (message "imap: Connecting to %s...failed" imap-server)) - (when (imap-opened buffer) - (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)) - buffer))) + (if (null (let ((imap-stream (or imap-stream imap-default-stream))) + (imap-open-1 buffer))) + (progn + (message "imap: Connecting to %s...failed" imap-server) + nil) + (when (null imap-stream) + ;; Need to choose stream. + (let ((streams imap-streams)) + (while (setq stream (pop streams)) + ;; OK to use this stream? + (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer) + ;; Stream changed? + (if (not (eq imap-default-stream stream)) + (with-current-buffer (get-buffer-create + (generate-new-buffer-name " *temp*")) + (mapcar 'make-local-variable imap-local-variables) + (imap-disable-multibyte) + (buffer-disable-undo) + (setq imap-server (or server imap-server)) + (setq imap-port (or port imap-port)) + (setq imap-auth (or auth imap-auth)) + (message "imap: Reconnecting with stream `%s'..." stream) + (if (null (let ((imap-stream stream)) + (imap-open-1 (current-buffer)))) + (progn + (kill-buffer (current-buffer)) + (message + "imap: Reconnecting with stream `%s'...failed" + stream)) + ;; We're done, kill the first connection + (imap-close buffer) + (kill-buffer buffer) + (rename-buffer buffer) + (message "imap: Reconnecting with stream `%s'...done" + stream) + (setq imap-stream stream) + (setq imap-capability nil) + (setq streams nil))) + ;; We're done + (message "imap: Connecting to %s...done" imap-server) + (setq imap-stream stream) + (setq imap-capability nil) + (setq streams nil)))))) + (when (imap-opened buffer) + (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))) + (when imap-stream + buffer)))) (defun imap-opened (&optional buffer) "Return non-nil if connection to imap server in BUFFER is open. @@ -970,20 +1116,40 @@ password is remembered in the buffer." (or (eq imap-state 'auth) (eq imap-state 'select) (eq imap-state 'examine)) - (make-variable-buffer-local 'imap-username) - (make-variable-buffer-local 'imap-password) + (make-local-variable 'imap-username) + (make-local-variable 'imap-password) (if user (setq imap-username user)) (if passwd (setq imap-password passwd)) - (if (funcall (nth 2 (assq imap-auth imap-authenticator-alist)) buffer) - (setq imap-state 'auth))))) + (if imap-auth + (and (funcall (nth 2 (assq imap-auth + imap-authenticator-alist)) buffer) + (setq imap-state 'auth)) + ;; Choose authenticator. + (let ((auths imap-authenticators) + auth) + (while (setq auth (pop auths)) + ;; OK to use authenticator? + (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer) + (message "imap: Authenticating to `%s' using `%s'..." + imap-server auth) + (setq imap-auth auth) + (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer) + (progn + (message "imap: Authenticating to `%s' using `%s'...done" + imap-server auth) + (setq auths nil)) + (message "imap: Authenticating to `%s' using `%s'...failed" + imap-server auth))))) + imap-state)))) (defun imap-close (&optional buffer) "Close connection to server in BUFFER. If BUFFER is nil, the current buffer is used." (with-current-buffer (or buffer (current-buffer)) - (and (imap-opened) - (not (imap-ok-p (imap-send-command-wait "LOGOUT"))) - (message "Server %s didn't let me log out" imap-server)) + (when (imap-opened) + (condition-case nil + (imap-send-command-wait "LOGOUT") + (quit nil))) (when (and imap-process (memq (process-status imap-process) '(open run))) (delete-process imap-process)) @@ -1005,6 +1171,26 @@ If BUFFER is nil, the current buffer is assumed." (memq (intern (upcase (symbol-name identifier))) imap-capability) imap-capability))) +(defun imap-id (&optional list-of-values buffer) + "Identify client to server in BUFFER, and return server identity. +LIST-OF-VALUES is nil, or a plist with identifier and value +strings to send to the server to identify the client. + +Return a list of identifiers which server in BUFFER support, or +nil if it doesn't support ID or returns no information. + +If BUFFER is nil, the current buffer is assumed." + (with-current-buffer (or buffer (current-buffer)) + (when (and (imap-capability 'ID) + (imap-ok-p (imap-send-command-wait + (if (null list-of-values) + "ID NIL" + (concat "ID (" (mapconcat (lambda (el) + (concat "\"" el "\"")) + list-of-values + " ") ")"))))) + imap-id))) + (defun imap-namespace (&optional buffer) "Return a namespace hierarchy at server in BUFFER. If BUFFER is nil, the current buffer is assumed." @@ -1041,7 +1227,7 @@ If BUFFER is nil, the current buffer is assumed." (defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer) (with-current-buffer (or buffer (current-buffer)) (let (result) - (mapatoms + (mapatoms (lambda (s) (push (funcall func (if mailbox-decoder (funcall mailbox-decoder (symbol-name s)) @@ -1077,7 +1263,7 @@ If EXAMINE is non-nil, do a read-only select." imap-current-mailbox (setq imap-current-mailbox mailbox) (if (imap-ok-p (imap-send-command-wait - (concat (if examine "EXAMINE" "SELECT") " \"" + (concat (if examine "EXAMINE" "SELECT") " \"" mailbox "\""))) (progn (setq imap-message-data (make-vector imap-message-prime 0) @@ -1086,18 +1272,18 @@ If EXAMINE is non-nil, do a read-only select." ;; Failed SELECT/EXAMINE unselects current mailbox (setq imap-current-mailbox nil)))) -(defun imap-mailbox-select (mailbox &optional examine buffer) +(defun imap-mailbox-select (mailbox &optional examine buffer) (with-current-buffer (or buffer (current-buffer)) - (imap-utf7-decode + (imap-utf7-decode (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine)))) (defun imap-mailbox-examine-1 (mailbox &optional buffer) (with-current-buffer (or buffer (current-buffer)) - (imap-mailbox-select-1 mailbox 'exmine))) + (imap-mailbox-select-1 mailbox 'examine))) (defun imap-mailbox-examine (mailbox &optional buffer) "Examine MAILBOX on server in BUFFER." - (imap-mailbox-select mailbox 'exmine buffer)) + (imap-mailbox-select mailbox 'examine buffer)) (defun imap-mailbox-unselect (&optional buffer) "Close current folder in BUFFER, without expunging articles." @@ -1105,7 +1291,7 @@ If EXAMINE is non-nil, do a read-only select." (when (or (eq imap-state 'auth) (and (imap-capability 'UNSELECT) (imap-ok-p (imap-send-command-wait "UNSELECT"))) - (and (imap-ok-p + (and (imap-ok-p (imap-send-command-wait (concat "EXAMINE \"" imap-current-mailbox "\""))) @@ -1115,22 +1301,38 @@ If EXAMINE is non-nil, do a read-only select." imap-state 'auth) t))) -(defun imap-mailbox-expunge (&optional buffer) +(defun imap-mailbox-expunge (&optional asynch buffer) "Expunge articles in current folder in BUFFER. +If ASYNCH, do not wait for succesful completion of the command. If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (when (and imap-current-mailbox (not (eq imap-state 'examine))) - (imap-ok-p (imap-send-command-wait "EXPUNGE"))))) + (if asynch + (imap-send-command "EXPUNGE") + (imap-ok-p (imap-send-command-wait "EXPUNGE")))))) -(defun imap-mailbox-close (&optional buffer) +(defun imap-mailbox-close (&optional asynch buffer) "Expunge articles and close current folder in BUFFER. +If ASYNCH, do not wait for succesful completion of the command. If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) - (when (and imap-current-mailbox - (imap-ok-p (imap-send-command-wait "CLOSE"))) - (setq imap-current-mailbox nil - imap-message-data nil - imap-state 'auth) + (when imap-current-mailbox + (if asynch + (imap-add-callback (imap-send-command "CLOSE") + `(lambda (tag status) + (message "IMAP mailbox `%s' closed... %s" + imap-current-mailbox status) + (when (eq ,imap-current-mailbox + imap-current-mailbox) + ;; Don't wipe out data if another mailbox + ;; was selected... + (setq imap-current-mailbox nil + imap-message-data nil + imap-state 'auth)))) + (when (imap-ok-p (imap-send-command-wait "CLOSE")) + (setq imap-current-mailbox nil + imap-message-data nil + imap-state 'auth))) t))) (defun imap-mailbox-create-1 (mailbox) @@ -1160,7 +1362,7 @@ If BUFFER is nil the current buffer is assumed." (imap-send-command-wait (list "RENAME \"" oldname "\" " "\"" newname "\"")))))) -(defun imap-mailbox-lsub (&optional root reference add-delimiter buffer) +(defun imap-mailbox-lsub (&optional root reference add-delimiter buffer) "Return a list of subscribed mailboxes on server in BUFFER. If ROOT is non-nil, only list matching mailboxes. If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to root. REFERENCE is a @@ -1174,7 +1376,7 @@ implementation-specific string that has to be passed to lsub command." (imap-mailbox-map-1 (lambda (mailbox) (imap-mailbox-put 'lsub nil mailbox))) (when (imap-ok-p - (imap-send-command-wait + (imap-send-command-wait (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root) (and add-delimiter (imap-mailbox-get-1 'delimiter root)) "%\""))) @@ -1198,7 +1400,7 @@ passed to list command." (imap-mailbox-map-1 (lambda (mailbox) (imap-mailbox-put 'list nil mailbox))) (when (imap-ok-p - (imap-send-command-wait + (imap-send-command-wait (concat "LIST \"" reference "\" \"" (imap-utf7-encode root) (and add-delimiter (imap-mailbox-get-1 'delimiter root)) "%\""))) @@ -1212,7 +1414,7 @@ passed to list command." "Send the SUBSCRIBE command on the mailbox to server in BUFFER. Returns non-nil if successful." (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \"" + (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \"" (imap-utf7-encode mailbox) "\""))))) @@ -1220,7 +1422,7 @@ Returns non-nil if successful." "Send the SUBSCRIBE command on the mailbox to server in BUFFER. Returns non-nil if successful." (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE " + (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE " (imap-utf7-encode mailbox) "\""))))) @@ -1229,22 +1431,37 @@ 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 + (when (imap-ok-p (imap-send-command-wait (list "STATUS \"" (imap-utf7-encode mailbox) "\" " - (format "%s" - (if (listp items) - items - (list items)))))) + (upcase + (format "%s" + (if (listp items) + items + (list items))))))) (if (listp items) (mapcar (lambda (item) (imap-mailbox-get item mailbox)) items) (imap-mailbox-get items mailbox))))) +(defun imap-mailbox-status-asynch (mailbox items &optional buffer) + "Send status item request ITEM on MAILBOX to server in BUFFER. +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. The IMAP command tag is returned." + (with-current-buffer (or buffer (current-buffer)) + (imap-send-command (list "STATUS \"" + (imap-utf7-encode mailbox) + "\" " + (format "%s" + (if (listp items) + items + (list items))))))) + (defun imap-mailbox-acl-get (&optional mailbox buffer) "Get ACL on mailbox from server in BUFFER." (let ((mailbox (imap-utf7-encode mailbox))) @@ -1296,8 +1513,8 @@ returned, if ITEMS is a symbol only it's value is returned." (mapconcat (lambda (item) (if (consp item) - (format "%d:%d" - (car item) (cdr item)) + (format "%d:%d" + (car item) (cdr item)) (format "%d" item))) (if (and (listp range) (not (listp (cdr range)))) (list range) ;; make (1 . 2) into ((1 . 2)) @@ -1317,7 +1534,7 @@ returned, if ITEMS is a symbol only it's value is returned." UIDS can be a string, number or a list of numbers. If RECEIVE is non-nil return theese properties." (with-current-buffer (or buffer (current-buffer)) - (when (imap-ok-p (imap-send-command-wait + (when (imap-ok-p (imap-send-command-wait (format "%sFETCH %s %s" (if nouidfetch "" "UID ") (if (listp uids) (imap-list-to-message-set uids) @@ -1334,7 +1551,7 @@ is non-nil return theese properties." (imap-message-get uid receive))) uids) (imap-message-get uids receive)))))) - + (defun imap-message-put (uid propname value &optional buffer) (with-current-buffer (or buffer (current-buffer)) (if imap-message-data @@ -1408,7 +1625,9 @@ is non-nil return theese properties." (imap-mailbox-put 'search 'dummy) (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate))) (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy) - (error "Missing SEARCH response to a SEARCH command") + (progn + (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...") + nil) (imap-mailbox-get-1 'search imap-current-mailbox))))) (defun imap-message-flag-permanent-p (flag &optional mailbox buffer) @@ -1482,7 +1701,7 @@ first element, rest of list contain the saved articles' UIDs." (imap-ok-p (imap-send-command-wait cmd))))) (or no-copyuid (imap-message-copyuid-1 mailbox))))))) - + (defun imap-message-appenduid-1 (mailbox) (if (imap-capability 'UIDPLUS) (imap-mailbox-get-1 'appenduid mailbox) @@ -1511,11 +1730,11 @@ on failure." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (and (let ((imap-current-target-mailbox mailbox)) - (imap-ok-p - (imap-send-command-wait + (imap-ok-p + (imap-send-command-wait (list "APPEND \"" mailbox "\" " article)))) (imap-message-appenduid-1 mailbox))))) - + (defun imap-body-lines (body) "Return number of lines in article by looking at the mime bodystructure BODY." (if (listp body) @@ -1535,18 +1754,21 @@ on failure." (and from (concat (aref from 0) (if (aref from 0) " <") - (aref from 2) - "@" + (aref from 2) + "@" (aref from 3) (if (aref from 0) ">")))) ;; Internal functions. +(defun imap-add-callback (tag func) + (setq imap-callbacks (append (list (cons tag func)) imap-callbacks))) + (defun imap-send-command-1 (cmdstr) (setq cmdstr (concat cmdstr imap-client-eol)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -1576,21 +1798,21 @@ on failure." (replace-match eol))) (if (not calcfirst) (setq size (buffer-size)))) - (setq cmdstr + (setq cmdstr (concat cmdstr (format "{%d}" size)))) (unwind-protect (progn (imap-send-command-1 cmdstr) (setq cmdstr nil) (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - (setq command nil);; abort command if no cont-req + (setq command nil) ;; abort command if no cont-req (let ((process imap-process) (stream imap-stream) (eol imap-client-eol)) (with-current-buffer cmd (and imap-log (with-current-buffer (get-buffer-create - imap-log) + imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -1604,7 +1826,7 @@ on failure." (setq cmdstr nil) (unwind-protect (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - (setq command nil);; abort command if no cont-req + (setq command nil) ;; abort command if no cont-req (setq command (cons (funcall cmd imap-continuation) command))) (setq imap-continuation nil))) @@ -1616,20 +1838,34 @@ on failure." (defun imap-wait-for-tag (tag &optional buffer) (with-current-buffer (or buffer (current-buffer)) - (while (and (null imap-continuation) - (< imap-reached-tag tag)) - (or (and (not (memq (process-status imap-process) '(open run))) - (sit-for 1)) - (let ((len (/ (point-max) 1024)) - message-log-max) - (unless (< len 10) - (message "imap read: %dk" len)) - (accept-process-output imap-process 1)))) - (message "") - (or (assq tag imap-failed-tags) - (if imap-continuation - 'INCOMPLETE - 'OK)))) + (let (imap-have-messaged) + (while (and (null imap-continuation) + (memq (process-status imap-process) '(open run)) + (< imap-reached-tag tag)) + (let ((len (/ (point-max) 1024)) + message-log-max) + (unless (< len 10) + (setq imap-have-messaged t) + (message "imap read: %dk" len)) + (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)) + (or (assq tag imap-failed-tags) + (if imap-continuation + 'INCOMPLETE + 'OK)))))) (defun imap-sentinel (process string) (delete-process process)) @@ -1649,34 +1885,37 @@ Return nil if no complete line has arrived." (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) - (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))))))))) ;; Imap parser. @@ -1761,7 +2000,7 @@ Return nil if no complete line has arrived." (defsubst imap-parse-astring () (or (imap-parse-string) - (buffer-substring (point) + (buffer-substring (point) (if (re-search-forward "[(){ \r\n%*\"\\]" nil t) (goto-char (1- (match-end 0))) (end-of-line) @@ -1772,21 +2011,21 @@ Return nil if no complete line has arrived." ;; ;; addr-adl = nstring ;; ; Holds route from [RFC-822] route-addr if -;; ; non-NIL +;; ; non-nil ;; ;; addr-host = nstring -;; ; NIL indicates [RFC-822] group syntax. +;; ; nil indicates [RFC-822] group syntax. ;; ; Otherwise, holds [RFC-822] domain name ;; ;; addr-mailbox = nstring -;; ; NIL indicates end of [RFC-822] group; if -;; ; non-NIL and addr-host is NIL, holds +;; ; nil indicates end of [RFC-822] group; if +;; ; non-nil and addr-host is nil, holds ;; ; [RFC-822] group name. ;; ; Otherwise, holds [RFC-822] local-part ;; ; after removing [RFC-822] quoting ;; ;; addr-name = nstring -;; ; If non-NIL, holds phrase from [RFC-822] +;; ; If non-nil, holds phrase from [RFC-822] ;; ; mailbox after removing [RFC-822] quoting ;; @@ -1821,7 +2060,7 @@ Return nil if no complete line has arrived." (when (eq (char-after) ?\)) (imap-forward) (nreverse addresses))) - (assert (imap-parse-nil)))) + (assert (imap-parse-nil) t "In imap-parse-address-list"))) ;; mailbox = "INBOX" / astring ;; ; INBOX is case-insensitive. All case variants of @@ -1874,7 +2113,7 @@ Return nil if no complete line has arrived." ;; resp-cond-bye = "BYE" SP resp-text ;; ;; mailbox-data = "FLAGS" SP flag-list / -;; "LIST" SP mailbox-list / +;; "LIST" SP mailbox-list / ;; "LSUB" SP mailbox-list / ;; "SEARCH" *(SP nz-number) / ;; "STATUS" SP mailbox SP "(" @@ -1907,14 +2146,16 @@ Return nil if no complete line has arrived." (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) (LIST (imap-parse-data-list 'list)) (LSUB (imap-parse-data-list 'lsub)) - (SEARCH (imap-mailbox-put - 'search + (SEARCH (imap-mailbox-put + 'search (read (concat "(" (buffer-substring (point) (point-max)) ")")))) (STATUS (imap-parse-status)) - (CAPABILITY (setq imap-capability - (read (concat "(" (upcase (buffer-substring - (point) (point-max))) - ")")))) + (CAPABILITY (setq imap-capability + (read (concat "(" (upcase (buffer-substring + (point) (point-max))) + ")")))) + (ID (setq imap-id (read (buffer-substring (point) + (point-max))))) (ACL (imap-parse-acl)) (t (case (prog1 (read (current-buffer)) (imap-forward)) @@ -1941,7 +2182,7 @@ Return nil if no complete line has arrived." (search-forward "]"))) (imap-forward)) (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) + (push (list token status code text) imap-failed-tags)))) (BAD (progn (setq imap-reached-tag (max imap-reached-tag token)) @@ -1956,7 +2197,11 @@ Return nil if no complete line has arrived." (push (list token status code text) imap-failed-tags) (error "Internal error, tag %s status %s code %s text %s" token status code text)))) - (t (message "Garbage: %s" (buffer-string)))))))))) + (t (message "Garbage: %s" (buffer-string)))) + (when (assq token imap-callbacks) + (funcall (cdr (assq token imap-callbacks)) token status) + (setq imap-callbacks + (imap-remassoc token imap-callbacks))))))))) ;; resp-text = ["[" resp-text-code "]" SP] text ;; @@ -1969,14 +2214,14 @@ Return nil if no complete line has arrived." ;; resp-text-code = "ALERT" / ;; "BADCHARSET [SP "(" astring *(SP astring) ")" ] / -;; "NEWNAME" SP string SP string / +;; "NEWNAME" SP string SP string / ;; "PARSE" / -;; "PERMANENTFLAGS" SP "(" +;; "PERMANENTFLAGS" SP "(" ;; [flag-perm *(SP flag-perm)] ")" / -;; "READ-ONLY" / -;; "READ-WRITE" / -;; "TRYCREATE" / -;; "UIDNEXT" SP nz-number / +;; "READ-ONLY" / +;; "READ-WRITE" / +;; "TRYCREATE" / +;; "UIDNEXT" SP nz-number / ;; "UIDVALIDITY" SP nz-number / ;; "UNSEEN" SP nz-number / ;; resp-text-atom [SP 1*] @@ -1995,7 +2240,7 @@ Return nil if no complete line has arrived." ;; ; delimits between two numbers inclusive. ;; ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13, ;; ; 14,15 for a mailbox with 15 messages. -;; +;; ;; sequence-num = nz-number / "*" ;; ; * is the largest number in use. For message ;; ; sequence numbers, it is the number of messages @@ -2029,10 +2274,10 @@ Return nil if no complete line has arrived." (imap-forward) (cond ((search-forward "PERMANENTFLAGS " nil t) (imap-mailbox-put 'permanentflags (imap-parse-flag-list))) - ((search-forward "UIDNEXT " nil t) - (imap-mailbox-put 'uidnext (read (current-buffer)))) + ((search-forward "UIDNEXT \\([0-9]+\\)" nil t) + (imap-mailbox-put 'uidnext (match-string 1))) ((search-forward "UNSEEN " nil t) - (imap-mailbox-put 'unseen (read (current-buffer)))) + (imap-mailbox-put 'first-unseen (read (current-buffer)))) ((looking-at "UIDVALIDITY \\([0-9]+\\)") (imap-mailbox-put 'uidvalidity (match-string 1))) ((search-forward "READ-ONLY" nil t) @@ -2096,18 +2341,18 @@ Return nil if no complete line has arrived." ;; "BODY" ["STRUCTURE"] SPACE body / ;; "BODY" section ["<" number ">"] SPACE nstring / ;; "UID" SPACE uniqueid) ")" -;; +;; ;; date_time ::= <"> date_day_fixed "-" date_month "-" date_year ;; SPACE time SPACE zone <"> -;; +;; ;; section ::= "[" [section_text / (nz_number *["." nz_number] ;; ["." (section_text / "MIME")])] "]" -;; +;; ;; section_text ::= "HEADER" / "HEADER.FIELDS" [".NOT"] ;; SPACE header_list / "TEXT" -;; +;; ;; header_fld_name ::= astring -;; +;; ;; header_list ::= "(" 1#header_fld_name ")" (defsubst imap-parse-header-list () @@ -2120,7 +2365,7 @@ Return nil if no complete line has arrived." (nreverse strlist)))) (defsubst imap-parse-fetch-body-section () - (let ((section + (let ((section (buffer-substring (point) (1- (re-search-forward "[] ]" nil t))))) (if (eq (char-before) ? ) (prog1 @@ -2130,16 +2375,20 @@ Return nil if no complete line has arrived." (defun imap-parse-fetch (response) (when (eq (char-after) ?\() - (let (uid flags envelope internaldate rfc822 rfc822header rfc822text - rfc822size body bodydetail bodystructure) + (let (uid flags envelope internaldate rfc822 rfc822header rfc822text + rfc822size body bodydetail bodystructure flags-empty) (while (not (eq (char-after) ?\))) (imap-forward) (let ((token (read (current-buffer)))) (imap-forward) (cond ((eq token 'UID) - (setq uid (ignore-errors (read (current-buffer))))) + (setq uid (condition-case () + (read (current-buffer)) + (error)))) ((eq token 'FLAGS) - (setq flags (imap-parse-flag-list))) + (setq flags (imap-parse-flag-list)) + (if (not flags) + (setq flags-empty 't))) ((eq token 'ENVELOPE) (setq envelope (imap-parse-envelope))) ((eq token 'INTERNALDATE) @@ -2168,7 +2417,7 @@ Return nil if no complete line has arrived." (when uid (setq imap-current-message uid) (imap-message-put uid 'UID uid) - (and flags (imap-message-put uid 'FLAGS flags)) + (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags)) (and envelope (imap-message-put uid 'ENVELOPE envelope)) (and internaldate (imap-message-put uid 'INTERNALDATE internaldate)) (and rfc822 (imap-message-put uid 'RFC822 rfc822)) @@ -2182,7 +2431,7 @@ Return nil if no complete line has arrived." ;; mailbox-data = ... ;; "STATUS" SP mailbox SP "(" -;; [status-att SP number +;; [status-att SP number ;; *(SP status-att SP number)] ")" ;; ... ;; @@ -2191,24 +2440,32 @@ Return nil if no complete line has arrived." (defun imap-parse-status () (let ((mailbox (imap-parse-mailbox))) - (when (and mailbox (search-forward "(" nil t)) - (while (not (eq (char-after) ?\))) - (let ((token (read (current-buffer)))) - (cond ((eq token 'MESSAGES) + (if (eq (char-after) ? ) + (forward-char)) + (when (and mailbox (eq (char-after) ?\()) + (while (and (not (eq (char-after) ?\))) + (or (forward-char) t) + (looking-at "\\([A-Za-z]+\\) ")) + (let ((token (match-string 1))) + (goto-char (match-end 0)) + (cond ((string= token "MESSAGES") (imap-mailbox-put 'messages (read (current-buffer)) mailbox)) - ((eq token 'RECENT) + ((string= token "RECENT") (imap-mailbox-put 'recent (read (current-buffer)) mailbox)) - ((eq token 'UIDNEXT) - (imap-mailbox-put 'uidnext (read (current-buffer)) mailbox)) - ((eq token 'UIDVALIDITY) - (and (looking-at " \\([0-9]+\\)") - (imap-mailbox-put 'uidvalidity (match-string 1) mailbox) - (goto-char (match-end 1)))) - ((eq token 'UNSEEN) + ((string= token "UIDNEXT") + (and (looking-at "[0-9]+") + (imap-mailbox-put 'uidnext (match-string 0) mailbox) + (goto-char (match-end 0)))) + ((string= token "UIDVALIDITY") + (and (looking-at "[0-9]+") + (imap-mailbox-put 'uidvalidity (match-string 0) mailbox) + (goto-char (match-end 0)))) + ((string= token "UNSEEN") (imap-mailbox-put 'unseen (read (current-buffer)) mailbox)) (t - (message "Unknown status data %s in mailbox %s ignored" - token mailbox)))))))) + (message "Unknown status data %s in mailbox %s ignored" + token mailbox) + (read (current-buffer))))))))) ;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE ;; rights) @@ -2246,16 +2503,16 @@ Return nil if no complete line has arrived." (defun imap-parse-flag-list () (let (flag-list start) - (assert (eq (char-after) ?\()) + (assert (eq (char-after) ?\() nil "In imap-parse-flag-list") (while (and (not (eq (char-after) ?\))) (setq start (progn (imap-forward) ;; next line for Courier IMAP bug. (skip-chars-forward " ") (point))) - (> (skip-chars-forward "^ )" (imap-point-at-eol)) 0)) + (> (skip-chars-forward "^ )" (point-at-eol)) 0)) (push (buffer-substring start (point)) flag-list)) - (assert (eq (char-after) ?\))) + (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list") (imap-forward) (nreverse flag-list))) @@ -2286,31 +2543,31 @@ Return nil if no complete line has arrived." (defun imap-parse-envelope () (when (eq (char-after) ?\() (imap-forward) - (vector (prog1 (imap-parse-nstring);; date + (vector (prog1 (imap-parse-nstring) ;; date (imap-forward)) - (prog1 (imap-parse-nstring);; subject + (prog1 (imap-parse-nstring) ;; subject (imap-forward)) - (prog1 (imap-parse-address-list);; from + (prog1 (imap-parse-address-list) ;; from (imap-forward)) - (prog1 (imap-parse-address-list);; sender + (prog1 (imap-parse-address-list) ;; sender (imap-forward)) - (prog1 (imap-parse-address-list);; reply-to + (prog1 (imap-parse-address-list) ;; reply-to (imap-forward)) - (prog1 (imap-parse-address-list);; to + (prog1 (imap-parse-address-list) ;; to (imap-forward)) - (prog1 (imap-parse-address-list);; cc + (prog1 (imap-parse-address-list) ;; cc (imap-forward)) - (prog1 (imap-parse-address-list);; bcc + (prog1 (imap-parse-address-list) ;; bcc (imap-forward)) - (prog1 (imap-parse-nstring);; in-reply-to + (prog1 (imap-parse-nstring) ;; in-reply-to (imap-forward)) - (prog1 (imap-parse-nstring);; message-id + (prog1 (imap-parse-nstring) ;; message-id (imap-forward))))) ;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil (defsubst imap-parse-string-list () - (cond ((eq (char-after) ?\();; body-fld-param + (cond ((eq (char-after) ?\() ;; body-fld-param (let (strlist str) (imap-forward) (while (setq str (imap-parse-string)) @@ -2340,7 +2597,7 @@ Return nil if no complete line has arrived." (while (eq (char-after) ?\ ) (imap-forward) (push (imap-parse-body-extension) b-e)) - (assert (eq (char-after) ?\))) + (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") (imap-forward) (nreverse b-e)) (or (imap-parse-number) @@ -2358,7 +2615,7 @@ Return nil if no complete line has arrived." (defsubst imap-parse-body-ext () (let (ext) - (when (eq (char-after) ?\ );; body-fld-dsp + (when (eq (char-after) ?\ ) ;; body-fld-dsp (imap-forward) (let (dsp) (if (eq (char-after) ?\() @@ -2368,14 +2625,14 @@ Return nil if no complete line has arrived." (imap-forward) (push (imap-parse-string-list) dsp) (imap-forward)) - (assert (imap-parse-nil))) + (assert (imap-parse-nil) t "In imap-parse-body-ext")) (push (nreverse dsp) ext)) - (when (eq (char-after) ?\ );; body-fld-lang + (when (eq (char-after) ?\ ) ;; body-fld-lang (imap-forward) (if (eq (char-after) ?\() (push (imap-parse-string-list) ext) (push (imap-parse-nstring) ext)) - (while (eq (char-after) ?\ );; body-extension + (while (eq (char-after) ?\ ) ;; body-extension (imap-forward) (setq ext (append (imap-parse-body-extension) ext))))) ext)) @@ -2449,91 +2706,90 @@ Return nil if no complete line has arrived." (let (subbody) (while (and (eq (char-after) ?\() (setq subbody (imap-parse-body))) - ;; buggy stalker communigate pro 3.0 insert a SPC between + ;; buggy stalker communigate pro 3.0 insert a SPC between ;; parts in multiparts (when (and (eq (char-after) ?\ ) (eq (char-after (1+ (point))) ?\()) (imap-forward)) (push subbody body)) (imap-forward) - (push (imap-parse-string) body);; media-subtype - (when (eq (char-after) ?\ );; body-ext-mpart: + (push (imap-parse-string) body) ;; media-subtype + (when (eq (char-after) ?\ ) ;; body-ext-mpart: (imap-forward) - (if (eq (char-after) ?\();; body-fld-param + (if (eq (char-after) ?\() ;; body-fld-param (push (imap-parse-string-list) body) (push (and (imap-parse-nil) nil) body)) (setq body - (append (imap-parse-body-ext) body)));; body-ext-... - (assert (eq (char-after) ?\))) + (append (imap-parse-body-ext) body))) ;; body-ext-... + (assert (eq (char-after) ?\)) nil "In imap-parse-body") (imap-forward) (nreverse body)) - (push (imap-parse-string) body);; media-type + (push (imap-parse-string) body) ;; media-type (imap-forward) - (push (imap-parse-string) body);; media-subtype + (push (imap-parse-string) body) ;; media-subtype (imap-forward) ;; next line for Sun SIMS bug (and (eq (char-after) ? ) (imap-forward)) - (if (eq (char-after) ?\();; body-fld-param + (if (eq (char-after) ?\() ;; body-fld-param (push (imap-parse-string-list) body) (push (and (imap-parse-nil) nil) body)) (imap-forward) - (push (imap-parse-nstring) body);; body-fld-id + (push (imap-parse-nstring) body) ;; body-fld-id (imap-forward) - (push (imap-parse-nstring) body);; body-fld-desc + (push (imap-parse-nstring) body) ;; body-fld-desc (imap-forward) ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a - ;; nstring and return NIL instead of defaulting back to 7BIT + ;; nstring and return nil instead of defaulting back to 7BIT ;; as the standard says. - (push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc + (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc (imap-forward) - (push (imap-parse-number) body);; body-fld-octets + (push (imap-parse-number) body) ;; body-fld-octets - ;; ok, we're done parsing the required parts, what comes now is one + ;; ok, we're done parsing the required parts, what comes now is one ;; of three things: ;; ;; envelope (then we're parsing body-type-msg) ;; body-fld-lines (then we're parsing body-type-text) ;; body-ext-1part (then we're parsing body-type-basic) ;; - ;; the problem is that the two first are in turn optionally followed - ;; by the third. So we parse the first two here (if there are any)... + ;; the problem is that the two first are in turn optionally followed +;; by the third. So we parse the first two here (if there are any)... (when (eq (char-after) ?\ ) (imap-forward) (let (lines) - (cond ((eq (char-after) ?\();; body-type-msg: - (push (imap-parse-envelope) body);; envelope + (cond ((eq (char-after) ?\() ;; body-type-msg: + (push (imap-parse-envelope) body) ;; envelope (imap-forward) - (push (imap-parse-body) body);; body + (push (imap-parse-body) body) ;; body ;; buggy stalker communigate pro 3.0 doesn't print ;; number of lines in message/rfc822 attachment (if (eq (char-after) ?\)) (push 0 body) (imap-forward) (push (imap-parse-number) body))) ;; body-fld-lines - ((setq lines (imap-parse-number)) ;; body-type-text: - (push lines body)) ;; body-fld-lines + ((setq lines (imap-parse-number)) ;; body-type-text: + (push lines body)) ;; body-fld-lines (t - (backward-char))))) ;; no match... + (backward-char))))) ;; no match... ;; ...and then parse the third one here... - (when (eq (char-after) ?\ );; body-ext-1part: + (when (eq (char-after) ?\ ) ;; body-ext-1part: (imap-forward) - (push (imap-parse-nstring) body);; body-fld-md5 - (setq body (append (imap-parse-body-ext) body)));; body-ext-1part.. - - (assert (eq (char-after) ?\))) + (push (imap-parse-nstring) body) ;; body-fld-md5 + (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. + + (assert (eq (char-after) ?\)) nil "In imap-parse-body 2") (imap-forward) (nreverse body))))) (when imap-debug ; (untrace-all) (require 'trace) - (buffer-disable-undo (get-buffer-create imap-debug)) - (mapcar (lambda (f) (trace-function-background f imap-debug)) + (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 @@ -2625,7 +2881,8 @@ Return nil if no complete line has arrived." imap-parse-body-extension imap-parse-body ))) - + (provide 'imap) +;;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7 ;;; imap.el ends here