X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fimap.el;h=4413fb57d9ba6eb2c75c7fcd68ac0a7661fc3a5c;hb=9aa0784067bd2f658fe4515bdb6f0a61853158af;hp=7ae1df3f5c7902cd91a78f7a295596174825ecf5;hpb=eb8ceb34709e3cea55aa2b6d7e9540e32f548841;p=gnus diff --git a/lisp/imap.el b/lisp/imap.el index 7ae1df3f5..4413fb57d 100644 --- a/lisp/imap.el +++ b/lisp/imap.el @@ -1,5 +1,5 @@ ;;; imap.el --- imap library -;; Copyright (C) 1998, 1999, 2000 +;; Copyright (C) 1998, 1999, 2000, 2001, 2002 ;; Free Software Foundation, Inc. ;; Author: Simon Josefsson @@ -219,14 +219,33 @@ until a successful connection is made." :group 'imap :type 'boolean) -(defvar imap-shell-host "gateway" - "Hostname of rlogin proxy.") +(defcustom imap-use-utf7 t + "If non-nil, do utf7 encoding/decoding of mailbox names. +Since the UTF7 decoding currently only decodes into ISO-8859-1 +characters, you may disable this decoding if you need to access UTF7 +encoded mailboxes which doesn't translate into ISO-8859-1." + :group 'imap + :type 'boolean) -(defvar imap-default-user (user-login-name) - "Default username to use.") +(defcustom imap-log nil + "If non-nil, a imap session trace is placed in *imap-log* buffer." + :group 'imap + :type 'boolean) -(defvar imap-error nil - "Error codes from the last command.") +(defcustom imap-debug nil + "If non-nil, random debug spews are placed in *imap-debug* buffer." + :group 'imap + :type 'boolean) + +(defcustom imap-shell-host "gateway" + "Hostname of rlogin proxy." + :group 'imap + :type 'string) + +(defcustom imap-default-user (user-login-name) + "Default username to use." + :group 'imap + :type 'string) ;; Various variables. @@ -245,7 +264,7 @@ until a successful connection is made." (starttls imap-starttls-p imap-starttls-open)) "Definition of network streams. -(NAME CHECK OPEN) +\(NAME CHECK OPEN) NAME names the stream, CHECK is a function returning non-nil if the server support the stream and OPEN is a function for opening the @@ -268,17 +287,14 @@ stream.") (digest-md5 imap-digest-md5-p imap-digest-md5-auth)) "Definition of authenticators. -(NAME CHECK AUTHENTICATE) +\(NAME CHECK AUTHENTICATE) NAME names the authenticator. CHECK is a function returning non-nil if the server support the authenticator and AUTHENTICATE is a function -for doing the actuall authentification.") +for doing the actual authentication.") -(defvar imap-use-utf7 t - "If non-nil, do utf7 encoding/decoding of mailbox names. -Since the UTF7 decoding currently only decodes into ISO-8859-1 -characters, you may disable this decoding if you need to access UTF7 -encoded mailboxes which doesn't translate into ISO-8859-1.") +(defvar imap-error nil + "Error codes from the last command.") ;; Internal constants. Change theese and die. @@ -307,6 +323,8 @@ encoded mailboxes which doesn't translate into ISO-8859-1.") imap-process imap-calculate-literal-size-first imap-mailbox-data)) +(defconst imap-log-buffer "*imap-log*") +(defconst imap-debug-buffer "*imap-debug*") ;; Internal variables. @@ -372,19 +390,28 @@ human readable response text (a string).") (defvar imap-continuation nil "Non-nil indicates that the server emitted a continuation request. -The actually value is really the text on the continuation line.") - -(defvar imap-log nil - "Name of buffer for imap session trace. -For example: (setq imap-log \"*imap-log*\")") +The actual value is really the text on the continuation line.") -(defvar imap-debug nil ;"*imap-debug*" - "Name of buffer for random debug spew. -For example: (setq imap-debug \"*imap-debug*\")") +(defvar imap-callbacks nil + "List of response tags and callbacks, on the form `(number . function)'. +The function should take two arguments, the first the IMAP tag and the +second the status (OK, NO, BAD etc) of the command.") ;; Utility functions: +(defun imap-remassoc (key alist) + "Delete by side effect any elements of LIST whose car is `equal' to KEY. +The modified LIST is returned. If the first member +of LIST has a car that is `equal' to KEY, there is no way to remove it +by side effect; therefore, write `(setq foo (remassoc key foo))' to be +sure of changing the value of `foo'." + (when alist + (if (equal key (caar alist)) + (cdr alist) + (setcdr alist (imap-remassoc key (cdr alist))) + alist))) + (defsubst imap-disable-multibyte () "Enable multibyte in the current buffer." (when (fboundp 'set-buffer-multibyte) @@ -470,11 +497,11 @@ If ARGS, PROMPT is used as an argument to `format'." (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug (goto-char (point-min)) - ;; cyrus 1.6.x (13? < x <= 22) queries capabilities + ;; 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) @@ -489,7 +516,7 @@ If ARGS, PROMPT is used as an argument to `format'." (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -501,7 +528,7 @@ If ARGS, PROMPT is used as an argument to `format'." (not (string-match "failed" response)))) (setq done process) (if (memq (process-status process) '(open run)) - (imap-send-command-wait "LOGOUT")) + (imap-send-command "LOGOUT")) (delete-process process) nil))))) done)) @@ -534,11 +561,11 @@ If ARGS, PROMPT is used as an argument to `format'." (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug (goto-char (point-min)) - ;; cyrus 1.6.x (13? < x <= 22) queries capabilities + ;; 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) @@ -550,7 +577,7 @@ If ARGS, PROMPT is used as an argument to `format'." (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -561,7 +588,7 @@ If ARGS, PROMPT is used as an argument to `format'." (not (string-match "failed" response)))) (setq done process) (if (memq (process-status process) '(open run)) - (imap-send-command-wait "LOGOUT")) + (imap-send-command "LOGOUT")) (delete-process process) nil))))) done)) @@ -574,7 +601,9 @@ 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)) + (condition-case () + (require 'ssl) + (error)) (while (and (not done) (setq cmd (pop cmds))) (message "imap: Opening SSL connection with `%s'..." cmd) (let* ((port (or port imap-default-ssl-port)) @@ -587,8 +616,9 @@ If ARGS, PROMPT is used as an argument to `format'." ?s server ?p (number-to-string port))))) process) - (when (setq process (ignore-errors (open-ssl-stream - name buffer server port))) + (when (setq process (condition-case () + (open-ssl-stream name buffer server port) + (error))) (with-current-buffer buffer (goto-char (point-min)) (while (and (memq (process-status process) '(open run)) @@ -599,7 +629,7 @@ If ARGS, PROMPT is used as an argument to `format'." (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -630,7 +660,7 @@ If ARGS, PROMPT is used as an argument to `format'." (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -642,7 +672,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) @@ -662,12 +693,13 @@ If ARGS, PROMPT is used as an argument to `format'." (when process (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug - (goto-char (point-min)) + (goto-char (point-max)) + (forward-line -1) (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -683,12 +715,7 @@ If ARGS, PROMPT is used as an argument to `format'." nil))) (defun imap-starttls-p (buffer) - (and (imap-capability 'STARTTLS buffer) - (condition-case () - (progn - (require 'starttls) - (call-process "starttls")) - (error nil)))) + (imap-capability 'STARTTLS buffer)) (defun imap-starttls-open (name buffer server port) (let* ((port (or port imap-default-port)) @@ -705,7 +732,7 @@ If ARGS, PROMPT is used as an argument to `format'." (accept-process-output process 1) (sit-for 1)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (buffer-disable-undo) (goto-char (point-max)) (insert-buffer-substring buffer))) @@ -731,7 +758,7 @@ If ARGS, PROMPT is used as an argument to `format'." (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) @@ -741,12 +768,15 @@ 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 (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 @@ -768,13 +798,7 @@ Returns t if login was successful, nil otherwise." (defun imap-gssapi-auth-p (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))))))) + (eq imap-stream 'gssapi))) (defun imap-gssapi-auth (buffer) (message "imap: Authenticating using GSSAPI...%s" @@ -783,13 +807,7 @@ Returns t if login was successful, nil otherwise." (defun imap-kerberos4-auth-p (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))))))) + (eq imap-stream 'kerberos4))) (defun imap-kerberos4-auth (buffer) (message "imap: Authenticating using Kerberos 4...%s" @@ -836,7 +854,7 @@ Returns t if login was successful, nil otherwise." 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) "@" @@ -909,7 +927,7 @@ 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) @@ -922,46 +940,53 @@ necessery. If nil, the buffer name is generated." (setq imap-auth (or auth imap-auth)) (setq imap-stream (or stream imap-stream)) (message "imap: Connecting to %s..." imap-server) - (if (let ((imap-stream (or imap-stream imap-default-stream))) - (imap-open-1 buffer)) - ;; Choose stream. - (let (stream-changed) - (message "imap: Connecting to %s...done" imap-server) - (when (null imap-stream) - (let ((streams imap-streams)) - (while (setq stream (pop streams)) - (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer) - (setq stream-changed (not (eq (or imap-stream - imap-default-stream) - stream)) - imap-stream stream - streams nil))) - (unless imap-stream - (error "Couldn't figure out a stream for server")))) - (when stream-changed - (message "imap: Reconnecting with stream `%s'..." imap-stream) - (imap-close buffer) - (if (imap-open-1 buffer) - (message "imap: Reconnecting with stream `%s'...done" - imap-stream) - (message "imap: Reconnecting with stream `%s'...failed" - imap-stream)) - (setq imap-capability nil)) - (if (imap-opened buffer) - ;; Choose authenticator - (when (and (null imap-auth) (not (eq imap-state 'auth))) - (let ((auths imap-authenticators)) - (while (setq auth (pop auths)) - (if (funcall (nth 1 (assq auth imap-authenticator-alist)) - buffer) - (setq imap-auth auth - auths nil))) - (unless imap-auth - (error "Couldn't figure out authenticator for server")))))) - (message "imap: Connecting to %s...failed" imap-server)) - (when (imap-opened buffer) - (setq imap-mailbox-data (make-vector imap-mailbox-prime 0)) - buffer))) + (if (null (let ((imap-stream (or imap-stream imap-default-stream))) + (imap-open-1 buffer))) + (progn + (message "imap: Connecting to %s...failed" imap-server) + nil) + (when (null imap-stream) + ;; Need to choose stream. + (let ((streams imap-streams)) + (while (setq stream (pop streams)) + ;; OK to use this stream? + (when (funcall (nth 1 (assq stream imap-stream-alist)) buffer) + ;; Stream changed? + (if (not (eq imap-default-stream stream)) + (with-current-buffer (get-buffer-create + (generate-new-buffer-name " *temp*")) + (mapcar 'make-local-variable imap-local-variables) + (imap-disable-multibyte) + (buffer-disable-undo) + (setq imap-server (or server imap-server)) + (setq imap-port (or port imap-port)) + (setq imap-auth (or auth imap-auth)) + (message "imap: Reconnecting with stream `%s'..." stream) + (if (null (let ((imap-stream stream)) + (imap-open-1 (current-buffer)))) + (progn + (kill-buffer (current-buffer)) + (message + "imap: Reconnecting with stream `%s'...failed" + stream)) + ;; We're done, kill the first connection + (imap-close buffer) + (kill-buffer buffer) + (rename-buffer buffer) + (message "imap: Reconnecting with stream `%s'...done" + stream) + (setq imap-stream stream) + (setq imap-capability nil) + (setq streams nil))) + ;; We're done + (message "imap: Connecting to %s...done" imap-server) + (setq imap-stream stream) + (setq imap-capability nil) + (setq streams nil)))))) + (when (imap-opened buffer) + (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))) + (when imap-stream + buffer)))) (defun imap-opened (&optional buffer) "Return non-nil if connection to imap server in BUFFER is open. @@ -988,16 +1013,36 @@ password is remembered in the buffer." (make-local-variable 'imap-password) (if user (setq imap-username user)) (if passwd (setq imap-password passwd)) - (if (funcall (nth 2 (assq imap-auth imap-authenticator-alist)) buffer) - (setq imap-state 'auth))))) + (if imap-auth + (and (funcall (nth 2 (assq imap-auth + imap-authenticator-alist)) buffer) + (setq imap-state 'auth)) + ;; Choose authenticator. + (let ((auths imap-authenticators) + auth) + (while (setq auth (pop auths)) + ;; OK to use authenticator? + (when (funcall (nth 1 (assq auth imap-authenticator-alist)) buffer) + (message "imap: Authenticating to `%s' using `%s'..." + imap-server auth) + (setq imap-auth auth) + (if (funcall (nth 2 (assq auth imap-authenticator-alist)) buffer) + (progn + (message "imap: Authenticating to `%s' using `%s'...done" + imap-server auth) + (setq auths nil)) + (message "imap: Authenticating to `%s' using `%s'...failed" + imap-server auth))))) + imap-state)))) (defun imap-close (&optional buffer) "Close connection to server in BUFFER. If BUFFER is nil, the current buffer is used." (with-current-buffer (or buffer (current-buffer)) - (and (imap-opened) - (not (imap-ok-p (imap-send-command-wait "LOGOUT"))) - (message "Server %s didn't let me log out" imap-server)) + (when (imap-opened) + (condition-case nil + (imap-send-command-wait "LOGOUT") + (quit nil))) (when (and imap-process (memq (process-status imap-process) '(open run))) (delete-process imap-process)) @@ -1107,11 +1152,11 @@ If EXAMINE is non-nil, do a read-only select." (defun imap-mailbox-examine-1 (mailbox &optional buffer) (with-current-buffer (or buffer (current-buffer)) - (imap-mailbox-select-1 mailbox 'exmine))) + (imap-mailbox-select-1 mailbox 'examine))) (defun imap-mailbox-examine (mailbox &optional buffer) "Examine MAILBOX on server in BUFFER." - (imap-mailbox-select mailbox 'exmine buffer)) + (imap-mailbox-select mailbox 'examine buffer)) (defun imap-mailbox-unselect (&optional buffer) "Close current folder in BUFFER, without expunging articles." @@ -1129,22 +1174,38 @@ If EXAMINE is non-nil, do a read-only select." imap-state 'auth) t))) -(defun imap-mailbox-expunge (&optional buffer) +(defun imap-mailbox-expunge (&optional asynch buffer) "Expunge articles in current folder in BUFFER. +If ASYNCH, do not wait for succesful completion of the command. If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) (when (and imap-current-mailbox (not (eq imap-state 'examine))) - (imap-ok-p (imap-send-command-wait "EXPUNGE"))))) + (if asynch + (imap-send-command "EXPUNGE") + (imap-ok-p (imap-send-command-wait "EXPUNGE")))))) -(defun imap-mailbox-close (&optional buffer) +(defun imap-mailbox-close (&optional asynch buffer) "Expunge articles and close current folder in BUFFER. +If ASYNCH, do not wait for succesful completion of the command. If BUFFER is nil the current buffer is assumed." (with-current-buffer (or buffer (current-buffer)) - (when (and imap-current-mailbox - (imap-ok-p (imap-send-command-wait "CLOSE"))) - (setq imap-current-mailbox nil - imap-message-data nil - imap-state 'auth) + (when imap-current-mailbox + (if asynch + (imap-add-callback (imap-send-command "CLOSE") + `(lambda (tag status) + (message "IMAP mailbox `%s' closed... %s" + imap-current-mailbox status) + (when (eq ,imap-current-mailbox + imap-current-mailbox) + ;; Don't wipe out data if another mailbox + ;; was selected... + (setq imap-current-mailbox nil + imap-message-data nil + imap-state 'auth)))) + (when (imap-ok-p (imap-send-command-wait "CLOSE")) + (setq imap-current-mailbox nil + imap-message-data nil + imap-state 'auth))) t))) (defun imap-mailbox-create-1 (mailbox) @@ -1259,6 +1320,20 @@ returned, if ITEMS is a symbol only it's value is returned." items) (imap-mailbox-get items mailbox))))) +(defun imap-mailbox-status-asynch (mailbox items &optional buffer) + "Send status item request ITEM on MAILBOX to server in BUFFER. +ITEMS can be a symbol or a list of symbols, valid symbols are one of +the STATUS data items -- ie 'messages, 'recent, 'uidnext, 'uidvalidity +or 'unseen. The IMAP command tag is returned." + (with-current-buffer (or buffer (current-buffer)) + (imap-send-command (list "STATUS \"" + (imap-utf7-encode mailbox) + "\" " + (format "%s" + (if (listp items) + items + (list items))))))) + (defun imap-mailbox-acl-get (&optional mailbox buffer) "Get ACL on mailbox from server in BUFFER." (let ((mailbox (imap-utf7-encode mailbox))) @@ -1422,7 +1497,9 @@ is non-nil return theese properties." (imap-mailbox-put 'search 'dummy) (when (imap-ok-p (imap-send-command-wait (concat "UID SEARCH " predicate))) (if (eq (imap-mailbox-get-1 'search imap-current-mailbox) 'dummy) - (error "Missing SEARCH response to a SEARCH command") + (progn + (message "Missing SEARCH response to a SEARCH command (server not RFC compliant)...") + nil) (imap-mailbox-get-1 'search imap-current-mailbox))))) (defun imap-message-flag-permanent-p (flag &optional mailbox buffer) @@ -1557,10 +1634,13 @@ on failure." ;; Internal functions. +(defun imap-add-callback (tag func) + (setq imap-callbacks (append (list (cons tag func)) imap-callbacks))) + (defun imap-send-command-1 (cmdstr) (setq cmdstr (concat cmdstr imap-client-eol)) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -1604,7 +1684,7 @@ on failure." (with-current-buffer cmd (and imap-log (with-current-buffer (get-buffer-create - imap-log) + imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -1630,20 +1710,23 @@ 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)) - (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))))) + (let (imap-have-messaged) + (while (and (null imap-continuation) + (memq (process-status imap-process) '(open run)) + (< imap-reached-tag tag)) + (let ((len (/ (point-max) 1024)) + message-log-max) + (unless (< len 10) + (setq imap-have-messaged t) + (message "imap read: %dk" len)) + (accept-process-output imap-process 1))) + (when imap-have-messaged + (message "")) + (and (memq (process-status imap-process) '(open run)) + (or (assq tag imap-failed-tags) + (if imap-continuation + 'INCOMPLETE + 'OK)))))) (defun imap-sentinel (process string) (delete-process process)) @@ -1667,7 +1750,7 @@ Return nil if no complete line has arrived." (goto-char (point-max)) (insert string) (and imap-log - (with-current-buffer (get-buffer-create imap-log) + (with-current-buffer (get-buffer-create imap-log-buffer) (imap-disable-multibyte) (buffer-disable-undo) (goto-char (point-max)) @@ -1786,21 +1869,21 @@ Return nil if no complete line has arrived." ;; ;; addr-adl = nstring ;; ; Holds route from [RFC-822] route-addr if -;; ; non-NIL +;; ; non-nil ;; ;; addr-host = nstring -;; ; NIL indicates [RFC-822] group syntax. +;; ; nil indicates [RFC-822] group syntax. ;; ; Otherwise, holds [RFC-822] domain name ;; ;; addr-mailbox = nstring -;; ; NIL indicates end of [RFC-822] group; if -;; ; non-NIL and addr-host is NIL, holds +;; ; nil indicates end of [RFC-822] group; if +;; ; non-nil and addr-host is nil, holds ;; ; [RFC-822] group name. ;; ; Otherwise, holds [RFC-822] local-part ;; ; after removing [RFC-822] quoting ;; ;; addr-name = nstring -;; ; If non-NIL, holds phrase from [RFC-822] +;; ; If non-nil, holds phrase from [RFC-822] ;; ; mailbox after removing [RFC-822] quoting ;; @@ -1888,7 +1971,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 "(" @@ -1926,9 +2009,9 @@ Return nil if no complete line has arrived." (read (concat "(" (buffer-substring (point) (point-max)) ")")))) (STATUS (imap-parse-status)) (CAPABILITY (setq imap-capability - (read (concat "(" (upcase (buffer-substring - (point) (point-max))) - ")")))) + (read (concat "(" (upcase (buffer-substring + (point) (point-max))) + ")")))) (ACL (imap-parse-acl)) (t (case (prog1 (read (current-buffer)) (imap-forward)) @@ -1970,7 +2053,11 @@ Return nil if no complete line has arrived." (push (list token status code text) imap-failed-tags) (error "Internal error, tag %s status %s code %s text %s" token status code text)))) - (t (message "Garbage: %s" (buffer-string)))))))))) + (t (message "Garbage: %s" (buffer-string)))) + (when (assq token imap-callbacks) + (funcall (cdr (assq token imap-callbacks)) token status) + (setq imap-callbacks + (imap-remassoc token imap-callbacks))))))))) ;; resp-text = ["[" resp-text-code "]" SP] text ;; @@ -1989,7 +2076,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 / @@ -2043,10 +2130,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) @@ -2145,15 +2232,19 @@ Return nil if no complete line has arrived." (defun imap-parse-fetch (response) (when (eq (char-after) ?\() (let (uid flags envelope internaldate rfc822 rfc822header rfc822text - rfc822size body bodydetail bodystructure) + rfc822size body bodydetail bodystructure flags-empty) (while (not (eq (char-after) ?\))) (imap-forward) (let ((token (read (current-buffer)))) (imap-forward) (cond ((eq token 'UID) - (setq uid (ignore-errors (read (current-buffer))))) + (setq uid (condition-case () + (read (current-buffer)) + (error)))) ((eq token 'FLAGS) - (setq flags (imap-parse-flag-list))) + (setq flags (imap-parse-flag-list)) + (if (not flags) + (setq flags-empty 't))) ((eq token 'ENVELOPE) (setq envelope (imap-parse-envelope))) ((eq token 'INTERNALDATE) @@ -2182,7 +2273,7 @@ Return nil if no complete line has arrived." (when uid (setq imap-current-message uid) (imap-message-put uid 'UID uid) - (and flags (imap-message-put uid 'FLAGS flags)) + (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags)) (and envelope (imap-message-put uid 'ENVELOPE envelope)) (and internaldate (imap-message-put uid 'INTERNALDATE internaldate)) (and rfc822 (imap-message-put uid 'RFC822 rfc822)) @@ -2205,24 +2296,32 @@ Return nil if no complete line has arrived." (defun imap-parse-status () (let ((mailbox (imap-parse-mailbox))) - (when (and mailbox (search-forward "(" nil t)) - (while (not (eq (char-after) ?\))) - (let ((token (read (current-buffer)))) - (cond ((eq token 'MESSAGES) + (if (eq (char-after) ? ) + (forward-char)) + (when (and mailbox (eq (char-after) ?\()) + (while (and (not (eq (char-after) ?\))) + (or (forward-char) t) + (looking-at "\\([A-Za-z]+\\) ")) + (let ((token (match-string 1))) + (goto-char (match-end 0)) + (cond ((string= token "MESSAGES") (imap-mailbox-put 'messages (read (current-buffer)) mailbox)) - ((eq token 'RECENT) + ((string= token "RECENT") (imap-mailbox-put 'recent (read (current-buffer)) mailbox)) - ((eq token 'UIDNEXT) - (imap-mailbox-put 'uidnext (read (current-buffer)) mailbox)) - ((eq token 'UIDVALIDITY) - (and (looking-at " \\([0-9]+\\)") - (imap-mailbox-put 'uidvalidity (match-string 1) mailbox) - (goto-char (match-end 1)))) - ((eq token 'UNSEEN) + ((string= token "UIDNEXT") + (and (looking-at "[0-9]+") + (imap-mailbox-put 'uidnext (match-string 0) mailbox) + (goto-char (match-end 0)))) + ((string= token "UIDVALIDITY") + (and (looking-at "[0-9]+") + (imap-mailbox-put 'uidvalidity (match-string 0) mailbox) + (goto-char (match-end 0)))) + ((string= token "UNSEEN") (imap-mailbox-put 'unseen (read (current-buffer)) mailbox)) (t (message "Unknown status data %s in mailbox %s ignored" - token mailbox)))))))) + token mailbox) + (read (current-buffer))))))))) ;; acl_data ::= "ACL" SPACE mailbox *(SPACE identifier SPACE ;; rights) @@ -2497,7 +2596,7 @@ Return nil if no complete line has arrived." (push (imap-parse-nstring) body) ;; body-fld-desc (imap-forward) ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a - ;; nstring and return NIL instead of defaulting back to 7BIT + ;; nstring and return nil instead of defaulting back to 7BIT ;; as the standard says. (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc (imap-forward) @@ -2544,8 +2643,8 @@ Return nil if no complete line has arrived." (when imap-debug ; (untrace-all) (require 'trace) - (buffer-disable-undo (get-buffer-create imap-debug)) - (mapcar (lambda (f) (trace-function-background f imap-debug)) + (buffer-disable-undo (get-buffer-create imap-debug-buffer)) + (mapcar (lambda (f) (trace-function-background f imap-debug-buffer)) '( imap-read-passwd imap-utf7-encode