X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fimap.el;h=7ae1df3f5c7902cd91a78f7a295596174825ecf5;hb=7416a4ac9f2a5ba4dc6320f42be6ec96b02645c7;hp=7aff9c511e570fa823a592c7d4384f4186194890;hpb=14682e69b4f47ddb035d26206578a9ffd0dc7755;p=gnus diff --git a/lisp/imap.el b/lisp/imap.el index 7aff9c511..7ae1df3f5 100644 --- a/lisp/imap.el +++ b/lisp/imap.el @@ -44,7 +44,7 @@ ;; ;; Mailbox commands: ;; -;; imap-mailbox-get, imap-mailbox-map, imap-current-mailbox, +;; imap-mailbox-get, imap-mailbox-map, imap-current-mailbox, ;; imap-current-mailbox-p, imap-search, imap-mailbox-select, ;; imap-mailbox-examine, imap-mailbox-unselect, imap-mailbox-expunge ;; imap-mailbox-close, imap-mailbox-create, imap-mailbox-delete @@ -57,7 +57,7 @@ ;; imap-fetch-asynch, imap-fetch, ;; imap-current-message, imap-list-to-message-set, ;; imap-message-get, imap-message-map -;; imap-message-envelope-date, imap-message-envelope-subject, +;; imap-message-envelope-date, imap-message-envelope-subject, ;; imap-message-envelope-from, imap-message-envelope-sender, ;; imap-message-envelope-reply-to, imap-message-envelope-to, ;; imap-message-envelope-cc, imap-message-envelope-bcc @@ -75,11 +75,11 @@ ;; ;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP ;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342 -;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS) -;; (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. +;; (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. ;; ;; Without the work of John McClary Prevost and Jim Radford this library ;; would not have seen the light of day. Many thanks. @@ -120,7 +120,7 @@ ;; => "X-Sieve: cmu-sieve 1.3^M\nX-Username: ^M\r...." ;; ;; Todo: -;; +;; ;; o Parse UIDs as strings? We need to overcome the 28 bit limit somehow. ;; o Don't use `read' at all (important places already fixed) ;; o Accept list of articles instead of message set string in most @@ -152,31 +152,75 @@ (autoload 'utf7-encode "utf7") (autoload 'utf7-decode "utf7") (autoload 'format-spec "format-spec") - (autoload 'format-spec-make "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))))) ;; User variables. -(defvar imap-kerberos4-program '("imtest -m kerberos_v4 -u %l -p %p %s" - "imtest -kp %s %p") +(defgroup imap nil + "Low-level IMAP issues." + :version "21.1" + :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.") +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)) -(defvar imap-gssapi-program '("imtest -m gssapi -u %l -p %p %s") +(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.") - -(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") +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 -quiet -ssl3 -connect %s:%p" + "openssl s_client -quiet -ssl2 -connect %s:%p" + "s_client -quiet -ssl3 -connect %s:%p" + "s_client -quiet -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)) + +(defcustom imap-process-connection-type nil + "*Value for `process-connection-type' to use for Kerberos4 and GSSAPI." + :group 'imap + :type 'boolean) + +(defvar imap-shell-host "gateway" + "Hostname of rlogin proxy.") (defvar imap-default-user (user-login-name) "Default username to use.") @@ -189,7 +233,7 @@ stdin and return responses to stdout.") (defvar imap-fetch-data-hook nil "Hooks called after receiving each FETCH response.") -(defvar imap-streams '(gssapi kerberos4 starttls 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 @@ -197,6 +241,7 @@ stdin and return responses to stdout.") (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. @@ -206,7 +251,7 @@ NAME names the stream, CHECK is a function returning non-nil if the server support the stream and OPEN is a function for opening the stream.") -(defvar imap-authenticators '(gssapi +(defvar imap-authenticators '(gssapi kerberos4 digest-md5 cram-md5 @@ -214,8 +259,8 @@ stream.") anonymous) "Priority of authenticators to consider when authenticating to server.") -(defvar imap-authenticator-alist - '((gssapi imap-gssapi-auth-p imap-gssapia-auth) +(defvar imap-authenticator-alist + '((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) @@ -260,6 +305,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. @@ -270,7 +316,8 @@ encoded mailboxes which doesn't translate into ISO-8859-1.") (defvar imap-port nil) (defvar imap-username nil) (defvar imap-password nil) -(defvar imap-state 'closed +(defvar imap-calculate-literal-size-first nil) +(defvar imap-state 'closed "IMAP state. Valid states are `closed', `initial', `nonauth', `auth', `selected' and `examine'.") @@ -311,7 +358,7 @@ and `examine'.") (defvar imap-reached-tag 0 "Lower limit on command tags that have been parsed.") -(defvar imap-failed-tags nil +(defvar imap-failed-tags nil "Alist of tags that failed. Each element is a list with four elements; tag (a integer), response state (a symbol, `OK', `NO' or `BAD'), response code (a string), and @@ -328,10 +375,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: @@ -362,7 +411,7 @@ If ARGS, PROMPT is used as an argument to `format'." (and string (condition-case () (utf7-encode string t) - (error (message + (error (message "imap: Could not UTF7 encode `%s', using it unencoded..." string) string))) @@ -400,10 +449,12 @@ If ARGS, PROMPT is used as an argument to `format'." 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 + (process-connection-type imap-process-connection-type) + (process (start-process name buffer shell-file-name shell-command-switch (format-spec cmd @@ -414,14 +465,16 @@ If ARGS, PROMPT is used as an argument to `format'." response) (when process (with-current-buffer buffer - (setq imap-client-eol "\n") + (setq imap-client-eol "\n" + imap-calculate-literal-size-first t) (while (and (memq (process-status process) '(open run)) + (set-buffer buffer) ;; XXX "blue moon" nntp.el bug (goto-char (point-min)) - ;; cyrus 1.6.x (13? < x <= 22) queries capabilities + ;; 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 + ;; cyrus 1.6 imtest print "S: " before server greeting (or (not (looking-at "S: ")) (forward-char 3) t) @@ -442,7 +495,8 @@ If ARGS, PROMPT is used as an argument to `format'." (goto-char (point-max)) (insert-buffer-substring buffer))) (erase-buffer) - (message "Kerberos 4 IMAP connection: %s" (or response "failed")) + (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) @@ -451,7 +505,7 @@ If ARGS, PROMPT is used as an argument to `format'." (delete-process process) nil))))) done)) - + (defun imap-gssapi-stream-p (buffer) (imap-capability 'AUTH=GSSAPI buffer)) @@ -463,7 +517,8 @@ If ARGS, PROMPT is used as an argument to `format'." (let* ((port (or port imap-default-port)) (coding-system-for-read imap-coding-system-for-read) (coding-system-for-write imap-coding-system-for-write) - (process (start-process + (process-connection-type imap-process-connection-type) + (process (start-process name buffer shell-file-name shell-command-switch (format-spec cmd @@ -474,10 +529,16 @@ If ARGS, PROMPT is used as an argument to `format'." response) (when process (with-current-buffer buffer - (setq imap-client-eol "\n") + (setq imap-client-eol "\n" + imap-calculate-literal-size-first t) (while (and (memq (process-status process) '(open run)) + (set-buffer buffer) ;; XXX "blue moon" nntp.el bug (goto-char (point-min)) - ;; cyrus 1.6 imtest print "S: " before server greeting + ;; 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) @@ -513,6 +574,7 @@ If ARGS, PROMPT is used as an argument to `format'." (let ((cmds (if (listp imap-ssl-program) imap-ssl-program (list imap-ssl-program))) cmd done) + (ignore-errors (require 'ssl)) (while (and (not done) (setq cmd (pop cmds))) (message "imap: Opening SSL connection with `%s'..." cmd) (let* ((port (or port imap-default-ssl-port)) @@ -530,6 +592,7 @@ If ARGS, PROMPT is used as an argument to `format'." (with-current-buffer buffer (goto-char (point-min)) (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))) @@ -548,7 +611,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) @@ -561,6 +624,7 @@ If ARGS, PROMPT is used as an argument to `format'." (process (open-network-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-min)) (not (imap-parse-greeting))) (accept-process-output process 1) @@ -574,19 +638,68 @@ If ARGS, PROMPT is used as an argument to `format'." (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)) + (set-buffer buffer) ;; XXX "blue moon" nntp.el bug + (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) + (imap-disable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (insert-buffer-substring buffer))) + (erase-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 (condition-case () - (require 'starttls) - (error nil)) - (imap-capability 'STARTTLS 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))) + (process (starttls-open-stream name buffer server port)) + done) + (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)) (not (imap-parse-greeting))) (accept-process-output process 1) @@ -605,8 +718,14 @@ If ARGS, PROMPT is used as an argument to `format'." (starttls-negotiate imap-process))) (set-process-filter imap-process nil))) (when (memq (process-status process) '(open run)) - process)))) - + (setq done process))) + (if done + (progn + (message "imap: Connecting with STARTTLS...done") + done) + (message "imap: Connecting with STARTTLS...failed") + nil))) + ;; Server functions; authenticator stuff: (defun imap-interactive-login (buffer loginfunc) @@ -615,18 +734,18 @@ LOGINFUNC is passed a username and a password, it should return t if it where sucessful authenticating itself to the server, nil otherwise. Returns t if login was successful, nil otherwise." (with-current-buffer buffer - (make-variable-buffer-local 'imap-username) - (make-variable-buffer-local 'imap-password) + (make-local-variable 'imap-username) + (make-local-variable 'imap-password) (let (user passwd ret) ;; (condition-case () (while (or (not user) (not passwd)) (setq user (or imap-username - (read-from-minibuffer + (read-from-minibuffer (concat "IMAP username for " imap-server ": ") (or user imap-default-user)))) (setq passwd (or imap-password (imap-read-passwd - (concat "IMAP password for " user "@" + (concat "IMAP password for " user "@" imap-server ": ")))) (when (and user passwd) (if (funcall loginfunc user passwd) @@ -648,15 +767,33 @@ Returns t if login was successful, nil otherwise." ret))) (defun imap-gssapi-auth-p (buffer) - (imap-capability 'AUTH=GSSAPI buffer)) + (and (imap-capability 'AUTH=GSSAPI buffer) + (catch 'imtest-found + (let (prg (prgs imap-gssapi-program)) + (while (setq prg (pop prgs)) + (condition-case () + (and (call-process (substring prg 0 (string-match " " prg))) + (throw 'imtest-found t)) + (error nil))))))) (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)) + (and (imap-capability 'AUTH=KERBEROS_V4 buffer) + (catch 'imtest-found + (let (prg (prgs imap-kerberos4-program)) + (while (setq prg (pop prgs)) + (condition-case () + (and (call-process (substring prg 0 (string-match " " prg))) + (throw 'imtest-found t)) + (error nil))))))) (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) @@ -664,52 +801,60 @@ 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." - (imap-interactive-login buffer + (message "imap: Plaintext authentication...") + (imap-interactive-login buffer (lambda (user passwd) - (imap-ok-p (imap-send-command-wait - (concat "LOGIN \"" user "\" \"" + (imap-ok-p (imap-send-command-wait + (concat "LOGIN \"" user "\" \"" passwd "\"")))))) (defun imap-anonymous-p (buffer) t) (defun imap-anonymous-auth (buffer) + (message "imap: Loging in anonymously...") (with-current-buffer buffer (imap-ok-p (imap-send-command-wait - (concat "LOGIN anonymous \"" (concat (user-login-name) "@" + (concat "LOGIN anonymous \"" (concat (user-login-name) "@" (system-name)) "\""))))) (defun imap-digest-md5-p (buffer) - (and (condition-case () + (and (imap-capability 'AUTH=DIGEST-MD5 buffer) + (condition-case () (require 'digest-md5) - (error nil)) - (imap-capability 'AUTH=DIGEST-MD5 buffer))) + (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 + (let ((tag (imap-send-command (list "AUTHENTICATE DIGEST-MD5" @@ -717,10 +862,10 @@ Returns t if login was successful, nil otherwise." (digest-md5-parse-digest-challenge (base64-decode-string challenge)) (let* ((digest-uri - (digest-md5-digest-uri + (digest-md5-digest-uri "imap" (digest-md5-challenge 'realm))) (response - (digest-md5-digest-response + (digest-md5-digest-response user passwd digest-uri))) (base64-encode-string response 'no-line-break)))) ))) @@ -739,7 +884,7 @@ Returns t if login was successful, nil otherwise." imap-current-message nil imap-state 'initial imap-process (condition-case () - (funcall (nth 2 (assq imap-stream + (funcall (nth 2 (assq imap-stream imap-stream-alist)) "imap" buffer imap-server imap-port) ((error quit) nil))) @@ -769,44 +914,51 @@ necessery. If nil, the buffer name is generated." (with-current-buffer (get-buffer-create buffer) (if (imap-opened buffer) (imap-close buffer)) - (mapcar 'make-variable-buffer-local imap-local-variables) + (mapcar 'make-local-variable imap-local-variables) (imap-disable-multibyte) (buffer-disable-undo) (setq imap-server (or server imap-server)) (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))) @@ -828,9 +980,12 @@ 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) - (make-variable-buffer-local 'imap-username) - (make-variable-buffer-local 'imap-password) + (if (not (eq imap-state 'nonauth)) + (or (eq imap-state 'auth) + (eq imap-state 'select) + (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 (funcall (nth 2 (assq imap-auth imap-authenticator-alist)) buffer) @@ -900,7 +1055,7 @@ If BUFFER is nil, the current buffer is assumed." (defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer) (with-current-buffer (or buffer (current-buffer)) (let (result) - (mapatoms + (mapatoms (lambda (s) (push (funcall func (if mailbox-decoder (funcall mailbox-decoder (symbol-name s)) @@ -936,7 +1091,7 @@ If EXAMINE is non-nil, do a read-only select." imap-current-mailbox (setq imap-current-mailbox mailbox) (if (imap-ok-p (imap-send-command-wait - (concat (if examine "EXAMINE" "SELECT") " \"" + (concat (if examine "EXAMINE" "SELECT") " \"" mailbox "\""))) (progn (setq imap-message-data (make-vector imap-message-prime 0) @@ -945,9 +1100,9 @@ If EXAMINE is non-nil, do a read-only select." ;; Failed SELECT/EXAMINE unselects current mailbox (setq imap-current-mailbox nil)))) -(defun imap-mailbox-select (mailbox &optional examine buffer) +(defun imap-mailbox-select (mailbox &optional examine buffer) (with-current-buffer (or buffer (current-buffer)) - (imap-utf7-decode + (imap-utf7-decode (imap-mailbox-select-1 (imap-utf7-encode mailbox) examine)))) (defun imap-mailbox-examine-1 (mailbox &optional buffer) @@ -964,7 +1119,7 @@ If EXAMINE is non-nil, do a read-only select." (when (or (eq imap-state 'auth) (and (imap-capability 'UNSELECT) (imap-ok-p (imap-send-command-wait "UNSELECT"))) - (and (imap-ok-p + (and (imap-ok-p (imap-send-command-wait (concat "EXAMINE \"" imap-current-mailbox "\""))) @@ -1019,7 +1174,7 @@ If BUFFER is nil the current buffer is assumed." (imap-send-command-wait (list "RENAME \"" oldname "\" " "\"" newname "\"")))))) -(defun imap-mailbox-lsub (&optional root reference add-delimiter buffer) +(defun imap-mailbox-lsub (&optional root reference add-delimiter buffer) "Return a list of subscribed mailboxes on server in BUFFER. If ROOT is non-nil, only list matching mailboxes. If ADD-DELIMITER is non-nil, a hierarchy delimiter is added to root. REFERENCE is a @@ -1033,7 +1188,7 @@ implementation-specific string that has to be passed to lsub command." (imap-mailbox-map-1 (lambda (mailbox) (imap-mailbox-put 'lsub nil mailbox))) (when (imap-ok-p - (imap-send-command-wait + (imap-send-command-wait (concat "LSUB \"" reference "\" \"" (imap-utf7-encode root) (and add-delimiter (imap-mailbox-get-1 'delimiter root)) "%\""))) @@ -1057,7 +1212,7 @@ passed to list command." (imap-mailbox-map-1 (lambda (mailbox) (imap-mailbox-put 'list nil mailbox))) (when (imap-ok-p - (imap-send-command-wait + (imap-send-command-wait (concat "LIST \"" reference "\" \"" (imap-utf7-encode root) (and add-delimiter (imap-mailbox-get-1 'delimiter root)) "%\""))) @@ -1071,7 +1226,7 @@ passed to list command." "Send the SUBSCRIBE command on the mailbox to server in BUFFER. Returns non-nil if successful." (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \"" + (imap-ok-p (imap-send-command-wait (concat "SUBSCRIBE \"" (imap-utf7-encode mailbox) "\""))))) @@ -1079,7 +1234,7 @@ Returns non-nil if successful." "Send the SUBSCRIBE command on the mailbox to server in BUFFER. Returns non-nil if successful." (with-current-buffer (or buffer (current-buffer)) - (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE " + (imap-ok-p (imap-send-command-wait (concat "UNSUBSCRIBE " (imap-utf7-encode mailbox) "\""))))) @@ -1090,13 +1245,13 @@ 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." (with-current-buffer (or buffer (current-buffer)) - (when (imap-ok-p + (when (imap-ok-p (imap-send-command-wait (list "STATUS \"" (imap-utf7-encode mailbox) "\" " (format "%s" (if (listp items) - items + items (list items)))))) (if (listp items) (mapcar (lambda (item) @@ -1151,6 +1306,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 ") @@ -1164,7 +1331,7 @@ returned, if ITEMS is a symbol only it's value is returned." UIDS can be a string, number or a list of numbers. If RECEIVE is non-nil return theese properties." (with-current-buffer (or buffer (current-buffer)) - (when (imap-ok-p (imap-send-command-wait + (when (imap-ok-p (imap-send-command-wait (format "%sFETCH %s %s" (if nouidfetch "" "UID ") (if (listp uids) (imap-list-to-message-set uids) @@ -1181,7 +1348,7 @@ is non-nil return theese properties." (imap-message-get uid receive))) uids) (imap-message-get uids receive)))))) - + (defun imap-message-put (uid propname value &optional buffer) (with-current-buffer (or buffer (current-buffer)) (if imap-message-data @@ -1321,12 +1488,15 @@ first element, rest of list contain the saved articles' UIDs." (if (imap-ok-p (imap-send-command-wait cmd)) t (when (and (not dont-create) - (imap-mailbox-get-1 'trycreate mailbox)) - (imap-mailbox-create-1 mailbox) + ;; removed because of buggy Oracle server + ;; that doesn't send TRYCREATE tags (which + ;; is a MUST according to specifications): + ;;(imap-mailbox-get-1 'trycreate mailbox) + (imap-mailbox-create-1 mailbox)) (imap-ok-p (imap-send-command-wait cmd))))) (or no-copyuid (imap-message-copyuid-1 mailbox))))))) - + (defun imap-message-appenduid-1 (mailbox) (if (imap-capability 'UIDPLUS) (imap-mailbox-get-1 'appenduid mailbox) @@ -1355,16 +1525,15 @@ on failure." (let ((mailbox (imap-utf7-encode mailbox))) (with-current-buffer (or buffer (current-buffer)) (and (let ((imap-current-target-mailbox mailbox)) - (imap-ok-p - (imap-send-command-wait + (imap-ok-p + (imap-send-command-wait (list "APPEND \"" mailbox "\" " article)))) (imap-message-appenduid-1 mailbox))))) - + (defun imap-body-lines (body) "Return number of lines in article by looking at the mime bodystructure BODY." (if (listp body) (if (stringp (car body)) - ;; upcase for bug in courier imap server (cond ((and (string= (upcase (car body)) "TEXT") (numberp (nth 7 body))) (nth 7 body)) @@ -1380,8 +1549,8 @@ on failure." (and from (concat (aref from 0) (if (aref from 0) " <") - (aref from 2) - "@" + (aref from 2) + "@" (aref from 3) (if (aref from 0) ">")))) @@ -1408,24 +1577,31 @@ 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) (setq cmdstr nil) (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - (setq command nil);; abort command if no cont-req + (setq command nil) ;; abort command if no cont-req (let ((process imap-process) (stream imap-stream) (eol imap-client-eol)) (with-current-buffer cmd - (when (not (equal eol "\r\n")) - ;; XXX modifies buffer! - (goto-char (point-min)) - (while (search-forward "\r\n" nil t) - (replace-match eol))) (and imap-log (with-current-buffer (get-buffer-create imap-log) @@ -1442,7 +1618,7 @@ on failure." (setq cmdstr nil) (unwind-protect (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE)) - (setq command nil);; abort command if no cont-req + (setq command nil) ;; abort command if no cont-req (setq command (cons (funcall cmd imap-continuation) command))) (setq imap-continuation nil))) @@ -1455,14 +1631,19 @@ on failure." (defun imap-wait-for-tag (tag &optional buffer) (with-current-buffer (or buffer (current-buffer)) (while (and (null imap-continuation) + (memq (process-status imap-process) '(open run)) (< imap-reached-tag tag)) - (or (and (not (memq (process-status imap-process) '(open run))) - (sit-for 1)) - (accept-process-output imap-process 1))) - (or (assq tag imap-failed-tags) - (if imap-continuation - 'INCOMPLETE - 'OK)))) + (let ((len (/ (point-max) 1024)) + message-log-max) + (unless (< len 10) + (message "imap read: %dk" len)) + (accept-process-output imap-process 1))) + (message "") + (and (memq (process-status imap-process) '(open run)) + (or (assq tag imap-failed-tags) + (if imap-continuation + 'INCOMPLETE + 'OK))))) (defun imap-sentinel (process string) (delete-process process)) @@ -1507,7 +1688,7 @@ Return nil if no complete line has arrived." (eq imap-state 'examine)) (imap-parse-response)) (t - (message "Unknown state %s in arrival filter" + (message "Unknown state %s in arrival filter" imap-state))) (delete-region (point-min) (point-max)))))))) @@ -1594,7 +1775,7 @@ Return nil if no complete line has arrived." (defsubst imap-parse-astring () (or (imap-parse-string) - (buffer-substring (point) + (buffer-substring (point) (if (re-search-forward "[(){ \r\n%*\"\\]" nil t) (goto-char (1- (match-end 0))) (end-of-line) @@ -1654,7 +1835,7 @@ Return nil if no complete line has arrived." (when (eq (char-after) ?\)) (imap-forward) (nreverse addresses))) - (assert (imap-parse-nil)))) + (assert (imap-parse-nil) t "In imap-parse-address-list"))) ;; mailbox = "INBOX" / astring ;; ; INBOX is case-insensitive. All case variants of @@ -1740,11 +1921,11 @@ Return nil if no complete line has arrived." (FLAGS (imap-mailbox-put 'flags (imap-parse-flag-list))) (LIST (imap-parse-data-list 'list)) (LSUB (imap-parse-data-list 'lsub)) - (SEARCH (imap-mailbox-put - 'search + (SEARCH (imap-mailbox-put + 'search (read (concat "(" (buffer-substring (point) (point-max)) ")")))) (STATUS (imap-parse-status)) - (CAPABILITY (setq imap-capability + (CAPABILITY (setq imap-capability (read (concat "(" (upcase (buffer-substring (point) (point-max))) ")")))) @@ -1774,7 +1955,7 @@ Return nil if no complete line has arrived." (search-forward "]"))) (imap-forward)) (setq text (buffer-substring (point) (point-max))) - (push (list token status code text) + (push (list token status code text) imap-failed-tags)))) (BAD (progn (setq imap-reached-tag (max imap-reached-tag token)) @@ -1802,14 +1983,14 @@ Return nil if no complete line has arrived." ;; resp-text-code = "ALERT" / ;; "BADCHARSET [SP "(" astring *(SP astring) ")" ] / -;; "NEWNAME" SP string SP string / +;; "NEWNAME" SP string SP string / ;; "PARSE" / -;; "PERMANENTFLAGS" SP "(" +;; "PERMANENTFLAGS" SP "(" ;; [flag-perm *(SP flag-perm)] ")" / -;; "READ-ONLY" / -;; "READ-WRITE" / +;; "READ-ONLY" / +;; "READ-WRITE" / ;; "TRYCREATE" / -;; "UIDNEXT" SP nz-number / +;; "UIDNEXT" SP nz-number / ;; "UIDVALIDITY" SP nz-number / ;; "UNSEEN" SP nz-number / ;; resp-text-atom [SP 1*] @@ -1828,7 +2009,7 @@ Return nil if no complete line has arrived." ;; ; delimits between two numbers inclusive. ;; ; Example: 2,4:7,9,12:* is 2,4,5,6,7,9,12,13, ;; ; 14,15 for a mailbox with 15 messages. -;; +;; ;; sequence-num = nz-number / "*" ;; ; * is the largest number in use. For message ;; ; sequence numbers, it is the number of messages @@ -1855,6 +2036,9 @@ Return nil if no complete line has arrived." ;; resp-text-atom = 1* (defun imap-parse-resp-text-code () + ;; xxx next line for stalker communigate pro 3.3.1 bug + (when (looking-at " \\[") + (imap-forward)) (when (eq (char-after) ?\[) (imap-forward) (cond ((search-forward "PERMANENTFLAGS " nil t) @@ -1926,18 +2110,18 @@ Return nil if no complete line has arrived." ;; "BODY" ["STRUCTURE"] SPACE body / ;; "BODY" section ["<" number ">"] SPACE nstring / ;; "UID" SPACE uniqueid) ")" -;; +;; ;; date_time ::= <"> date_day_fixed "-" date_month "-" date_year ;; SPACE time SPACE zone <"> -;; +;; ;; section ::= "[" [section_text / (nz_number *["." nz_number] ;; ["." (section_text / "MIME")])] "]" -;; +;; ;; section_text ::= "HEADER" / "HEADER.FIELDS" [".NOT"] ;; SPACE header_list / "TEXT" -;; +;; ;; header_fld_name ::= astring -;; +;; ;; header_list ::= "(" 1#header_fld_name ")" (defsubst imap-parse-header-list () @@ -1950,7 +2134,7 @@ Return nil if no complete line has arrived." (nreverse strlist)))) (defsubst imap-parse-fetch-body-section () - (let ((section + (let ((section (buffer-substring (point) (1- (re-search-forward "[] ]" nil t))))) (if (eq (char-before) ? ) (prog1 @@ -1960,7 +2144,7 @@ Return nil if no complete line has arrived." (defun imap-parse-fetch (response) (when (eq (char-after) ?\() - (let (uid flags envelope internaldate rfc822 rfc822header rfc822text + (let (uid flags envelope internaldate rfc822 rfc822header rfc822text rfc822size body bodydetail bodystructure) (while (not (eq (char-after) ?\))) (imap-forward) @@ -2012,7 +2196,7 @@ Return nil if no complete line has arrived." ;; mailbox-data = ... ;; "STATUS" SP mailbox SP "(" -;; [status-att SP number +;; [status-att SP number ;; *(SP status-att SP number)] ")" ;; ... ;; @@ -2037,7 +2221,7 @@ Return nil if no complete line has arrived." ((eq token 'UNSEEN) (imap-mailbox-put 'unseen (read (current-buffer)) mailbox)) (t - (message "Unknown status data %s in mailbox %s ignored" + (message "Unknown status data %s in mailbox %s ignored" token mailbox)))))))) ;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE @@ -2075,11 +2259,19 @@ Return nil if no complete line has arrived." ;; ; revisions of this specification. (defun imap-parse-flag-list () - (let ((str (buffer-substring (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) ?\() t "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)) + (push (buffer-substring start (point)) flag-list)) + (assert (eq (char-after) ?\)) t "In imap-parse-flag-list") + (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 @@ -2108,36 +2300,39 @@ Return nil if no complete line has arrived." (defun imap-parse-envelope () (when (eq (char-after) ?\() (imap-forward) - (vector (prog1 (imap-parse-nstring);; date + (vector (prog1 (imap-parse-nstring) ;; date (imap-forward)) - (prog1 (imap-parse-nstring);; subject + (prog1 (imap-parse-nstring) ;; subject (imap-forward)) - (prog1 (imap-parse-address-list);; from + (prog1 (imap-parse-address-list) ;; from (imap-forward)) - (prog1 (imap-parse-address-list);; sender + (prog1 (imap-parse-address-list) ;; sender (imap-forward)) - (prog1 (imap-parse-address-list);; reply-to + (prog1 (imap-parse-address-list) ;; reply-to (imap-forward)) - (prog1 (imap-parse-address-list);; to + (prog1 (imap-parse-address-list) ;; to (imap-forward)) - (prog1 (imap-parse-address-list);; cc + (prog1 (imap-parse-address-list) ;; cc (imap-forward)) - (prog1 (imap-parse-address-list);; bcc + (prog1 (imap-parse-address-list) ;; bcc (imap-forward)) - (prog1 (imap-parse-nstring);; in-reply-to + (prog1 (imap-parse-nstring) ;; in-reply-to (imap-forward)) - (prog1 (imap-parse-nstring);; message-id + (prog1 (imap-parse-nstring) ;; message-id (imap-forward))))) ;; body-fld-param = "(" string SP string *(SP string SP string) ")" / nil (defsubst imap-parse-string-list () - (cond ((eq (char-after) ?\();; body-fld-param + (cond ((eq (char-after) ?\() ;; body-fld-param (let (strlist str) (imap-forward) (while (setq str (imap-parse-string)) (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))) @@ -2159,7 +2354,7 @@ Return nil if no complete line has arrived." (while (eq (char-after) ?\ ) (imap-forward) (push (imap-parse-body-extension) b-e)) - (assert (eq (char-after) ?\))) + (assert (eq (char-after) ?\)) t "In imap-parse-body-extension") (imap-forward) (nreverse b-e)) (or (imap-parse-number) @@ -2177,7 +2372,7 @@ Return nil if no complete line has arrived." (defsubst imap-parse-body-ext () (let (ext) - (when (eq (char-after) ?\ );; body-fld-dsp + (when (eq (char-after) ?\ ) ;; body-fld-dsp (imap-forward) (let (dsp) (if (eq (char-after) ?\() @@ -2187,14 +2382,14 @@ Return nil if no complete line has arrived." (imap-forward) (push (imap-parse-string-list) dsp) (imap-forward)) - (assert (imap-parse-nil))) + (assert (imap-parse-nil) t "In imap-parse-body-ext")) (push (nreverse dsp) ext)) - (when (eq (char-after) ?\ );; body-fld-lang + (when (eq (char-after) ?\ ) ;; body-fld-lang (imap-forward) (if (eq (char-after) ?\() (push (imap-parse-string-list) ext) (push (imap-parse-nstring) ext)) - (while (eq (char-after) ?\ );; body-extension + (while (eq (char-after) ?\ ) ;; body-extension (imap-forward) (setq ext (append (imap-parse-body-extension) ext))))) ext)) @@ -2268,77 +2463,89 @@ 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 - (when (eq (char-after) ?\ );; body-ext-mpart: + (push (imap-parse-string) body) ;; media-subtype + (when (eq (char-after) ?\ ) ;; body-ext-mpart: (imap-forward) - (if (eq (char-after) ?\();; body-fld-param + (if (eq (char-after) ?\() ;; body-fld-param (push (imap-parse-string-list) body) (push (and (imap-parse-nil) nil) body)) (setq body - (append (imap-parse-body-ext) body)));; body-ext-... - (assert (eq (char-after) ?\))) + (append (imap-parse-body-ext) body))) ;; body-ext-... + (assert (eq (char-after) ?\)) t "In imap-parse-body") (imap-forward) (nreverse body)) - (push (imap-parse-string) body);; media-type + (push (imap-parse-string) body) ;; media-type (imap-forward) - (push (imap-parse-string) body);; media-subtype + (push (imap-parse-string) body) ;; media-subtype (imap-forward) ;; next line for Sun SIMS bug (and (eq (char-after) ? ) (imap-forward)) - (if (eq (char-after) ?\();; body-fld-param + (if (eq (char-after) ?\() ;; body-fld-param (push (imap-parse-string-list) body) (push (and (imap-parse-nil) nil) body)) (imap-forward) - (push (imap-parse-nstring) body);; body-fld-id + (push (imap-parse-nstring) body) ;; body-fld-id (imap-forward) - (push (imap-parse-nstring) body);; body-fld-desc + (push (imap-parse-nstring) body) ;; body-fld-desc (imap-forward) - (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 + (push (imap-parse-number) body) ;; body-fld-octets - ;; ok, we're done parsing the required parts, what comes now is one + ;; ok, we're done parsing the required parts, what comes now is one ;; of three things: ;; ;; envelope (then we're parsing body-type-msg) ;; body-fld-lines (then we're parsing body-type-text) ;; body-ext-1part (then we're parsing body-type-basic) ;; - ;; the problem is that the two first are in turn optionally followed - ;; by the third. So we parse the first two here (if there are any)... + ;; the problem is that the two first are in turn optionally followed +;; by the third. So we parse the first two here (if there are any)... (when (eq (char-after) ?\ ) (imap-forward) (let (lines) - (cond ((eq (char-after) ?\();; body-type-msg: - (push (imap-parse-envelope) body);; envelope + (cond ((eq (char-after) ?\() ;; body-type-msg: + (push (imap-parse-envelope) body) ;; envelope (imap-forward) - (push (imap-parse-body) body);; body - (imap-forward) - (push (imap-parse-number) body));; body-fld-lines - ((setq lines (imap-parse-number));; body-type-text: - (push lines body));; body-fld-lines + (push (imap-parse-body) body) ;; body + ;; buggy stalker communigate pro 3.0 doesn't print + ;; number of lines in message/rfc822 attachment + (if (eq (char-after) ?\)) + (push 0 body) + (imap-forward) + (push (imap-parse-number) body))) ;; body-fld-lines + ((setq lines (imap-parse-number)) ;; body-type-text: + (push lines body)) ;; body-fld-lines (t - (backward-char)))));; no match... + (backward-char))))) ;; no match... ;; ...and then parse the third one here... - (when (eq (char-after) ?\ );; body-ext-1part: + (when (eq (char-after) ?\ ) ;; body-ext-1part: (imap-forward) - (push (imap-parse-nstring) body);; body-fld-md5 - (setq body (append (imap-parse-body-ext) body)));; body-ext-1part.. - - (assert (eq (char-after) ?\))) + (push (imap-parse-nstring) body) ;; body-fld-md5 + (setq body (append (imap-parse-body-ext) body))) ;; body-ext-1part.. + + (assert (eq (char-after) ?\)) t "In imap-parse-body 2") (imap-forward) (nreverse body))))) (when imap-debug ; (untrace-all) (require 'trace) (buffer-disable-undo (get-buffer-create imap-debug)) - (mapcar (lambda (f) (trace-function-background f imap-debug)) + (mapcar (lambda (f) (trace-function-background f imap-debug)) '( imap-read-passwd imap-utf7-encode @@ -2432,7 +2639,7 @@ Return nil if no complete line has arrived." imap-parse-body-extension imap-parse-body ))) - + (provide 'imap) ;;; imap.el ends here