From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 9 May 2001 17:38:33 +0000 (+0000)
Subject: Add new procedure URL-SELECTABLE?.
X-Git-Tag: 20090517-FFI~2835
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e59c0d2d9ff7ea33f1e268c1c34da25651be246e;p=mit-scheme.git

Add new procedure URL-SELECTABLE?.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 958daa4e5..3d4335b5d 100644
--- a/v7/src/imail/imail-core.scm
+++ b/v7/src/imail/imail-core.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-core.scm,v 1.119 2001/05/07 18:02:52 cph Exp $
+;;; $Id: imail-core.scm,v 1.120 2001/05/09 17:38:17 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -91,6 +91,9 @@
 ;; Return #T if URL represents an existing folder.
 (define-generic url-exists? (url))
 
+;; Return #T if URL both exists and can be opened.
+(define-generic url-selectable? (url))
+
 ;; Return a string that uniquely identifies the server and account for
 ;; URL.  E.g. for IMAP this could be the URL string without the
 ;; mailbox information.  This string will be included in the
diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 677b184d2..e4f5cc8ab 100644
--- a/v7/src/imail/imail-file.scm
+++ b/v7/src/imail/imail-file.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-file.scm,v 1.61 2001/03/19 22:51:48 cph Exp $
+;;; $Id: imail-file.scm,v 1.62 2001/05/09 17:38:22 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -43,6 +43,9 @@
 (define-method url-exists? ((url <file-url>))
   (file-exists? (file-url-pathname url)))
 
+(define-method url-selectable? ((url <file-url>))
+  (file-regular? (file-url-pathname url)))
+
 (define (pathname->url-body pathname)
   (string-append (let ((device (pathname-device pathname)))
 		   (if (string? device)
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 124192bf5..fefd81e84 100644
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.148 2001/05/07 18:01:05 cph Exp $
+;;; $Id: imail-imap.scm,v 1.149 2001/05/09 17:38:33 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -87,6 +87,14 @@
        (= (imap-url-port url1) (imap-url-port url2))))
 
 (define-method url-exists? ((url <imap-url>))
+  (and (imap-url-info url) #t))
+
+(define-method url-selectable? ((url <imap-url>))
+  (let ((response (imap-url-info url)))
+    (and response
+	 (not (memq '\NOSELECT (imap:response:list-flags response))))))
+
+(define (imap-url-info url)
   (let ((responses
 	 (with-open-imap-connection url
 	   (lambda (connection)
@@ -95,7 +103,7 @@
 				(imap-url-server-mailbox url))))))
     (and (pair? responses)
 	 (null? (cdr responses))
-	 (not (memq '\NOSELECT (imap:response:list-flags (car responses)))))))
+	 (car responses))))
 
 (define-method url-pass-phrase-key ((url <imap-url>))
   (make-url-string (url-protocol url) (make-imap-url-string url #f)))