X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fimap.el;h=294ba76c79e7fafdaa7a708e416b7316d685532a;hb=0651fabaac80cf08698f066dae0af33f29b91a9a;hp=a91b581d1e071efa7ea56eb8490d294a1cc78166;hpb=ac4215f6b5e813696983fb5888fe7fe3db58d46c;p=gnus diff --git a/lisp/imap.el b/lisp/imap.el index a91b581d1..294ba76c7 100644 --- a/lisp/imap.el +++ b/lisp/imap.el @@ -1,5 +1,6 @@ ;;; imap.el --- imap library -;; Copyright (C) 1998,1999 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000 +;; Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Keywords: mail @@ -74,7 +75,9 @@ ;; ;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP ;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342 -;; (NAMESPACE), RFC2359 (UIDPLUS), and the kerberos V4 part of RFC1731 +;; (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. ;; @@ -122,11 +125,13 @@ ;; 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 Cyrus IMAPd 1.6.x `imtest' support in the imtest wrapper ;; ;; Revision history: ;; -;; - this is unreleased software +;; - 19991218 added starttls/digest-md5 patch, +;; by Daiki Ueno +;; NB! you need SLIM for starttls.el and digest-md5.el +;; - 19991023 commited to pgnus ;; ;;; Code: @@ -136,6 +141,12 @@ (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 '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") @@ -145,20 +156,57 @@ ;; User variables. -(defvar imap-imtest-program "imtest -kp %s %p" - "How to call program for Kerberos 4 authentication. -%s is replaced with server and %p with port to connect to. The -program should accept IMAP commands on stdin and return responses to -stdout.") - -(defvar imap-ssl-program '("openssl s_client -ssl3 -connect %s:%p" - "openssl s_client -ssl2 -connect %s:%p" - "s_client -ssl3 -connect %s:%p" - "s_client -ssl2 -connect %s:%p") +(defgroup imap nil + "Low-level IMAP issues." + :group 'mail) + +(defcustom imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s" + "imtest -kp %s %p") + "List of strings containing commands for Kerberos 4 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 +IMAP commands on stdin and return responses to stdout. Each entry in +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") + "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 +IMAP commands on stdin and return responses to stdout. Each entry in +the list is tried until a successful connection is made." + :group 'imap + :type '(repeat string)) + +(defcustom imap-ssl-program '("openssl s_client -ssl3 -connect %s:%p" + "openssl s_client -ssl2 -connect %s:%p" + "s_client -ssl3 -connect %s:%p" + "s_client -ssl2 -connect %s:%p") "A string, or list of strings, containing commands for SSL connections. Within a string, %s is replaced with the server address and %p with port number on server. The program should accept IMAP commands on -stdin and return responses to stdout.") +stdin and return responses to stdout. Each entry in the list is tried +until a successful connection is made." + :group 'imap + :type '(choice string + (repeat string))) + +(defcustom imap-shell-program '("ssh %s imapd" + "rsh %s imapd" + "ssh %g ssh %s imapd" + "rsh %g rsh %s imapd") + "A list of strings, containing commands for IMAP connection. +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 +until a successful connection is made." + :group 'imap + :type '(repeat string)) + +(defvar imap-shell-host "gateway" + "Hostname of rlogin proxy.") (defvar imap-default-user (user-login-name) "Default username to use.") @@ -171,13 +219,16 @@ stdin and return responses to stdout.") (defvar imap-fetch-data-hook nil "Hooks called after receiving each FETCH response.") -(defvar imap-streams '(kerberos4 ssl network) +(defvar imap-streams '(gssapi kerberos4 starttls ssl network shell) "Priority of streams to consider when opening connection to server.") (defvar imap-stream-alist - '((kerberos4 imap-kerberos4s-p imap-kerberos4-open) - (ssl imap-ssl-p imap-ssl-open) - (network imap-network-p imap-network-open)) + '((gssapi imap-gssapi-stream-p imap-gssapi-open) + (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open) + (ssl imap-ssl-p imap-ssl-open) + (network imap-network-p imap-network-open) + (shell imap-shell-p imap-shell-open) + (starttls imap-starttls-p imap-starttls-open)) "Definition of network streams. (NAME CHECK OPEN) @@ -186,14 +237,21 @@ NAME names the stream, CHECK is a function returning non-nil if the server support the stream and OPEN is a function for opening the stream.") -(defvar imap-authenticators '(kerberos4 cram-md5 login anonymous) +(defvar imap-authenticators '(gssapi + kerberos4 + digest-md5 + cram-md5 + login + anonymous) "Priority of authenticators to consider when authenticating to server.") (defvar imap-authenticator-alist - '((kerberos4 imap-kerberos4a-p imap-kerberos4-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)) + '((gssapi imap-gssapi-auth-p imap-gssapi-auth) + (kerberos4 imap-kerberos4-auth-p imap-kerberos4-auth) + (cram-md5 imap-cram-md5-p imap-cram-md5-auth) + (login imap-login-p imap-login-auth) + (anonymous imap-anonymous-p imap-anonymous-auth) + (digest-md5 imap-digest-md5-p imap-digest-md5-auth)) "Definition of authenticators. (NAME CHECK AUTHENTICATE) @@ -202,7 +260,7 @@ NAME names the authenticator. CHECK is a function returning non-nil if the server support the authenticator and AUTHENTICATE is a function for doing the actuall authentification.") -(defvar imap-utf7-p nil +(defvar imap-use-utf7 t "If non-nil, do utf7 encoding/decoding of mailbox names. Since the UTF7 decoding currently only decodes into ISO-8859-1 characters, you may disable this decoding if you need to access UTF7 @@ -233,6 +291,7 @@ encoded mailboxes which doesn't translate into ISO-8859-1.") imap-failed-tags imap-tag imap-process + imap-calculate-literal-size-first imap-mailbox-data)) ;; Internal variables. @@ -243,6 +302,7 @@ encoded mailboxes which doesn't translate into ISO-8859-1.") (defvar imap-port nil) (defvar imap-username nil) (defvar imap-password nil) +(defvar imap-calculate-literal-size-first nil) (defvar imap-state 'closed "IMAP state. Valid states are `closed', `initial', `nonauth', `auth', `selected' @@ -301,10 +361,12 @@ human readable response text (a string).") The actually value is really the text on the continuation line.") (defvar imap-log nil - "Imap session trace.") + "Name of buffer for imap session trace. +For example: (setq imap-log \"*imap-log*\")") (defvar imap-debug nil ;"*imap-debug*" - "Random debug spew.") + "Name of buffer for random debug spew. +For example: (setq imap-debug \"*imap-debug*\")") ;; Utility functions: @@ -331,7 +393,7 @@ If ARGS, PROMPT is used as an argument to `format'." prompt))) (defsubst imap-utf7-encode (string) - (if imap-utf7-p + (if imap-use-utf7 (and string (condition-case () (utf7-encode string t) @@ -342,7 +404,7 @@ If ARGS, PROMPT is used as an argument to `format'." string)) (defsubst imap-utf7-decode (string) - (if imap-utf7-p + (if imap-use-utf7 (and string (condition-case () (utf7-decode string t) @@ -365,46 +427,126 @@ If ARGS, PROMPT is used as an argument to `format'." ;; Server functions; stream stuff: -(defun imap-kerberos4s-p (buffer) +(defun imap-kerberos4-stream-p (buffer) (imap-capability 'AUTH=KERBEROS_V4 buffer)) (defun imap-kerberos4-open (name buffer server port) - (message "Opening Kerberized IMAP connection...") - (let* ((port (or port imap-default-port)) - (coding-system-for-read imap-coding-system-for-read) - (coding-system-for-write imap-coding-system-for-write) - (process (start-process - name buffer shell-file-name shell-command-switch - (format-spec - imap-imtest-program - (format-spec-make ?s server ?p (number-to-string port)))))) - (when process - (with-current-buffer buffer - (setq imap-client-eol "\n") - ;; Result of authentication is a string: __Full privacy protection__ - (while (and (memq (process-status process) '(open run)) - (goto-char (point-min)) - (not (and (imap-parse-greeting) - (re-search-forward "__\\(.*\\)__\n" nil t)))) - (accept-process-output process 1) - (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) - (let ((response (match-string 1))) - (erase-buffer) - (message "Kerberized IMAP connection: %s" response) - (if (and response (let ((case-fold-search nil)) - (not (string-match "failed" response)))) - process - (if (memq (process-status process) '(open run)) - (imap-send-command-wait "LOGOUT")) - (delete-process process) - nil)))))) + (let ((cmds imap-kerberos4-program) + cmd done) + (while (and (not done) (setq cmd (pop cmds))) + (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd) + (erase-buffer) + (let* ((port (or port imap-default-port)) + (coding-system-for-read imap-coding-system-for-read) + (coding-system-for-write imap-coding-system-for-write) + (process (start-process + name buffer shell-file-name shell-command-switch + (format-spec + cmd + (format-spec-make + ?s server + ?p (number-to-string port) + ?l imap-default-user)))) + response) + (when process + (with-current-buffer buffer + (setq imap-client-eol "\n" + imap-calculate-literal-size-first t) + (while (and (memq (process-status process) '(open run)) + (goto-char (point-min)) + ;; cyrus 1.6.x (13? < x <= 22) queries capabilities + (or (while (looking-at "^C:") + (forward-line)) + t) + ;; cyrus 1.6 imtest print "S: " before server greeting + (or (not (looking-at "S: ")) + (forward-char 3) + t) + (not (and (imap-parse-greeting) + ;; success in imtest < 1.6: + (or (re-search-forward + "^__\\(.*\\)__\n" nil t) + ;; success in imtest 1.6: + (re-search-forward + "^\\(Authenticat.*\\)" nil t)) + (setq response (match-string 1))))) + (accept-process-output process 1) + (sit-for 1)) + (and imap-log + (with-current-buffer (get-buffer-create imap-log) + (imap-disable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (insert-buffer-substring buffer))) + (erase-buffer) + (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd + (if response (concat "done, " response) "failed")) + (if (and response (let ((case-fold-search nil)) + (not (string-match "failed" response)))) + (setq done process) + (if (memq (process-status process) '(open run)) + (imap-send-command-wait "LOGOUT")) + (delete-process process) + nil))))) + done)) +(defun imap-gssapi-stream-p (buffer) + (imap-capability 'AUTH=GSSAPI buffer)) + +(defun imap-gssapi-open (name buffer server port) + (let ((cmds imap-gssapi-program) + cmd done) + (while (and (not done) (setq cmd (pop cmds))) + (message "Opening GSSAPI IMAP connection with `%s'..." cmd) + (let* ((port (or port imap-default-port)) + (coding-system-for-read imap-coding-system-for-read) + (coding-system-for-write imap-coding-system-for-write) + (process (start-process + name buffer shell-file-name shell-command-switch + (format-spec + cmd + (format-spec-make + ?s server + ?p (number-to-string port) + ?l imap-default-user)))) + response) + (when process + (with-current-buffer buffer + (setq imap-client-eol "\n") + (while (and (memq (process-status process) '(open run)) + (goto-char (point-min)) + ;; cyrus 1.6.x (13? < x <= 22) queries capabilities + (or (while (looking-at "^C:") + (forward-line)) + t) + ;; cyrus 1.6 imtest print "S: " before server greeting + (or (not (looking-at "S: ")) + (forward-char 3) + t) + (not (and (imap-parse-greeting) + ;; success in imtest 1.6: + (re-search-forward + "^\\(Authenticat.*\\)" nil t) + (setq response (match-string 1))))) + (accept-process-output process 1) + (sit-for 1)) + (and imap-log + (with-current-buffer (get-buffer-create imap-log) + (imap-disable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (insert-buffer-substring buffer))) + (erase-buffer) + (message "GSSAPI IMAP connection: %s" (or response "failed")) + (if (and response (let ((case-fold-search nil)) + (not (string-match "failed" response)))) + (setq done process) + (if (memq (process-status process) '(open run)) + (imap-send-command-wait "LOGOUT")) + (delete-process process) + nil))))) + done)) + (defun imap-ssl-p (buffer) nil) @@ -448,7 +590,7 @@ If ARGS, PROMPT is used as an argument to `format'." (progn (message "imap: Opening SSL connection with `%s'...done" cmd) done) - (message "imap: Failed opening SSL connection") + (message "imap: Opening SSL connection with `%s'...failed" cmd) nil))) (defun imap-network-p (buffer) @@ -473,6 +615,92 @@ If ARGS, PROMPT is used as an argument to `format'." (insert-buffer-substring buffer))) (when (memq (process-status process) '(open run)) process)))) + +(defun imap-shell-p (buffer) + nil) + +(defun imap-shell-open (name buffer server port) + (let ((cmds imap-shell-program) + cmd done) + (while (and (not done) (setq cmd (pop cmds))) + (message "imap: Opening IMAP connection with `%s'..." cmd) + (setq imap-client-eol "\n") + (let* ((port (or port imap-default-port)) + (coding-system-for-read imap-coding-system-for-read) + (coding-system-for-write imap-coding-system-for-write) + (process (start-process + name buffer shell-file-name shell-command-switch + (format-spec + cmd + (format-spec-make + ?s server + ?g imap-shell-host + ?p (number-to-string port) + ?l imap-default-user))))) + (when process + (while (and (memq (process-status process) '(open run)) + (goto-char (point-min)) + (not (imap-parse-greeting))) + (accept-process-output process 1) + (sit-for 1)) + (erase-buffer) + (and imap-log + (with-current-buffer (get-buffer-create imap-log) + (imap-disable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (insert-buffer-substring buffer))) + (when (memq (process-status process) '(open run)) + (setq done process))))) + (if done + (progn + (message "imap: Opening IMAP connection with `%s'...done" cmd) + done) + (message "imap: Opening IMAP connection with `%s'...failed" cmd) + nil))) + +(defun imap-starttls-p (buffer) + (and (imap-capability 'STARTTLS buffer) + (condition-case () + (progn + (require 'starttls) + (call-process "starttls")) + (error nil)))) + +(defun imap-starttls-open (name buffer server port) + (let* ((port (or port imap-default-port)) + (coding-system-for-read imap-coding-system-for-read) + (coding-system-for-write imap-coding-system-for-write) + (process (starttls-open-stream name buffer server port)) + done) + (message "imap: Connecting with STARTTLS...") + (when process + (while (and (memq (process-status process) '(open run)) + (goto-char (point-min)) + (not (imap-parse-greeting))) + (accept-process-output process 1) + (sit-for 1)) + (and imap-log + (with-current-buffer (get-buffer-create imap-log) + (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)) + (setq done process))) + (if done + (progn + (message "imap: Connecting with STARTTLS...done") + done) + (message "imap: Connecting with STARTTLS...failed") + nil))) ;; Server functions; authenticator stuff: @@ -514,10 +742,20 @@ Returns t if login was successful, nil otherwise." ;; passwd nil)))) ret))) -(defun imap-kerberos4a-p (buffer) +(defun imap-gssapi-auth-p (buffer) + (imap-capability 'AUTH=GSSAPI buffer)) + +(defun imap-gssapi-auth (buffer) + (message "imap: Authenticating using GSSAPI...%s" + (if (eq imap-stream 'gssapi) "done" "failed")) + (eq imap-stream 'gssapi)) + +(defun imap-kerberos4-auth-p (buffer) (imap-capability 'AUTH=KERBEROS_V4 buffer)) (defun imap-kerberos4-auth (buffer) + (message "imap: Authenticating using Kerberos 4...%s" + (if (eq imap-stream 'kerberos4) "done" "failed")) (eq imap-stream 'kerberos4)) (defun imap-cram-md5-p (buffer) @@ -525,25 +763,33 @@ Returns t if login was successful, nil otherwise." (defun imap-cram-md5-auth (buffer) "Login to server using the AUTH CRAM-MD5 method." - (imap-interactive-login - buffer - (lambda (user passwd) - (imap-ok-p - (imap-send-command-wait - (list - "AUTHENTICATE CRAM-MD5" - (lambda (challenge) - (let* ((decoded (base64-decode-string challenge)) - (hash (rfc2104-hash 'md5 64 16 passwd decoded)) - (response (concat user " " hash)) - (encoded (base64-encode-string response))) - encoded)))))))) + (message "imap: Authenticating using CRAM-MD5...") + (let ((done (imap-interactive-login + buffer + (lambda (user passwd) + (imap-ok-p + (imap-send-command-wait + (list + "AUTHENTICATE CRAM-MD5" + (lambda (challenge) + (let* ((decoded (base64-decode-string challenge)) + (hash (rfc2104-hash 'md5 64 16 passwd decoded)) + (response (concat user " " hash)) + (encoded (base64-encode-string response))) + encoded))))))))) + (if done + (message "imap: Authenticating using CRAM-MD5...done") + (message "imap: Authenticating using CRAM-MD5...failed")))) + + (defun imap-login-p (buffer) - (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))) + (and (not (imap-capability 'LOGINDISABLED buffer)) + (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))) (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 @@ -554,11 +800,45 @@ Returns t if login was successful, nil otherwise." t) (defun imap-anonymous-auth (buffer) + (message "imap: Loging in anonymously...") (with-current-buffer buffer (imap-ok-p (imap-send-command-wait (concat "LOGIN anonymous \"" (concat (user-login-name) "@" (system-name)) "\""))))) +(defun imap-digest-md5-p (buffer) + (and (imap-capability 'AUTH=DIGEST-MD5 buffer) + (condition-case () + (require 'digest-md5) + (error nil)))) + +(defun imap-digest-md5-auth (buffer) + "Login to server using the AUTH DIGEST-MD5 method." + (message "imap: Authenticating using DIGEST-MD5...") + (imap-interactive-login + buffer + (lambda (user passwd) + (let ((tag + (imap-send-command + (list + "AUTHENTICATE DIGEST-MD5" + (lambda (challenge) + (digest-md5-parse-digest-challenge + (base64-decode-string challenge)) + (let* ((digest-uri + (digest-md5-digest-uri + "imap" (digest-md5-challenge 'realm))) + (response + (digest-md5-digest-response + user passwd digest-uri))) + (base64-encode-string response 'no-line-break)))) + ))) + (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) + nil + (setq imap-continuation nil) + (imap-send-command-1 "") + (imap-ok-p (imap-wait-for-tag tag))))))) + ;; Server functions: (defun imap-open-1 (buffer) @@ -605,37 +885,44 @@ necessery. If nil, the buffer name is generated." (setq imap-port (or port imap-port)) (setq imap-auth (or auth imap-auth)) (setq imap-stream (or stream imap-stream)) - (when (let ((imap-stream (or imap-stream imap-default-stream))) - (imap-open-1 buffer)) - ;; Choose stream. - (let (stream-changed) - (when (null imap-stream) - (let ((streams imap-streams)) - (while (setq stream (pop streams)) - (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer) - (setq stream-changed (not (eq (or imap-stream - imap-default-stream) - stream)) - imap-stream stream - streams nil))) - (unless imap-stream - (error "Couldn't figure out a stream for server")))) - (when stream-changed - (message "Reconnecting with %s..." imap-stream) - (imap-close buffer) - (imap-open-1 buffer) - (setq imap-capability nil))) - (if (imap-opened buffer) - ;; Choose authenticator - (when (null imap-auth) - (let ((auths imap-authenticators)) - (while (setq auth (pop auths)) - (if (funcall (nth 1 (assq auth imap-authenticator-alist)) - buffer) - (setq imap-auth auth - auths nil))) - (unless imap-auth - (error "Couldn't figure out authenticator for server")))))) + (message "imap: Connecting to %s..." imap-server) + (if (let ((imap-stream (or imap-stream imap-default-stream))) + (imap-open-1 buffer)) + ;; Choose stream. + (let (stream-changed) + (message "imap: Connecting to %s...done" imap-server) + (when (null imap-stream) + (let ((streams imap-streams)) + (while (setq stream (pop streams)) + (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer) + (setq stream-changed (not (eq (or imap-stream + imap-default-stream) + stream)) + imap-stream stream + streams nil))) + (unless imap-stream + (error "Couldn't figure out a stream for server")))) + (when stream-changed + (message "imap: Reconnecting with stream `%s'..." imap-stream) + (imap-close buffer) + (if (imap-open-1 buffer) + (message "imap: Reconnecting with stream `%s'...done" + imap-stream) + (message "imap: Reconnecting with stream `%s'...failed" + imap-stream)) + (setq imap-capability nil)) + (if (imap-opened buffer) + ;; Choose authenticator + (when (and (null imap-auth) (not (eq imap-state 'auth))) + (let ((auths imap-authenticators)) + (while (setq auth (pop auths)) + (if (funcall (nth 1 (assq auth imap-authenticator-alist)) + buffer) + (setq imap-auth auth + auths nil))) + (unless imap-auth + (error "Couldn't figure out authenticator for server")))))) + (message "imap: Connecting to %s...failed" imap-server)) (when (imap-opened buffer) (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)) buffer))) @@ -657,7 +944,10 @@ user and optionally stored in the buffer. If USER and/or PASSWD is specified, the user will not be questioned and the username and/or password is remembered in the buffer." (with-current-buffer (or buffer (current-buffer)) - (when (eq imap-state 'nonauth) + (if (not (eq imap-state 'nonauth)) + (or (eq imap-state 'auth) + (eq imap-state 'select) + (eq imap-state 'examine)) (make-variable-buffer-local 'imap-username) (make-variable-buffer-local 'imap-password) (if user (setq imap-username user)) @@ -779,6 +1069,10 @@ If EXAMINE is non-nil, do a read-only select." (imap-utf7-decode (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine)))) +(defun imap-mailbox-examine-1 (mailbox &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (imap-mailbox-select-1 mailbox 'exmine))) + (defun imap-mailbox-examine (mailbox &optional buffer) "Examine MAILBOX on server in BUFFER." (imap-mailbox-select mailbox 'exmine buffer)) @@ -925,9 +1219,9 @@ returned, if ITEMS is a symbol only it's value is returned." (list items)))))) (if (listp items) (mapcar (lambda (item) - (imap-mailbox-get-1 item mailbox)) + (imap-mailbox-get item mailbox)) items) - (imap-mailbox-get-1 items mailbox))))) + (imap-mailbox-get items mailbox))))) (defun imap-mailbox-acl-get (&optional mailbox buffer) "Get ACL on mailbox from server in BUFFER." @@ -976,6 +1270,18 @@ returned, if ITEMS is a symbol only it's value is returned." (list list)) ",")) +(defun imap-range-to-message-set (range) + (mapconcat + (lambda (item) + (if (consp item) + (format "%d:%d" + (car item) (cdr item)) + (format "%d" item))) + (if (and (listp range) (not (listp (cdr range)))) + (list range) ;; make (1 . 2) into ((1 . 2)) + range) + ",")) + (defun imap-fetch-asynch (uids props &optional nouidfetch buffer) (with-current-buffer (or buffer (current-buffer)) (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ") @@ -1117,7 +1423,7 @@ is non-nil return theese properties." (let ((old-mailbox imap-current-mailbox) (state imap-state) (imap-message-data (make-vector 2 0))) - (when (imap-mailbox-examine mailbox) + (when (imap-mailbox-examine-1 mailbox) (prog1 (and (imap-fetch "*" "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) @@ -1158,7 +1464,7 @@ first element, rest of list contain the saved articles' UIDs." (let ((old-mailbox imap-current-mailbox) (state imap-state) (imap-message-data (make-vector 2 0))) - (when (imap-mailbox-examine mailbox) + (when (imap-mailbox-examine-1 mailbox) (prog1 (and (imap-fetch "*" "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) @@ -1189,10 +1495,10 @@ on failure." "Return number of lines in article by looking at the mime bodystructure BODY." (if (listp body) (if (stringp (car body)) - (cond ((and (string= (car body) "TEXT") + (cond ((and (string= (upcase (car body)) "TEXT") (numberp (nth 7 body))) (nth 7 body)) - ((and (string= (car body) "MESSAGE") + ((and (string= (upcase (car body)) "MESSAGE") (numberp (nth 9 body))) (nth 9 body)) (t 0)) @@ -1232,9 +1538,21 @@ on failure." (cond ((stringp cmd) (setq cmdstr (concat cmdstr cmd))) ((bufferp cmd) - (setq cmdstr - (concat cmdstr (format "{%d}" (with-current-buffer cmd - (buffer-size))))) + (let ((eol imap-client-eol) + (calcfirst imap-calculate-literal-size-first) + size) + (with-current-buffer cmd + (if calcfirst + (setq size (buffer-size))) + (when (not (equal eol "\r\n")) + ;; XXX modifies buffer! + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match eol))) + (if (not calcfirst) + (setq size (buffer-size)))) + (setq cmdstr + (concat cmdstr (format "{%d}" size)))) (unwind-protect (progn (imap-send-command-1 cmdstr) @@ -1242,13 +1560,9 @@ on failure." (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) (setq command nil);; abort command if no cont-req (let ((process imap-process) - (stream imap-stream)) + (stream imap-stream) + (eol imap-client-eol)) (with-current-buffer cmd - (when (eq stream 'kerberos4) - ;; XXX modifies buffer! - (goto-char (point-min)) - (while (search-forward "\r\n" nil t) - (replace-match "\n"))) (and imap-log (with-current-buffer (get-buffer-create imap-log) @@ -1360,7 +1674,7 @@ Return nil if no complete line has arrived." (if (< (point-max) (+ pos len)) nil (goto-char (+ pos len)) - (buffer-substring-no-properties pos (+ pos len)))))) + (buffer-substring pos (+ pos len)))))) ;; string = quoted / literal ;; @@ -1374,13 +1688,20 @@ Return nil if no complete line has arrived." ;; TEXT-CHAR = (defsubst imap-parse-string () - (let (strstart strend) - (cond ((and (eq (char-after) ?\") - (setq strstart (point)) - (setq strend (search-forward "\"" nil t 2))) - (buffer-substring-no-properties (1+ strstart) (1- strend))) - ((eq (char-after) ?{) - (imap-parse-literal))))) + (cond ((eq (char-after) ?\") + (forward-char 1) + (let ((p (point)) (name "")) + (skip-chars-forward "^\"\\\\") + (setq name (buffer-substring p (point))) + (while (eq (char-after) ?\\) + (setq p (1+ (point))) + (forward-char 2) + (skip-chars-forward "^\"\\\\") + (setq name (concat name (buffer-substring p (point))))) + (forward-char 1) + name)) + ((eq (char-after) ?{) + (imap-parse-literal)))) ;; nil = "NIL" @@ -1891,12 +2212,15 @@ Return nil if no complete line has arrived." ;; ; revisions of this specification. (defun imap-parse-flag-list () - (let ((str (buffer-substring-no-properties - (point) (search-forward ")" nil t))) - pos) - (while (setq pos (string-match "\\\\" str (and pos (+ 2 pos)))) - (setq str (replace-match "\\\\" nil t str))) - (mapcar 'symbol-name (read str)))) + (let (flag-list start) + (assert (eq (char-after) ?\()) + (while (and (not (eq (char-after) ?\))) + (setq start (progn (imap-forward) (point))) + (> (skip-chars-forward "^ )" (gnus-point-at-eol)) 0)) + (push (buffer-substring start (point)) flag-list)) + (assert (eq (char-after) ?\))) + (imap-forward) + (nreverse flag-list))) ;; envelope = "(" env-date SP env-subject SP env-from SP env-sender SP ;; env-reply-to SP env-to SP env-cc SP env-bcc SP @@ -1954,7 +2278,10 @@ Return nil if no complete line has arrived." (imap-forward) (while (setq str (imap-parse-string)) (push str strlist) - (imap-forward)) + ;; buggy stalker communigate pro 3.0 doesn't print SPC + ;; between body-fld-param's sometimes + (or (eq (char-after) ?\") + (imap-forward))) (nreverse strlist))) ((imap-parse-nil) nil))) @@ -2085,6 +2412,11 @@ 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 + ;; parts in multiparts + (when (and (eq (char-after) ?\ ) + (eq (char-after (1+ (point))) ?\()) + (imap-forward)) (push subbody body)) (imap-forward) (push (imap-parse-string) body);; media-subtype @@ -2113,7 +2445,10 @@ Return nil if no complete line has arrived." (imap-forward) (push (imap-parse-nstring) body);; body-fld-desc (imap-forward) - (push (imap-parse-string) body);; body-fld-enc + ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a + ;; nstring and return NIL instead of defaulting back to 7BIT + ;; as the standard says. + (push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc (imap-forward) (push (imap-parse-number) body);; body-fld-octets @@ -2134,12 +2469,16 @@ Return nil if no complete line has arrived." (push (imap-parse-envelope) body);; envelope (imap-forward) (push (imap-parse-body) body);; body - (imap-forward) - (push (imap-parse-number) body));; body-fld-lines - ((setq lines (imap-parse-number));; body-type-text: - (push lines body));; body-fld-lines + ;; buggy stalker communigate pro 3.0 doesn't print + ;; number of lines in message/rfc822 attachment + (if (eq (char-after) ?\)) + (push 0 body) + (imap-forward) + (push (imap-parse-number) body))) ;; body-fld-lines + ((setq lines (imap-parse-number)) ;; body-type-text: + (push lines body)) ;; body-fld-lines (t - (backward-char)))));; no match... + (backward-char))))) ;; no match... ;; ...and then parse the third one here... @@ -2193,6 +2532,7 @@ Return nil if no complete line has arrived." imap-current-mailbox-p imap-mailbox-select-1 imap-mailbox-select + imap-mailbox-examine-1 imap-mailbox-examine imap-mailbox-unselect imap-mailbox-expunge