;;; imap.el --- imap library
-;; Copyright (C) 1998, 1999, 2000
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002
;; Free Software Foundation, Inc.
;; Author: Simon Josefsson <jas@pdc.kth.se>
: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.
(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
(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.
imap-process
imap-calculate-literal-size-first
imap-mailbox-data))
+(defconst imap-log-buffer "*imap-log*")
+(defconst imap-debug-buffer "*imap-debug*")
;; Internal variables.
(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.")
\f
;; 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)
(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)
(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))
(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))
(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)
(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))
(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))
(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))
?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))
(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))
(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))
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)
(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))
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))
(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)))
(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)
(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
(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"
(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"
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) "@"
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)
(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.
(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))
(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."
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)
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)))
(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)
\f
;; 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))
(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))
(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))
(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))
;;
;; 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
;;
;; 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 "("
(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))
(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
;;
;; [flag-perm *(SP flag-perm)] ")" /
;; "READ-ONLY" /
;; "READ-WRITE" /
-;; "TRYCREATE" /
+;; "TRYCREATE" /
;; "UIDNEXT" SP nz-number /
;; "UIDVALIDITY" SP nz-number /
;; "UNSEEN" SP nz-number /
(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)
(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)
(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))
(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)
(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)
(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
projects / gnus / blobdiff