Add new procedure URL-SELECTABLE?.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 958daa4e51514c868b9cb013592a71cdb45f5496..3d4335b5d9236da5ed742abf6d329f22ead66b48 100644 (file)
--- 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 677b184d21ab6fb21013014fa541330a7e3a429e..e4f5cc8ab4c4434957c96e975b4e6bed6d39fd5d 100644 (file)
--- 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 124192bf5056aa5369366fc8d97816e7d659ac29..fefd81e8417d598a5d1fb9a999e6152303d67d27 100644 (file)
--- 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))))
 \f
 (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)))