;;; imap.el --- imap library
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Simon Josefsson <simon@josefsson.org>
;; Keywords: mail
:type 'string)
(defcustom imap-read-timeout (if (string-match
- "windows-nt\\|os/2\\|emx\\|cygwin"
+ "windows-nt\\|os/2\\|cygwin"
(symbol-name system-type))
1.0
0.1)
(defvar imap-port nil)
(defvar imap-username nil)
(defvar imap-password nil)
+(defvar imap-last-authenticator nil)
(defvar imap-calculate-literal-size-first nil)
(defvar imap-state 'closed
"IMAP state.
The function should take two arguments, the first the IMAP tag and the
second the status (OK, NO, BAD etc) of the command.")
-(defvar imap-enable-exchange-bug-workaround nil
- "Send FETCH UID commands as *:* instead of *.
-
-When non-nil, use an alternative UIDS form. Enabling appears to
-be required for some servers (e.g., Microsoft Exchange 2007)
-which otherwise would trigger a response 'BAD The specified
-message set is invalid.'. We don't unconditionally use this
-form, since this is said to be significantly inefficient.
-
-This variable is set to t automatically per server if the
-canonical form fails.")
-
\f
;; Utility functions:
(setcdr alist (imap-remassoc key (cdr alist)))
alist)))
-(defsubst imap-disable-multibyte ()
+(defmacro imap-disable-multibyte ()
"Enable multibyte in the current buffer."
- (when (fboundp 'set-buffer-multibyte)
- (set-buffer-multibyte nil)))
+ (unless (featurep 'xemacs)
+ '(set-buffer-multibyte nil)))
(defsubst imap-utf7-encode (string)
(if imap-use-utf7
\f
;; Server functions; stream stuff:
+(defun imap-log (string-or-buffer)
+ (when imap-log
+ (with-current-buffer (get-buffer-create imap-log-buffer)
+ (imap-disable-multibyte)
+ (buffer-disable-undo)
+ (goto-char (point-max))
+ (if (bufferp string-or-buffer)
+ (insert-buffer-substring string-or-buffer)
+ (insert string-or-buffer)))))
+
(defun imap-kerberos4-stream-p (buffer)
(imap-capability 'AUTH=KERBEROS_V4 buffer))
(setq response (match-string 1)))))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
(erase-buffer)
(message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
(if response (concat "done, " response) "failed"))
(setq response (match-string 1)))))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(erase-buffer)
(message "GSSAPI IMAP connection: %s" (or response "failed"))
(if (and response (let ((case-fold-search nil))
(not (imap-parse-greeting)))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(erase-buffer)
(when (memq (process-status process) '(open run))
(setq done process))))))
(not (imap-parse-greeting)))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(when (memq (process-status process) '(open run))
process))))
(not (imap-parse-greeting)))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(when (memq (process-status process) '(open run))
process))))
(not (imap-parse-greeting)))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(erase-buffer)
(when (memq (process-status process) '(open run))
(setq done process)))))
(not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
(accept-process-output process 1)
(sit-for 1))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring buffer)))
+ (imap-log buffer)
(when (and (setq tls-info (starttls-negotiate process))
(memq (process-status process) '(open run)))
(setq done process)))
(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
(read-passwd
- (concat "IMAP password for " user "@"
+ (concat "imap: password for " user "@"
imap-server " (using authenticator `"
(symbol-name imap-auth) "'): "))))
(when (and user passwd)
(if (funcall loginfunc user passwd)
(progn
+ (message "imap: Login successful...")
(setq ret t
imap-username user)
(when (and (not imap-password)
(or imap-store-password
- (y-or-n-p "Store password for this session? ")))
+ (y-or-n-p "imap: Store password for this IMAP session? ")))
(setq imap-password passwd)))
- (message "Login failed...")
+ (message "imap: Login failed...")
(setq passwd nil)
(setq imap-password nil)
(sit-for 1))))
buffer
(buffer-name buffer))))
(kill-buffer buffer)
- (rename-buffer name))
+ (rename-buffer name)
+ ;; set the passed buffer to the current one,
+ ;; so that (imap-opened buffer) later will work
+ (setq buffer (current-buffer)))
(message "imap: Reconnecting with stream `%s'...done"
stream)
(setq imap-stream stream)
(setq streams nil))))))
(when (imap-opened buffer)
(setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
+ ;; (debug "opened+state+auth+buffer" (imap-opened buffer) imap-state imap-auth buffer)
(when imap-stream
buffer))))
(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))
+ (make-local-variable 'imap-last-authenticator)
+ (when user (setq imap-username user))
+ (when passwd (setq imap-password passwd))
(if imap-auth
- (and (funcall (nth 2 (assq imap-auth
- imap-authenticator-alist)) (current-buffer))
+ (and (setq imap-last-authenticator
+ (assq imap-auth imap-authenticator-alist))
+ (funcall (nth 2 imap-last-authenticator) (current-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)) (current-buffer))
+ (setq imap-last-authenticator
+ (assq auth imap-authenticator-alist))
+ (when (funcall (nth 1 imap-last-authenticator) (current-buffer))
(message "imap: Authenticating to `%s' using `%s'..."
imap-server auth)
(setq imap-auth auth)
- (if (funcall (nth 2 (assq auth imap-authenticator-alist)) (current-buffer))
+ (if (funcall (nth 2 imap-last-authenticator) (current-buffer))
(progn
(message "imap: Authenticating to `%s' using `%s'...done"
imap-server auth)
+ ;; set imap-state correctly on successful auth attempt
+ (setq imap-state 'auth)
+ ;; stop iterating through the authenticator list
(setq auths nil))
(message "imap: Authenticating to `%s' using `%s'...failed"
imap-server auth)))))
\f
;; Mailbox functions:
-(defun imap-mailbox-put (propname value &optional mailbox buffer)
- (with-current-buffer (or buffer (current-buffer))
- (if imap-mailbox-data
- (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
- propname value)
- (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
- propname value mailbox (current-buffer)))
- t))
+(defun imap-mailbox-put (propname value &optional mailbox)
+ (if imap-mailbox-data
+ (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
+ propname value)
+ (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
+ propname value mailbox (current-buffer)))
+ t)
(defsubst imap-mailbox-get-1 (propname &optional mailbox)
(get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
propname))
(defun imap-mailbox-get (propname &optional mailbox buffer)
- (let ((mailbox (imap-utf7-encode mailbox)))
- (with-current-buffer (or buffer (current-buffer))
- (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
-
-(defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
(with-current-buffer (or buffer (current-buffer))
- (let (result)
- (mapatoms
- (lambda (s)
- (push (funcall func (if mailbox-decoder
- (funcall mailbox-decoder (symbol-name s))
- (symbol-name s))) result))
- imap-mailbox-data)
- result)))
-
-(defun imap-mailbox-map (func &optional buffer)
+ (imap-mailbox-get-1 propname (or (imap-utf7-encode mailbox)
+ imap-current-mailbox))))
+
+(defun imap-mailbox-map-1 (func &optional mailbox-decoder)
+ (let (result)
+ (mapatoms
+ (lambda (s)
+ (push (funcall func (if mailbox-decoder
+ (funcall mailbox-decoder (symbol-name s))
+ (symbol-name s))) result))
+ imap-mailbox-data)
+ result))
+
+(defun imap-mailbox-map (func)
"Map a function across each mailbox in `imap-mailbox-data', returning a list.
Function should take a mailbox name (a string) as
the only argument."
- (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
+ (imap-mailbox-map-1 func 'imap-utf7-decode))
(defun imap-current-mailbox (&optional buffer)
(with-current-buffer (or buffer (current-buffer))
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
- (put (intern (number-to-string uid) imap-message-data)
- propname value)
- (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
- uid propname value (current-buffer)))
- t))
+(defun imap-message-put (uid propname value)
+ (if imap-message-data
+ (put (intern (number-to-string uid) imap-message-data)
+ propname value)
+ (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
+ uid propname value (current-buffer)))
+ t)
-(defun imap-message-get (uid propname &optional buffer)
- (with-current-buffer (or buffer (current-buffer))
- (get (intern-soft (number-to-string uid) imap-message-data)
- propname)))
+(defun imap-message-get (uid propname)
+ (get (intern-soft (number-to-string uid) imap-message-data)
+ propname))
-(defun imap-message-map (func propname &optional buffer)
+(defun imap-message-map (func propname)
"Map a function across each message in `imap-message-data', returning a list."
- (with-current-buffer (or buffer (current-buffer))
- (let (result)
- (mapatoms
- (lambda (s)
- (push (funcall func (get s 'UID) (get s propname)) result))
- imap-message-data)
- result)))
+ (let (result)
+ (mapatoms
+ (lambda (s)
+ (push (funcall func (get s 'UID) (get s propname)) result))
+ imap-message-data)
+ result))
(defmacro imap-message-envelope-date (uid &optional buffer)
`(with-current-buffer (or ,buffer (current-buffer))
(format "String %s cannot be converted to a Lisp integer" number))
number)))
-(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer)
- "Like `imap-fetch', but DTRT with Exchange 2007 bug.
-However, UIDS here is a cons, where the car is the canonical form
-of the UIDS specification, and the cdr is the one which works with
-Exchange 2007 or, potentially, other buggy servers.
-See `imap-enable-exchange-bug-workaround'."
- ;; The first time we get here for a given, we'll try the canonical
- ;; form. If we get the known error from the buggy server, set the
- ;; flag buffer-locally (to account for connections to multiple
- ;; servers), then re-try with the alternative UIDS spec. We don't
- ;; unconditionally use the alternative form, since the
- ;; currently-used alternatives are seriously inefficient with some
- ;; servers (although they are valid).
- ;;
- ;; FIXME: Maybe it would be cleaner to have a flag to not signal
- ;; the error (which otherwise gives a message), and test
- ;; `imap-failed-tags'. Also, Other IMAP clients use other forms of
- ;; request which work with Exchange, e.g. Claws does "UID FETCH 1:*
- ;; (UID)" rather than "FETCH UID 1,*". Is there a good reason not
- ;; to do the same?
- (condition-case data
- ;; Binding `debug-on-error' allows us to get the error from
- ;; `imap-parse-response' -- it's normally caught by Emacs around
- ;; execution of a process filter.
- (let ((debug-on-error t))
- (imap-fetch (if imap-enable-exchange-bug-workaround
- (cdr uids)
- (car uids))
- props receive nouidfetch buffer))
- (error
- (if (and (not imap-enable-exchange-bug-workaround)
- ;; This is the Exchange 2007 response. It may be more
- ;; robust just to check for a BAD response to the
- ;; attempted fetch.
- (string-match "The specified message set is invalid"
- (cadr data)))
- (with-current-buffer (or buffer (current-buffer))
- (set (make-local-variable 'imap-enable-exchange-bug-workaround)
- t)
- (imap-fetch (cdr uids) props receive nouidfetch))
- (signal (car data) (cdr data))))))
-
(defun imap-message-copyuid-1 (mailbox)
(if (imap-capability 'UIDPLUS)
(list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
(imap-message-data (make-vector 2 0)))
(when (imap-mailbox-examine-1 mailbox)
(prog1
- (and (imap-fetch-safe '("*" . "*:*") "UID")
+ (and (imap-fetch "*:*" "UID")
(list (imap-mailbox-get-1 'uidvalidity mailbox)
(apply 'max (imap-message-map
(lambda (uid prop) uid) 'UID))))
(imap-message-data (make-vector 2 0)))
(when (imap-mailbox-examine-1 mailbox)
(prog1
- (and (imap-fetch-safe '("*" . "*:*") "UID")
+ (and (imap-fetch "*:*" "UID")
(list (imap-mailbox-get-1 'uidvalidity mailbox)
(apply 'max (imap-message-map
(lambda (uid prop) uid) 'UID))))
(defun imap-send-command-1 (cmdstr)
(setq cmdstr (concat cmdstr imap-client-eol))
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert cmdstr)))
+ (imap-log cmdstr)
(process-send-string imap-process cmdstr))
(defun imap-send-command (command &optional buffer)
(stream imap-stream)
(eol imap-client-eol))
(with-current-buffer cmd
- (and imap-log
- (with-current-buffer (get-buffer-create
- imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert-buffer-substring cmd)))
+ (imap-log cmd)
(process-send-region process (point-min)
(point-max)))
(process-send-string process imap-client-eol))))
(with-current-buffer (process-buffer proc)
(goto-char (point-max))
(insert string)
- (and imap-log
- (with-current-buffer (get-buffer-create imap-log-buffer)
- (imap-disable-multibyte)
- (buffer-disable-undo)
- (goto-char (point-max))
- (insert string)))
+ (imap-log string)
(let (end)
(goto-char (point-min))
(while (setq end (imap-find-next-line))
(save-restriction
(narrow-to-region (point-min) end)
- (delete-backward-char (length imap-server-eol))
+ (delete-char (- (length imap-server-eol)))
(goto-char (point-min))
(unwind-protect
(cond ((eq imap-state 'initial)
(imap-forward)
(nreverse body)))))
-(when imap-debug ; (untrace-all)
- (require 'trace)
- (buffer-disable-undo (get-buffer-create imap-debug-buffer))
- (mapc (lambda (f) (trace-function-background f imap-debug-buffer))
- '(
- imap-utf7-encode
- imap-utf7-decode
- imap-error-text
- imap-kerberos4s-p
- imap-kerberos4-open
- imap-ssl-p
- imap-ssl-open
- imap-network-p
- imap-network-open
- imap-interactive-login
- imap-kerberos4a-p
- imap-kerberos4-auth
- imap-cram-md5-p
- imap-cram-md5-auth
- imap-login-p
- imap-login-auth
- imap-anonymous-p
- imap-anonymous-auth
- imap-open-1
- imap-open
- imap-opened
- imap-ping-server
- imap-authenticate
- imap-close
- imap-capability
- imap-namespace
- imap-send-command-wait
- imap-mailbox-put
- imap-mailbox-get
- imap-mailbox-map-1
- imap-mailbox-map
- imap-current-mailbox
- imap-current-mailbox-p-1
- imap-current-mailbox-p
- imap-mailbox-select-1
- imap-mailbox-select
- imap-mailbox-examine-1
- imap-mailbox-examine
- imap-mailbox-unselect
- imap-mailbox-expunge
- imap-mailbox-close
- imap-mailbox-create-1
- imap-mailbox-create
- imap-mailbox-delete
- imap-mailbox-rename
- imap-mailbox-lsub
- imap-mailbox-list
- imap-mailbox-subscribe
- imap-mailbox-unsubscribe
- imap-mailbox-status
- imap-mailbox-acl-get
- imap-mailbox-acl-set
- imap-mailbox-acl-delete
- imap-current-message
- imap-list-to-message-set
- imap-fetch-asynch
- imap-fetch
- imap-fetch-safe
- imap-message-put
- imap-message-get
- imap-message-map
- imap-search
- imap-message-flag-permanent-p
- imap-message-flags-set
- imap-message-flags-del
- imap-message-flags-add
- imap-message-copyuid-1
- imap-message-copyuid
- imap-message-copy
- imap-message-appenduid-1
- imap-message-appenduid
- imap-message-append
- imap-body-lines
- imap-envelope-from
- imap-send-command-1
- imap-send-command
- imap-wait-for-tag
- imap-sentinel
- imap-find-next-line
- imap-arrival-filter
- imap-parse-greeting
- imap-parse-response
- imap-parse-resp-text
- imap-parse-resp-text-code
- imap-parse-data-list
- imap-parse-fetch
- imap-parse-status
- imap-parse-acl
- imap-parse-flag-list
- imap-parse-envelope
- imap-parse-body-extension
- imap-parse-body
- )))
-
(provide 'imap)
-;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7
;;; imap.el ends here
projects / gnus / blobdiff