X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fimap.el;h=8e41c68720b4baf20ba1d609dc0bb5c75a011260;hp=aa26b06b134f56e3239d5ca1c1f92c0592315199;hb=b58d62328adf02b341b460a98819a54a0d629b60;hpb=cd5b82c3b85262a5bfdb3e22da5ccb6a612250e8 diff --git a/lisp/imap.el b/lisp/imap.el index aa26b06b1..8e41c6872 100644 --- a/lisp/imap.el +++ b/lisp/imap.el @@ -1,6 +1,7 @@ ;;; imap.el --- imap library -;; Copyright (C) 1998, 1999, 2000, 2001, 2002 -;; Free Software Foundation, Inc. + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Keywords: mail @@ -9,7 +10,7 @@ ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -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,17 +70,17 @@ ;; 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. ;; -;; 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 +;; takes advantage of the UNSELECT extension in Cyrus IMAPD. ;; ;; Without the work of John McClary Prevost and Jim Radford this library ;; would not have seen the light of day. Many thanks. @@ -125,6 +126,7 @@ ;; 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 +140,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 +171,11 @@ 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 %s %p " + "--mechanism GSSAPI " + "--authentication-id %l") + "imtest -m gssapi -u %l -p %p %s") "List of strings containing commands for GSSAPI (krb5) authentication. %s is replaced with server hostname, %p with port to connect to, and %l with the value of `imap-default-user'. The program should accept @@ -215,7 +211,14 @@ 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." + :version "22.1" :group 'imap :type 'boolean) @@ -228,12 +231,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) @@ -247,17 +258,33 @@ 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) + +(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) @@ -274,6 +301,7 @@ stream.") kerberos4 digest-md5 cram-md5 + ;;sasl login anonymous) "Priority of authenticators to consider when authenticating to server.") @@ -281,6 +309,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) @@ -296,10 +325,18 @@ for doing the actual authentication.") (defvar imap-error nil "Error codes from the last command.") -;; Internal constants. Change theese and die. +(defvar imap-logout-timeout nil + "Close server immediately if it can't logout in this number of seconds. +If it is nil, never close server until logout completes. Normally, +the value of this variable will be bound to a certain value to which +an application program that uses this module specifies on a per-server +basis.") + +;; Internal constants. Change these and die. (defconst imap-default-port 143) (defconst imap-default-ssl-port 993) +(defconst imap-default-tls-port 993) (defconst imap-default-stream 'network) (defconst imap-coding-system-for-read 'binary) (defconst imap-coding-system-for-write 'binary) @@ -315,6 +352,7 @@ for doing the actual authentication.") imap-current-target-mailbox imap-message-data imap-capability + imap-id imap-namespace imap-state imap-reached-tag @@ -370,6 +408,10 @@ 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.") @@ -417,22 +459,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 @@ -497,8 +523,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)) + ;; 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:") + (or (while (looking-at "^C:") (forward-line)) t) ;; cyrus 1.6 imtest print "S: " before server greeting @@ -528,7 +561,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 "LOGOUT")) + (imap-logout)) (delete-process process) nil))))) done)) @@ -541,6 +574,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) @@ -561,18 +595,32 @@ 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)) + ;; 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:") + (or (while (looking-at "^C:") (forward-line)) t) ;; cyrus 1.6 imtest print "S: " before server greeting (or (not (looking-at "S: ")) (forward-char 3) t) + ;; GNU SASL may print 'Trying ...' first. + (or (not (looking-at "Trying ")) + (forward-line) + t) (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)) @@ -588,7 +636,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 "LOGOUT")) + (imap-logout)) (delete-process process) nil))))) done)) @@ -601,24 +649,28 @@ 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 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 (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))))) + (funcall set-process-query-on-exit-flag process nil) + process) (with-current-buffer buffer (goto-char (point-min)) (while (and (memq (process-status process) '(open run)) @@ -644,6 +696,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) @@ -722,36 +799,36 @@ 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 (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-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: @@ -773,7 +850,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) "'): ")))) @@ -782,11 +859,13 @@ 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) (sit-for 1)))) ;; (quit (with-current-buffer buffer ;; (setq user nil @@ -797,8 +876,7 @@ Returns t if login was successful, nil otherwise." ret))) (defun imap-gssapi-auth-p (buffer) - (and (imap-capability 'AUTH=GSSAPI buffer) - (eq imap-stream 'gssapi))) + (eq imap-stream 'gssapi)) (defun imap-gssapi-auth (buffer) (message "imap: Authenticating using GSSAPI...%s" @@ -841,14 +919,27 @@ Returns t if login was successful, nil otherwise." (and (not (imap-capability 'LOGINDISABLED buffer)) (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))) +(defun imap-quote-specials (string) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "[\\\"]" nil t) + (forward-char -1) + (insert "\\") + (forward-char 1)) + (buffer-string))) + (defun imap-login-auth (buffer) "Login to server using the LOGIN command." (message "imap: Plaintext authentication...") (imap-interactive-login buffer (lambda (user passwd) (imap-ok-p (imap-send-command-wait - (concat "LOGIN \"" user "\" \"" - passwd "\"")))))) + (concat "LOGIN \"" + (imap-quote-specials user) + "\" \"" + (imap-quote-specials passwd) + "\"")))))) (defun imap-anonymous-p (buffer) t) @@ -860,6 +951,73 @@ 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)) + +(declare-function sasl-find-mechanism "sasl" (mechanism)) +(declare-function sasl-mechanism-name "sasl" (mechanism)) +(declare-function sasl-make-client "sasl" (mechanism name service server)) +(declare-function sasl-next-step "sasl" (client step)) +(declare-function sasl-step-data "sasl" (step)) +(declare-function sasl-step-set-data "sasl" (step data)) + +(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 () @@ -932,7 +1090,7 @@ necessary. If nil, the buffer name is generated." (with-current-buffer (get-buffer-create buffer) (if (imap-opened buffer) (imap-close buffer)) - (mapcar 'make-local-variable imap-local-variables) + (mapc 'make-local-variable imap-local-variables) (imap-disable-multibyte) (buffer-disable-undo) (setq imap-server (or server imap-server)) @@ -955,7 +1113,7 @@ necessary. If nil, the buffer name is generated." (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) + (mapc 'make-local-variable imap-local-variables) (imap-disable-multibyte) (buffer-disable-undo) (setq imap-server (or server imap-server)) @@ -971,8 +1129,11 @@ necessary. If nil, the buffer name is generated." stream)) ;; We're done, kill the first connection (imap-close buffer) - (kill-buffer buffer) - (rename-buffer buffer) + (let ((name (if (stringp buffer) + buffer + (buffer-name buffer)))) + (kill-buffer buffer) + (rename-buffer name)) (message "imap: Reconnecting with stream `%s'...done" stream) (setq imap-stream stream) @@ -1007,7 +1168,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) @@ -1041,7 +1202,7 @@ If BUFFER is nil, the current buffer is used." (with-current-buffer (or buffer (current-buffer)) (when (imap-opened) (condition-case nil - (imap-send-command-wait "LOGOUT") + (imap-logout-wait) (quit nil))) (when (and imap-process (memq (process-status imap-process) '(open run))) @@ -1064,6 +1225,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." @@ -1076,6 +1257,28 @@ If BUFFER is nil, the current buffer is assumed." (defun imap-send-command-wait (command &optional buffer) (imap-wait-for-tag (imap-send-command command buffer) buffer)) +(defun imap-logout (&optional buffer) + (or buffer (setq buffer (current-buffer))) + (if imap-logout-timeout + (with-timeout (imap-logout-timeout + (condition-case nil + (with-current-buffer buffer + (delete-process imap-process)) + (error))) + (imap-send-command "LOGOUT" buffer)) + (imap-send-command "LOGOUT" buffer))) + +(defun imap-logout-wait (&optional buffer) + (or buffer (setq buffer (current-buffer))) + (if imap-logout-timeout + (with-timeout (imap-logout-timeout + (condition-case nil + (with-current-buffer buffer + (delete-process imap-process)) + (error))) + (imap-send-command-wait "LOGOUT" buffer)) + (imap-send-command-wait "LOGOUT" buffer))) + ;; Mailbox functions: @@ -1310,10 +1513,11 @@ returned, if ITEMS is a symbol only its value is returned." (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)) @@ -1329,10 +1533,11 @@ or 'unseen. The IMAP command tag is returned." (imap-send-command (list "STATUS \"" (imap-utf7-encode mailbox) "\" " - (format "%s" - (if (listp items) - items - (list items))))))) + (upcase + (format "%s" + (if (listp items) + items + (list items)))))))) (defun imap-mailbox-acl-get (&optional mailbox buffer) "Get ACL on mailbox from server in BUFFER." @@ -1404,7 +1609,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 ") @@ -1503,7 +1708,7 @@ is non-nil return theese properties." (imap-mailbox-get-1 'search imap-current-mailbox))))) (defun imap-message-flag-permanent-p (flag &optional mailbox buffer) - "Return t iff FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER." + "Return t if FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER." (with-current-buffer (or buffer (current-buffer)) (or (member "\\*" (imap-mailbox-get 'permanentflags mailbox)) (member flag (imap-mailbox-get 'permanentflags mailbox))))) @@ -1719,7 +1924,18 @@ 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))))) + ;; 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)) @@ -1746,34 +1962,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-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))))))))) ;; Imap parser. @@ -1918,7 +2137,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 @@ -2012,6 +2233,8 @@ Return nil if no complete line has arrived." (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)) @@ -2302,7 +2525,7 @@ Return nil if no complete line has arrived." (while (and (not (eq (char-after) ?\))) (or (forward-char) t) (looking-at "\\([A-Za-z]+\\) ")) - (let ((token (match-string 1))) + (let ((token (upcase (match-string 1)))) (goto-char (match-end 0)) (cond ((string= token "MESSAGES") (imap-mailbox-put 'messages (read (current-buffer)) mailbox)) @@ -2359,16 +2582,16 @@ Return nil if no complete line has arrived." (defun imap-parse-flag-list () (let (flag-list start) - (assert (eq (char-after) ?\() t "In imap-parse-flag-list") + (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) ?\)) t "In imap-parse-flag-list") + (assert (eq (char-after) ?\)) nil "In imap-parse-flag-list") (imap-forward) (nreverse flag-list))) @@ -2453,7 +2676,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) ?\)) t "In imap-parse-body-extension") + (assert (eq (char-after) ?\)) nil "In imap-parse-body-extension") (imap-forward) (nreverse b-e)) (or (imap-parse-number) @@ -2481,7 +2704,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) @@ -2577,7 +2802,7 @@ Return nil if no complete line has arrived." (push (and (imap-parse-nil) nil) body)) (setq body (append (imap-parse-body-ext) body))) ;; body-ext-... - (assert (eq (char-after) ?\)) t "In imap-parse-body") + (assert (eq (char-after) ?\)) nil "In imap-parse-body") (imap-forward) (nreverse body)) @@ -2637,108 +2862,108 @@ Return nil if no complete line has arrived." (push (imap-parse-nstring) body) ;; body-fld-md5 (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. - (assert (eq (char-after) ?\)) t "In imap-parse-body 2") + (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-buffer)) - (mapcar (lambda (f) (trace-function-background f imap-debug-buffer)) - '( - imap-read-passwd - imap-utf7-encode - imap-utf7-decode - imap-error-text - imap-kerberos4s-p - imap-kerberos4-open - imap-ssl-p - imap-ssl-open - imap-network-p - imap-network-open - imap-interactive-login - imap-kerberos4a-p - imap-kerberos4-auth - imap-cram-md5-p - imap-cram-md5-auth - imap-login-p - imap-login-auth - imap-anonymous-p - imap-anonymous-auth - imap-open-1 - imap-open - imap-opened - imap-authenticate - imap-close - imap-capability - imap-namespace - imap-send-command-wait - imap-mailbox-put - imap-mailbox-get - imap-mailbox-map-1 - imap-mailbox-map - imap-current-mailbox - imap-current-mailbox-p-1 - imap-current-mailbox-p - imap-mailbox-select-1 - imap-mailbox-select - imap-mailbox-examine-1 - imap-mailbox-examine - imap-mailbox-unselect - imap-mailbox-expunge - imap-mailbox-close - imap-mailbox-create-1 - imap-mailbox-create - imap-mailbox-delete - imap-mailbox-rename - imap-mailbox-lsub - imap-mailbox-list - imap-mailbox-subscribe - imap-mailbox-unsubscribe - imap-mailbox-status - imap-mailbox-acl-get - imap-mailbox-acl-set - imap-mailbox-acl-delete - imap-current-message - imap-list-to-message-set - imap-fetch-asynch - imap-fetch - imap-message-put - imap-message-get - imap-message-map - imap-search - imap-message-flag-permanent-p - imap-message-flags-set - imap-message-flags-del - imap-message-flags-add - imap-message-copyuid-1 - imap-message-copyuid - imap-message-copy - imap-message-appenduid-1 - imap-message-appenduid - imap-message-append - imap-body-lines - imap-envelope-from - imap-send-command-1 - imap-send-command - imap-wait-for-tag - imap-sentinel - imap-find-next-line - imap-arrival-filter - imap-parse-greeting - imap-parse-response - imap-parse-resp-text - imap-parse-resp-text-code - imap-parse-data-list - imap-parse-fetch - imap-parse-status - imap-parse-acl - imap-parse-flag-list - imap-parse-envelope - imap-parse-body-extension - imap-parse-body - ))) + (mapc (lambda (f) (trace-function-background f imap-debug-buffer)) + '( + imap-utf7-encode + imap-utf7-decode + imap-error-text + imap-kerberos4s-p + imap-kerberos4-open + imap-ssl-p + imap-ssl-open + imap-network-p + imap-network-open + imap-interactive-login + imap-kerberos4a-p + imap-kerberos4-auth + imap-cram-md5-p + imap-cram-md5-auth + imap-login-p + imap-login-auth + imap-anonymous-p + imap-anonymous-auth + imap-open-1 + imap-open + imap-opened + imap-authenticate + imap-close + imap-capability + imap-namespace + imap-send-command-wait + imap-mailbox-put + imap-mailbox-get + imap-mailbox-map-1 + imap-mailbox-map + imap-current-mailbox + imap-current-mailbox-p-1 + imap-current-mailbox-p + imap-mailbox-select-1 + imap-mailbox-select + imap-mailbox-examine-1 + imap-mailbox-examine + imap-mailbox-unselect + imap-mailbox-expunge + imap-mailbox-close + imap-mailbox-create-1 + imap-mailbox-create + imap-mailbox-delete + imap-mailbox-rename + imap-mailbox-lsub + imap-mailbox-list + imap-mailbox-subscribe + imap-mailbox-unsubscribe + imap-mailbox-status + imap-mailbox-acl-get + imap-mailbox-acl-set + imap-mailbox-acl-delete + imap-current-message + imap-list-to-message-set + imap-fetch-asynch + imap-fetch + imap-message-put + imap-message-get + imap-message-map + imap-search + imap-message-flag-permanent-p + imap-message-flags-set + imap-message-flags-del + imap-message-flags-add + imap-message-copyuid-1 + imap-message-copyuid + imap-message-copy + imap-message-appenduid-1 + imap-message-appenduid + imap-message-append + imap-body-lines + imap-envelope-from + imap-send-command-1 + imap-send-command + imap-wait-for-tag + imap-sentinel + imap-find-next-line + imap-arrival-filter + imap-parse-greeting + imap-parse-response + imap-parse-resp-text + imap-parse-resp-text-code + imap-parse-data-list + imap-parse-fetch + imap-parse-status + imap-parse-acl + imap-parse-flag-list + imap-parse-envelope + imap-parse-body-extension + imap-parse-body + ))) (provide 'imap) +;;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7 ;;; imap.el ends here