;;; imap.el --- imap library
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
-;; Free Software Foundation, Inc.
+
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005, 2006, 2007 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,
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; 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.
:type '(repeat string))
(defcustom imap-gssapi-program (list
- (concat "gsasl --client --connect %s:%p "
- "--imap --application-data "
+ (concat "gsasl %s %p "
"--mechanism GSSAPI "
"--authentication-id %l")
"imtest -m gssapi -u %l -p %p %s")
(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)
(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))
(while (and (memq (process-status process) '(open run))
(set-buffer buffer) ;; XXX "blue moon" nntp.el bug
(goto-char (point-min))
+ ;; Athena IMTEST can output SSL verify errors
+ (or (while (looking-at "^verify error:num=")
+ (forward-line))
+ t)
+ (or (while (looking-at "^TLS connection established")
+ (forward-line))
+ t)
;; cyrus 1.6.x (13? < x <= 22) queries capabilities
(or (while (looking-at "^C:")
(forward-line))
(or (not (looking-at "S: "))
(forward-char 3)
t)
+ ;; GNU SASL may print 'Trying ...' first.
+ (or (not (looking-at "Trying "))
+ (forward-line)
+ t)
(not (and (imap-parse-greeting)
;; success in imtest 1.6:
(re-search-forward
(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))
(coding-system-for-read imap-coding-system-for-read)
(coding-system-for-write imap-coding-system-for-write)
(process-connection-type imap-process-connection-type)
+ (set-process-query-on-exit-flag
+ (if (fboundp 'set-process-query-on-exit-flag)
+ 'set-process-query-on-exit-flag
+ 'process-kill-without-query))
process)
(when (progn
(setq process (start-process
(format-spec-make
?s server
?p (number-to-string port)))))
- (process-kill-without-query process)
+ (funcall set-process-query-on-exit-flag process nil)
process)
(with-current-buffer buffer
(goto-char (point-min))
(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)
(with-current-buffer (or buffer (current-buffer))
(if (not (eq imap-state 'nonauth))
(or (eq imap-state 'auth)
- (eq imap-state 'select)
+ (eq imap-state 'selected)
(eq imap-state 'examine))
(make-local-variable 'imap-username)
(make-local-variable 'imap-password)
(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)))))
(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-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)
projects / gnus / blobdiff