X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fimap.el;h=def7d4a44f54bc8ab2e70bd1888d6c8ea5205481;hp=2b36d798d6ed8214fd10e242cbd9f1d9d0494195;hb=24b14a968f23355a4941d920b5c61e688f288076;hpb=edd7e48432c9a489df69da4bc7e8932ce840a2d1 diff --git a/lisp/imap.el b/lisp/imap.el index 2b36d798d..def7d4a44 100644 --- a/lisp/imap.el +++ b/lisp/imap.el @@ -1,30 +1,29 @@ ;;; imap.el --- imap library -;; Copyright (C) 1998, 1999, 2000, 2001, 2002 -;; Free Software Foundation, Inc. -;; Author: Simon Josefsson +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Simon Josefsson ;; Keywords: mail ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; 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. +;; along with GNU Emacs. If not, see . ;;; Commentary: -;; imap.el is a elisp library providing an interface for talking to +;; imap.el is an elisp library providing an interface for talking to ;; IMAP servers. ;; ;; imap.el is roughly divided in two parts, one that parses IMAP @@ -69,29 +68,29 @@ ;; 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 supports RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1). The 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'), and 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. ;; -;; This is a transcript of short interactive session for demonstration +;; This is a transcript of a short interactive session for demonstration ;; purposes. ;; ;; (imap-open "my.mail.server") ;; => " *imap* my.mail.server:0" ;; ;; The rest are invoked with current buffer as the buffer returned by -;; `imap-open'. It is possible to do all without this, but it would +;; `imap-open'. It is possible to do it all without this, but it would ;; look ugly here since `buffer' is always the last argument for all ;; imap.el API functions. ;; @@ -122,45 +121,38 @@ ;; Todo: ;; ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow. +;; Use IEEE floats (which are effectively exact)? -- fx ;; 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: ;; ;; - 19991218 added starttls/digest-md5 patch, ;; by Daiki Ueno ;; NB! you need SLIM for starttls.el and digest-md5.el -;; - 19991023 commited to pgnus +;; - 19991023 committed to pgnus ;; ;;; Code: (eval-when-compile (require 'cl)) (eval-and-compile - (autoload 'open-ssl-stream "ssl") - (autoload 'base64-decode-string "base64") - (autoload 'base64-encode-string "base64") + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) (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 @@ -209,13 +205,20 @@ until a successful connection is made." Within a string, %s is replaced with the server address, %p with port number on server, %g with `imap-shell-host', and %l with `imap-default-user'. The program should read IMAP commands from stdin -and write IMAP response to stdout. Each entry in the list is tried +and write IMAP response to stdout. Each entry in the list is tried until a successful connection is made." :group 'imap :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 controls the 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 an IMAP server is +opened; changing it after that has no effect." + :version "22.1" :group 'imap :type 'boolean) @@ -228,12 +231,28 @@ 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, an 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 buffer. +It is not written to disk, however. Do not enable this +variable unless you are comfortable with that. + +See also `imap-debug'." :group 'imap :type 'boolean) (defcustom imap-debug nil - "If non-nil, random debug spews are placed in *imap-debug* buffer." + "If non-nil, trace imap- functions into `imap-debug-buffer'. +Uses `trace-function-background', so you can turn it off with, +say, `untrace-all'. + +Note that username, passwords and other privacy sensitive +information (such as e-mail) may be stored in the buffer. +It is not written to disk, however. Do not enable this +variable unless you are comfortable with that. + +This variable only takes effect when loading the `imap' library. +See also `imap-log'." :group 'imap :type 'boolean) @@ -247,17 +266,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 prompting." + :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 +309,7 @@ stream.") kerberos4 digest-md5 cram-md5 + ;;sasl login anonymous) "Priority of authenticators to consider when authenticating to server.") @@ -281,6 +317,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 +333,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 +360,7 @@ for doing the actual authentication.") imap-current-target-mailbox imap-message-data imap-capability + imap-id imap-namespace imap-state imap-reached-tag @@ -356,7 +402,7 @@ and `examine'.") "Obarray with mailbox data.") (defvar imap-mailbox-prime 997 - "Length of imap-mailbox-data.") + "Length of `imap-mailbox-data'.") (defvar imap-current-message nil "Current message number.") @@ -365,11 +411,15 @@ and `examine'.") "Obarray with message data.") (defvar imap-message-prime 997 - "Length of imap-message-data.") + "Length of `imap-message-data'.") (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.") @@ -390,20 +440,26 @@ 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.") +The actual value is really the text on the continuation line.") (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.") +(defvar imap-enable-exchange-bug-workaround nil + "Send FETCH UID commands as *:* instead of *. +Enabling this appears to be required for some servers (e.g., +Microsoft Exchange) which otherwise would trigger a response 'BAD +The specified message set is invalid.'.") + ;; 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 + "Delete by side effect any elements of ALIST whose car is `equal' to KEY. +The modified ALIST is returned. If the first member +of ALIST 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 @@ -417,22 +473,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 +537,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 +575,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-logout)) (delete-process process) nil))))) done)) @@ -541,6 +588,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 +609,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 +650,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-logout)) (delete-process process) nil))))) done)) @@ -597,28 +659,32 @@ If ARGS, PROMPT is used as an argument to `format'." nil) (defun imap-ssl-open (name buffer server port) - "Open a SSL connection to server." + "Open an SSL connection to SERVER." (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 +710,38 @@ 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)) + ;; FIXME: Per the "blue moon" comment, the process/buffer + ;; handling here, and elsewhere in functions which open + ;; streams, looks confused. Obviously we can change buffers + ;; if a different process handler kicks in from + ;; `accept-process-output' or `sit-for' below, and TRT seems + ;; to be to `save-buffer' around those calls. (I wonder why + ;; `sit-for' is used with a non-zero wait.) -- fx + (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) @@ -672,7 +770,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) @@ -692,7 +791,8 @@ 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)) @@ -720,43 +820,43 @@ 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: (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-local-variable 'imap-username) @@ -766,22 +866,27 @@ Returns t if login was successful, nil otherwise." (while (or (not user) (not passwd)) (setq user (or imap-username (read-from-minibuffer - (concat "IMAP username for " imap-server ": ") + (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 + (read-passwd (concat "IMAP password for " user "@" - imap-server ": ")))) + 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 @@ -792,8 +897,7 @@ Returns t if login was successful, nil otherwise." ret))) (defun imap-gssapi-auth-p (buffer) - (and (imap-capability 'AUTH=GSSAPI buffer) - (eq imap-state 'gssapi))) + (eq imap-stream 'gssapi)) (defun imap-gssapi-auth (buffer) (message "imap: Authenticating using GSSAPI...%s" @@ -802,7 +906,7 @@ Returns t if login was successful, nil otherwise." (defun imap-kerberos4-auth-p (buffer) (and (imap-capability 'AUTH=KERBEROS_V4 buffer) - (eq imap-state 'kerberos4))) + (eq imap-stream 'kerberos4))) (defun imap-kerberos4-auth (buffer) (message "imap: Authenticating using Kerberos 4...%s" @@ -836,25 +940,105 @@ 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) (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) "@" (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 () @@ -913,7 +1097,7 @@ Returns t if login was successful, nil otherwise." imap-process)))) (defun imap-open (server &optional port stream auth buffer) - "Open a IMAP connection to host SERVER at PORT returning a buffer. + "Open an IMAP connection to host SERVER at PORT returning a buffer. If PORT is unspecified, a default value is used (143 except for SSL which use 993). STREAM indicates the stream to use, see `imap-streams' for available @@ -922,12 +1106,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-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)) @@ -948,21 +1132,31 @@ necessery. If nil, the buffer name is generated." (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer) ;; Stream changed? (if (not (eq imap-default-stream stream)) - (with-temp-buffer - (mapcar 'make-local-variable imap-local-variables) + (with-current-buffer (get-buffer-create + (generate-new-buffer-name " *temp*")) + (mapc '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)))) - (message "imap: Reconnecting with stream `%s'...failed" - stream) + (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) + (let ((name (if (stringp buffer) + buffer + (buffer-name buffer)))) + (kill-buffer buffer) + (rename-buffer name)) (message "imap: Reconnecting with stream `%s'...done" - imap-stream) + stream) (setq imap-stream stream) (setq imap-capability nil) (setq streams nil))) @@ -973,9 +1167,16 @@ necessery. If nil, the buffer name is generated." (setq streams nil)))))) (when (imap-opened buffer) (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))) - (when imap-stream + (when imap-stream buffer)))) +(defcustom imap-ping-server t + "If non-nil, check if IMAP is open. +See the function `imap-ping-server'." + :version "23.1" ;; No Gnus + :group 'imap + :type 'boolean) + (defun imap-opened (&optional buffer) "Return non-nil if connection to imap server in BUFFER is open. If BUFFER is nil then the current buffer is used." @@ -983,7 +1184,18 @@ If BUFFER is nil then the current buffer is used." (buffer-live-p buffer) (with-current-buffer buffer (and imap-process - (memq (process-status imap-process) '(open run)))))) + (memq (process-status imap-process) '(open run)) + (if imap-ping-server + (imap-ping-server) + t))))) + +(defun imap-ping-server (&optional buffer) + "Ping the IMAP server in BUFFER with a \"NOOP\" command. +Return non-nil if the server responds, and nil if it does not +respond. If BUFFER is nil, the current buffer is used." + (condition-case () + (imap-ok-p (imap-send-command-wait "NOOP" buffer)) + (error nil))) (defun imap-authenticate (&optional user passwd buffer) "Authenticate to server in BUFFER, using current buffer if nil. @@ -995,30 +1207,30 @@ 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) (if user (setq imap-username user)) (if passwd (setq imap-password passwd)) (if imap-auth - (and (funcall (nth 2 (assq imap-auth - imap-authenticator-alist)) buffer) + (and (funcall (nth 2 (assq imap-auth + imap-authenticator-alist)) (current-buffer)) (setq imap-state 'auth)) ;; Choose authenticator. - (let (auth - (auths imap-authenticators)) + (let ((auths imap-authenticators) + auth) (while (setq auth (pop auths)) ;; OK to use authenticator? - (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer) + (when (funcall (nth 1 (assq auth imap-authenticator-alist)) (current-buffer)) (message "imap: Authenticating to `%s' using `%s'..." imap-server auth) - (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer) + (setq imap-auth auth) + (if (funcall (nth 2 (assq auth imap-authenticator-alist)) (current-buffer)) (progn (message "imap: Authenticating to `%s' using `%s'...done" imap-server auth) - (setq imap-auth auth - auths nil)) + (setq auths nil)) (message "imap: Authenticating to `%s' using `%s'...failed" imap-server auth))))) imap-state)))) @@ -1029,7 +1241,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))) @@ -1052,6 +1264,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." @@ -1064,6 +1296,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: @@ -1164,7 +1418,7 @@ If EXAMINE is non-nil, do a read-only select." (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 ASYNCH, do not wait for successful 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))) @@ -1174,7 +1428,7 @@ If BUFFER is nil the current buffer is assumed." (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 ASYNCH, do not wait for successful completion of the command. If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (when imap-current-mailbox @@ -1272,7 +1526,7 @@ passed to list command." (nreverse out))))) (defun imap-mailbox-subscribe (mailbox &optional buffer) - "Send the SUBSCRIBE command on the mailbox to server in BUFFER. + "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 \"" @@ -1280,7 +1534,7 @@ Returns non-nil if successful." "\""))))) (defun imap-mailbox-unsubscribe (mailbox &optional buffer) - "Send the SUBSCRIBE command on the mailbox to server in BUFFER. + "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 " @@ -1290,26 +1544,42 @@ Returns non-nil if successful." (defun imap-mailbox-status (mailbox items &optional buffer) "Get status items ITEM in MAILBOX from 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. If ITEMS is a list of symbols, a list of values is -returned, if ITEMS is a symbol only it's value is returned." +the STATUS data items -- i.e. `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 its value is returned." (with-current-buffer (or buffer (current-buffer)) (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 -- i.e. '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) + "\" " + (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." + "Get ACL on MAILBOX from server in BUFFER." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (when (imap-ok-p @@ -1331,7 +1601,7 @@ returned, if ITEMS is a symbol only it's value is returned." rights)))))) (defun imap-mailbox-acl-delete (identifier &optional mailbox buffer) - "Removes any pair for IDENTIFIER in MAILBOX from server in BUFFER." + "Remove any pair for IDENTIFIER in MAILBOX from server in BUFFER." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (imap-ok-p @@ -1378,7 +1648,7 @@ returned, if ITEMS is a symbol only it's value 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 ") @@ -1466,6 +1736,7 @@ is non-nil return theese properties." `(with-current-buffer (or ,buffer (current-buffer)) (imap-message-get ,uid 'BODY))) +;; FIXME: Should this try to use CHARSET? -- fx (defun imap-search (predicate &optional buffer) (with-current-buffer (or buffer (current-buffer)) (imap-mailbox-put 'search 'dummy) @@ -1477,7 +1748,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))))) @@ -1503,6 +1774,47 @@ is non-nil return theese properties." (concat "UID STORE " articles " +FLAGS" (if silent ".SILENT") " (" flags ")")))))) +;; Cf. http://thread.gmane.org/gmane.emacs.gnus.general/65317/focus=65343 +;; Signal an error if we'd get an integer overflow. +;; +;; FIXME: Identify relevant calls to `string-to-number' and replace them with +;; `imap-string-to-integer'. +(defun imap-string-to-integer (string &optional base) + (let ((number (string-to-number string base))) + (if (> number most-positive-fixnum) + (error + (format "String %s cannot be converted to a Lisp integer" number)) + number))) + +(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer) + "Like `imap-fetch', but DTRT with Exchange 2007 bug. +However, UIDS here is a cons, where the car is the canonical form +of the UIDS specification, and the cdr is the one which works with +Exchange 2007 or, potentially, other buggy servers. +See `imap-enable-exchange-bug-workaround'." + ;; We don't unconditionally use the alternative (valid) form, since + ;; this is said to be significantly inefficient. The first time we + ;; get here for a given, we'll try the canonical form. If we get + ;; the known error from the buggy server, set the flag + ;; buffer-locally (to account for connexions to multiple servers), + ;; then re-try with the alternative UIDS spec. + (condition-case data + (imap-fetch (if imap-enable-exchange-bug-workaround + (cdr uids) + (car uids)) + props receive nouidfetch buffer) + (error + (if (and (not imap-enable-exchange-bug-workaround) + (string-match + "The specified message set is invalid" + (cadr data))) + (with-current-buffer (or buffer (current-buffer)) + (set (make-local-variable + 'imap-enable-exchange-bug-workaround) + t) + (imap-fetch (cdr uids) props receive nouidfetch)) + (signal (car data) (cdr data)))))) + (defun imap-message-copyuid-1 (mailbox) (if (imap-capability 'UIDPLUS) (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox)) @@ -1512,7 +1824,7 @@ is non-nil return theese properties." (imap-message-data (make-vector 2 0))) (when (imap-mailbox-examine-1 mailbox) (prog1 - (and (imap-fetch "*" "UID") + (and (imap-fetch-safe '("*" . "*:*") "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map (lambda (uid prop) uid) 'UID)))) @@ -1526,11 +1838,11 @@ is non-nil return theese properties." (defun imap-message-copy (articles mailbox &optional dont-create no-copyuid buffer) - "Copy ARTICLES (a string message set) to MAILBOX on server in -BUFFER, creating mailbox if it doesn't exist. If dont-create is -non-nil, it will not create a mailbox. On success, return a list with + "Copy ARTICLES to MAILBOX on server in BUFFER. +ARTICLES is a string message set. Create mailbox if it doesn't exist, +unless DONT-CREATE is non-nil. On success, return a list with the UIDVALIDITY of the mailbox the article(s) was copied to as the -first element, rest of list contain the saved articles' UIDs." +first element. The rest of list contains the saved articles' UIDs." (when articles (with-current-buffer (or buffer (current-buffer)) (let ((mailbox (imap-utf7-encode mailbox))) @@ -1548,6 +1860,8 @@ first element, rest of list contain the saved articles' UIDs." (or no-copyuid (imap-message-copyuid-1 mailbox))))))) +;; FIXME: Amalgamate with imap-message-copyuid-1, using an extra arg, since it +;; shares most of the code? -- fx (defun imap-message-appenduid-1 (mailbox) (if (imap-capability 'UIDPLUS) (imap-mailbox-get-1 'appenduid mailbox) @@ -1556,7 +1870,7 @@ first element, rest of list contain the saved articles' UIDs." (imap-message-data (make-vector 2 0))) (when (imap-mailbox-examine-1 mailbox) (prog1 - (and (imap-fetch "*" "UID") + (and (imap-fetch-safe '("*" "*:*") "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map (lambda (uid prop) uid) 'UID)))) @@ -1693,7 +2007,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)) @@ -1720,34 +2045,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. @@ -1892,7 +2220,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 @@ -1917,7 +2247,7 @@ Return nil if no complete line has arrived." ;; resp-cond-bye = "BYE" SP resp-text (defun imap-parse-greeting () - "Parse a IMAP greeting." + "Parse an IMAP greeting." (cond ((looking-at "\\* OK ") (setq imap-state 'nonauth)) ((looking-at "\\* PREAUTH ") @@ -1945,7 +2275,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 "(" @@ -1986,6 +2316,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)) @@ -2050,7 +2382,7 @@ Return nil if no complete line has arrived." ;; [flag-perm *(SP flag-perm)] ")" / ;; "READ-ONLY" / ;; "READ-WRITE" / -;; "TRYCREATE" / +;; "TRYCREATE" / ;; "UIDNEXT" SP nz-number / ;; "UIDVALIDITY" SP nz-number / ;; "UNSEEN" SP nz-number / @@ -2104,10 +2436,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) @@ -2270,24 +2602,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 (upcase (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)))))))) + token mailbox) + (read (current-buffer))))))))) ;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE ;; rights) @@ -2325,16 +2665,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 1") (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 2") (imap-forward) (nreverse flag-list))) @@ -2419,7 +2759,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) @@ -2447,7 +2787,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) @@ -2528,7 +2870,7 @@ 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 inserts a SPC between ;; parts in multiparts (when (and (eq (char-after) ?\ ) (eq (char-after (1+ (point))) ?\()) @@ -2543,7 +2885,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)) @@ -2561,22 +2903,28 @@ Return nil if no complete line has arrived." (imap-forward) (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 + ;; Next `or' for Sun SIMS bug. It regards body-fld-enc as a + ;; nstring and returns nil instead of defaulting back to 7BIT ;; as the standard says. + ;; Exchange (2007, at least) does this as well. (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc (imap-forward) - (push (imap-parse-number) body) ;; body-fld-octets + ;; Exchange 2007 can return -1, contrary to the spec... + (if (eq (char-after) ?-) + (progn + (skip-chars-forward "-0-9") + (push nil body)) + (push (imap-parse-number) body)) ;; body-fld-octets - ;; ok, we're done parsing the required parts, what comes now is one - ;; of three things: + ;; 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) @@ -2603,108 +2951,109 @@ 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-ping-server + 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