X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fimap.el;h=8e41c68720b4baf20ba1d609dc0bb5c75a011260;hp=d81048902d61b66981d5899be13c6ac8430cac46;hb=b58d62328adf02b341b460a98819a54a0d629b60;hpb=13b6d9f72158c7f9571cc1f23c1af4e4cedb428f

diff --git a/lisp/imap.el b/lisp/imap.el
index d81048902..8e41c6872 100644
--- a/lisp/imap.el
+++ b/lisp/imap.el
@@ -1,7 +1,7 @@
 ;;; imap.el --- imap library
 
 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005 Free Software Foundation, Inc.
+;;   2005, 2006, 2007 Free Software Foundation, Inc.
 
 ;; Author: Simon Josefsson <jas@pdc.kth.se>
 ;; Keywords: mail
@@ -10,7 +10,7 @@
 
 ;; 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,
@@ -80,7 +80,7 @@
 ;; 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.
@@ -173,7 +173,7 @@ the list is tried until a successful connection is made."
 
 (defcustom imap-gssapi-program (list
 				(concat "gsasl %s %p "
-					"--imap --mechanism GSSAPI "
+					"--mechanism GSSAPI "
 					"--authentication-id %l")
 				"imtest -m gssapi -u %l -p %p %s")
   "List of strings containing commands for GSSAPI (krb5) authentication.
@@ -325,6 +325,13 @@ for doing the actual authentication.")
 (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)
@@ -554,7 +561,7 @@ sure of changing the value of `foo'."
 				(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))
@@ -588,6 +595,13 @@ sure of changing the value of `foo'."
 	    (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))
@@ -622,7 +636,7 @@ sure of changing the value of `foo'."
 				(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))
@@ -905,14 +919,27 @@ Returns t if login was successful, nil otherwise."
   (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)
@@ -939,6 +966,13 @@ Returns t if login was successful, nil otherwise."
 	  (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)
@@ -1056,7 +1090,7 @@ necessary.  If nil, the buffer name is generated."
   (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))
@@ -1079,7 +1113,7 @@ necessary.  If nil, the buffer name is generated."
 	      (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))
@@ -1095,8 +1129,11 @@ necessary.  If nil, the buffer name is generated."
 			   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)
@@ -1165,7 +1202,7 @@ If BUFFER is nil, the current buffer is used."
   (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)))
@@ -1220,6 +1257,28 @@ If BUFFER is nil, the current buffer is assumed."
 (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)))
+
 
 ;; Mailbox functions:
 
@@ -1474,10 +1533,11 @@ or 'unseen.  The IMAP command tag is returned."
     (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."
@@ -1648,7 +1708,7 @@ is non-nil return these properties."
 	(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)))))
@@ -2465,7 +2525,7 @@ Return nil if no complete line has arrived."
       (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))
@@ -2809,99 +2869,99 @@ Return nil if no complete line has arrived."
 (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)