;;; imap.el --- imap library
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005 Free Software Foundation, Inc.
+;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Simon Josefsson <jas@pdc.kth.se>
;; Keywords: mail
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; 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'), RFC2971 (ID). It also
-;; take advantage the UNSELECT extension in Cyrus IMAPD.
+;; takes advantage of 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.
(eval-when-compile (require 'cl))
(eval-and-compile
+ (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
(autoload 'starttls-open-stream "starttls")
(autoload 'starttls-negotiate "starttls")
(autoload 'sasl-find-mechanism "sasl")
(defvar imap-error nil
"Error codes from the last command.")
+(defvar imap-logout-timeout nil
+ "Close server immediately if it can't logout in this number of seconds.
+If it is nil, never close server until logout completes. Normally,
+the value of this variable will be bound to a certain value to which
+an application program that uses this module specifies on a per-server
+basis.")
+
;; Internal constants. Change these and die.
(defconst imap-default-port 143)
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 *.
+Enabling this appears to be required for some servers (e.g.,
+Microsoft Exchange) which otherwise would trigger a response 'BAD
+The specified message set is invalid.'.")
+
\f
;; Utility functions:
(not (string-match "failed" response))))
(setq done process)
(if (memq (process-status process) '(open run))
- (imap-send-command "LOGOUT"))
+ (imap-logout))
(delete-process process)
nil)))))
done))
(not (string-match "failed" response))))
(setq done process)
(if (memq (process-status process) '(open run))
- (imap-send-command "LOGOUT"))
+ (imap-logout))
(delete-process process)
nil)))))
done))
(and (not (imap-capability 'LOGINDISABLED buffer))
(not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))
+(defun imap-quote-specials (string)
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (while (re-search-forward "[\\\"]" nil t)
+ (forward-char -1)
+ (insert "\\")
+ (forward-char 1))
+ (buffer-string)))
+
(defun imap-login-auth (buffer)
"Login to server using the LOGIN command."
(message "imap: Plaintext authentication...")
(imap-interactive-login buffer
(lambda (user passwd)
(imap-ok-p (imap-send-command-wait
- (concat "LOGIN \"" user "\" \""
- passwd "\""))))))
+ (concat "LOGIN \""
+ (imap-quote-specials user)
+ "\" \""
+ (imap-quote-specials passwd)
+ "\""))))))
(defun imap-anonymous-p (buffer)
t)
(imap-capability nil buffer))
mecs))
+(declare-function sasl-find-mechanism "sasl" (mechanism))
+(declare-function sasl-mechanism-name "sasl" (mechanism))
+(declare-function sasl-make-client "sasl" (mechanism name service server))
+(declare-function sasl-next-step "sasl" (client step))
+(declare-function sasl-step-data "sasl" (step))
+(declare-function sasl-step-set-data "sasl" (step data))
+
(defun imap-sasl-auth-p (buffer)
(and (condition-case ()
(require 'sasl)
(with-current-buffer (get-buffer-create buffer)
(if (imap-opened buffer)
(imap-close buffer))
- (mapcar 'make-local-variable imap-local-variables)
+ (mapc 'make-local-variable imap-local-variables)
(imap-disable-multibyte)
(buffer-disable-undo)
(setq imap-server (or server imap-server))
(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)
+ (mapc 'make-local-variable imap-local-variables)
(imap-disable-multibyte)
(buffer-disable-undo)
(setq imap-server (or server imap-server))
stream))
;; We're done, kill the first connection
(imap-close buffer)
- (kill-buffer buffer)
- (rename-buffer buffer)
+ (let ((name (if (stringp buffer)
+ buffer
+ (buffer-name buffer))))
+ (kill-buffer buffer)
+ (rename-buffer name))
(message "imap: Reconnecting with stream `%s'...done"
stream)
(setq imap-stream stream)
(when imap-stream
buffer))))
+(defcustom imap-ping-server t
+ "If non-nil, check if IMAP is open.
+See the function `imap-ping-server'."
+ :version "23.1" ;; No Gnus
+ :group 'imap
+ :type 'boolean)
+
(defun imap-opened (&optional buffer)
"Return non-nil if connection to imap server in BUFFER is open.
If BUFFER is nil then the current buffer is used."
(buffer-live-p buffer)
(with-current-buffer buffer
(and imap-process
- (memq (process-status imap-process) '(open run))))))
+ (memq (process-status imap-process) '(open run))
+ (if imap-ping-server
+ (imap-ping-server)
+ t)))))
+
+(defun imap-ping-server (&optional buffer)
+ "Ping the IMAP server in BUFFER with a \"NOOP\" command.
+Return non-nil if the server responds, and nil if it does not
+respond. If BUFFER is nil, the current buffer is used."
+ (condition-case ()
+ (imap-ok-p (imap-send-command-wait "NOOP" buffer))
+ (error nil)))
(defun imap-authenticate (&optional user passwd buffer)
"Authenticate to server in BUFFER, using current buffer if nil.
(if passwd (setq imap-password passwd))
(if imap-auth
(and (funcall (nth 2 (assq imap-auth
- imap-authenticator-alist)) buffer)
+ imap-authenticator-alist)) (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)) buffer)
+ (when (funcall (nth 1 (assq auth imap-authenticator-alist)) (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)) buffer)
+ (if (funcall (nth 2 (assq auth imap-authenticator-alist)) (current-buffer))
(progn
(message "imap: Authenticating to `%s' using `%s'...done"
imap-server auth)
(with-current-buffer (or buffer (current-buffer))
(when (imap-opened)
(condition-case nil
- (imap-send-command-wait "LOGOUT")
+ (imap-logout-wait)
(quit nil)))
(when (and imap-process
(memq (process-status imap-process) '(open run)))
(defun imap-send-command-wait (command &optional buffer)
(imap-wait-for-tag (imap-send-command command buffer) buffer))
+(defun imap-logout (&optional buffer)
+ (or buffer (setq buffer (current-buffer)))
+ (if imap-logout-timeout
+ (with-timeout (imap-logout-timeout
+ (condition-case nil
+ (with-current-buffer buffer
+ (delete-process imap-process))
+ (error)))
+ (imap-send-command "LOGOUT" buffer))
+ (imap-send-command "LOGOUT" buffer)))
+
+(defun imap-logout-wait (&optional buffer)
+ (or buffer (setq buffer (current-buffer)))
+ (if imap-logout-timeout
+ (with-timeout (imap-logout-timeout
+ (condition-case nil
+ (with-current-buffer buffer
+ (delete-process imap-process))
+ (error)))
+ (imap-send-command-wait "LOGOUT" buffer))
+ (imap-send-command-wait "LOGOUT" buffer)))
+
\f
;; Mailbox functions:
(imap-send-command (list "STATUS \""
(imap-utf7-encode mailbox)
"\" "
- (format "%s"
- (if (listp items)
- items
- (list items)))))))
+ (upcase
+ (format "%s"
+ (if (listp items)
+ items
+ (list items))))))))
(defun imap-mailbox-acl-get (&optional mailbox buffer)
"Get ACL on mailbox from server in BUFFER."
(imap-mailbox-get-1 'search imap-current-mailbox)))))
(defun imap-message-flag-permanent-p (flag &optional mailbox buffer)
- "Return t iff FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
+ "Return t if FLAG can be permanently (between IMAP sessions) saved on articles, in MAILBOX on server in BUFFER."
(with-current-buffer (or buffer (current-buffer))
(or (member "\\*" (imap-mailbox-get 'permanentflags mailbox))
(member flag (imap-mailbox-get 'permanentflags mailbox)))))
(concat "UID STORE " articles
" +FLAGS" (if silent ".SILENT") " (" flags ")"))))))
+;; Cf. http://thread.gmane.org/gmane.emacs.gnus.general/65317/focus=65343
+;; Signal an error if we'd get an integer overflow.
+;;
+;; FIXME: Identify relevant calls to `string-to-number' and replace them with
+;; `imap-string-to-integer'.
+(defun imap-string-to-integer (string &optional base)
+ (let ((number (string-to-number string base)))
+ (if (> number most-positive-fixnum)
+ (error
+ (format "String %s cannot be converted to a lisp integer" number))
+ number)))
+
(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 "*" "UID")
+ (and (imap-fetch
+ (if imap-enable-exchange-bug-workaround "*:*" "*") "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 "*" "UID")
+ (and (imap-fetch
+ (if imap-enable-exchange-bug-workaround "*:*" "*") "UID")
(list (imap-mailbox-get-1 'uidvalidity mailbox)
(apply 'max (imap-message-map
(lambda (uid prop) uid) 'UID))))
(while (and (not (eq (char-after) ?\)))
(or (forward-char) t)
(looking-at "\\([A-Za-z]+\\) "))
- (let ((token (match-string 1)))
+ (let ((token (upcase (match-string 1))))
(goto-char (match-end 0))
(cond ((string= token "MESSAGES")
(imap-mailbox-put 'messages (read (current-buffer)) mailbox))
(when imap-debug ; (untrace-all)
(require 'trace)
(buffer-disable-undo (get-buffer-create imap-debug-buffer))
- (mapcar (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-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-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
- )))
+ (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-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
+;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7
;;; imap.el ends here
projects / gnus / blobdiff