New operation CONTAINER-URL-CONTENTS.

Reimplemented URL-IS-SELECTABLE? for file folders.  New implementation
probes the file to determine if it is a known type.

File-folder completion now only considers files of known type and
directories.  It also doesn't consider "." and ".." directories.

Code that mapped IMAP heirarchy delimiters was broken, although this
caused no practical consequences.  It has been reimplemented to make
it both correct and simpler.

IMAP-folder completion used to probe subfolders of a folder to
determine if a folder should have a "/" at the end.  This was wasteful
of network bandwidth and had no practical consequences, so it has been
changed to not do this.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 08a24afa5b08cca49502307980e8681e511abdf0..e0008c45e20fddc0d91a08b21049e9049f423404 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.121 2001/05/13 03:45:48 cph Exp $
+;;; $Id: imail-core.scm,v 1.122 2001/05/15 19:46:48 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -78,6 +78,11 @@
 ;; may be affected by the NAMESPACE prefix information).
 (define-generic url-container (url))
 
+;; Return a list of URLs referring to the contents of CONTAINER-URL.
+;; The result can contain both folder and container URLs.
+;; The result is not sorted.
+(define-generic container-url-contents (container-url))
+
 ;; Return the base name of FOLDER-URL.  This is the PATHNAME-NAME of a
 ;; file-based folder, and for IMAP it's the part of the mailbox name
 ;; following the rightmost delimiter.

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 6261478b47484f306500212165b5a8e79f4b5ed2..0563887ee8ea25d850cf3c298a1d81f707ecfd3a 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.64 2001/05/13 03:45:52 cph Exp $
+;;; $Id: imail-file.scm,v 1.65 2001/05/15 19:46:51 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -48,61 +48,71 @@
 (define pathname-url-constructors
   (make-eq-hash-table))
 
-(define-method url-body ((url <pathname-url>))
-  (pathname->url-body (pathname-url-pathname url)))
-
-(define (pathname->url-body pathname)
-  (string-append (let ((device (pathname-device pathname)))
-                  (if (string? device)
-                      (string-append "/" device ":")
-                      ""))
-                (let ((directory (pathname-directory pathname)))
-                  (if (pair? directory)
-                      (string-append
-                       (if (eq? (car directory) 'ABSOLUTE) "/" "")
-                       (decorated-string-append
-                        "" "" "/"
-                        (map (lambda (string)
-                               (url:encode-string
-                                (if (eq? string 'UP) ".." string)))
-                             (cdr directory))))
-                      ""))
-                (url:encode-string (file-namestring pathname))))
-
 (define-method url-container ((url <pathname-url>))
   (make-directory-url
    (directory-pathname
     (directory-pathname-as-file (pathname-url-pathname url)))))
-\f
-(define (define-pathname-url-predicate class predicate)
+
+(define (define-pathname-url-predicates class
+         file-predicate
+         directory-predicate
+         pathname-predicate)
   (let ((constructor (get-pathname-url-constructor class)))
     (let loop ((entries pathname-url-predicates))
       (if (pair? entries)
          (if (eq? class (vector-ref (car entries) 0))
              (begin
-               (vector-set! (car entries) 1 predicate)
-               (vector-set! (car entries) 2 constructor))
+               (vector-set! (car entries) 1 file-predicate)
+               (vector-set! (car entries) 2 directory-predicate)
+               (vector-set! (car entries) 3 pathname-predicate)
+               (vector-set! (car entries) 4 constructor))
              (loop (cdr entries)))
          (begin
            (set! pathname-url-predicates
-                 (cons (vector class predicate constructor)
+                 (cons (vector class
+                               file-predicate
+                               directory-predicate
+                               pathname-predicate
+                               constructor)
                        pathname-url-predicates))
            unspecific)))))
 
+(define (find-pathname-url-constructor pathname must-exist? if-not-found)
+  (let ((type (file-type-indirect pathname))
+       (search
+        (lambda (index)
+          (let loop ((entries pathname-url-predicates))
+            (and (pair? entries)
+                 (if ((vector-ref (car entries) index) pathname)
+                     (vector-ref (car entries) 4)
+                     (loop (cdr entries))))))))
+    (or (case type
+         ((REGULAR) (search 1))
+         ((DIRECTORY) (search 2))
+         ((#F) (and (not must-exist?) (search 3)))
+         (else #f))
+       (and if-not-found
+            (if-not-found pathname type)))))
+
 (define pathname-url-predicates '())
+\f
+(define-method url-is-selectable? ((url <pathname-url>))
+  (and (find-pathname-url-constructor (pathname-url-pathname url) #t #f) #t))
 
 (define-method parse-url-body ((string <string>) (default-url <pathname-url>))
   (let ((pathname
         (parse-pathname-url-body string (pathname-url-pathname default-url))))
-    ((let loop ((entries pathname-url-predicates))
-       (if (pair? entries)
-          (if ((vector-ref (car entries) 1) pathname)
-              (vector-ref (car entries) 2)
-              (loop (cdr entries)))
-          (if (or (directory-pathname? pathname)
-                  (file-directory? pathname))
-              make-directory-url
-              make-file-url)))
+    ((find-pathname-url-constructor pathname #f
+       (lambda (pathname type)
+        (case type
+          ((REGULAR) make-file-url)
+          ((DIRECTORY) make-directory-url)
+          ((#F)
+           (if (directory-pathname? pathname)
+               make-directory-url
+               make-file-url))
+          (else
+           (error "Pathname refers to illegal file type:" pathname)))))
      pathname)))
 
 (define (parse-pathname-url-body string default-pathname)
@@ -127,6 +137,27 @@
           (error:bad-range-argument string 'PARSE-PATHNAME-URL-BODY))
          (else
           (finish string)))))
+
+(define-method url-body ((url <pathname-url>))
+  (pathname->url-body (pathname-url-pathname url)))
+
+(define (pathname->url-body pathname)
+  (string-append (let ((device (pathname-device pathname)))
+                  (if (string? device)
+                      (string-append "/" device ":")
+                      ""))
+                (let ((directory (pathname-directory pathname)))
+                  (if (pair? directory)
+                      (string-append
+                       (if (eq? (car directory) 'ABSOLUTE) "/" "")
+                       (decorated-string-append
+                        "" "" "/"
+                        (map (lambda (string)
+                               (url:encode-string
+                                (if (eq? string 'UP) ".." string)))
+                             (cdr directory))))
+                      ""))
+                (url:encode-string (file-namestring pathname))))
 \f
 ;;;; File folders
 
@@ -136,9 +167,6 @@
 (define-method url-exists? ((url <file-url>))
   (file-exists? (pathname-url-pathname url)))
 
-(define-method url-is-selectable? ((url <file-url>))
-  (file-regular? (pathname-url-pathname url)))
-
 (define-method url-presentation-name ((url <file-url>))
   (file-namestring (pathname-url-pathname url)))
 
@@ -169,6 +197,18 @@
 \f
 ;;;; Server operations
 
+(define-method container-url-contents ((url <directory-url>))
+  (simple-directory-read (pathname-url-pathname url)
+    (lambda (name directory result)
+      (if (or (string=? name ".") (string=? name ".."))
+         result
+         (let* ((pathname
+                 (parse-namestring (string-append directory name) #f #f))
+                (constructor (pathname-url-filter pathname)))
+           (if constructor
+               (cons (constructor pathname) result)
+               result))))))
+
 (define-method %url-complete-string
     ((string <string>) (default-url <pathname-url>)
                       if-unique if-not-unique if-not-found)
@@ -176,7 +216,7 @@
    (parse-pathname-url-body
     string
     (directory-pathname (pathname-url-pathname default-url)))
-   (lambda (pathname) pathname #t)
+   pathname-url-filter
    (lambda (string)
      (if-unique (pathname->url-body string)))
    (lambda (prefix get-completions)
@@ -191,7 +231,14 @@
        (parse-pathname-url-body
         string
         (directory-pathname (pathname-url-pathname default-url)))
-       (lambda (pathname) pathname #t))))
+       pathname-url-filter)))
+
+(define (pathname-url-filter pathname)
+  (find-pathname-url-constructor pathname #t
+    (lambda (pathname type)
+      pathname
+      (and (eq? type 'DIRECTORY)
+          make-directory-url))))
 
 (define-method %delete-folder ((url <file-url>))
   (delete-file (pathname-url-pathname url)))

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index cc73b632fb90c17f1d953666e72dda1bea66dc88..18adf20e255164d3291de06eb0b5dc134a9b9705 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.150 2001/05/13 03:46:01 cph Exp $
+;;; $Id: imail-imap.scm,v 1.151 2001/05/15 19:46:54 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -122,55 +122,11 @@
                 mailbox))
 
 (define-method make-peer-url ((url <imap-url>) base-name)
-  (imap-url-new-mailbox
-   url
-   (string-append (imap-mailbox-container-string url (imap-url-mailbox url))
-                 base-name)))
+  (let ((url (url-container url)))
+    (imap-url-new-mailbox
+     url
+     (string-append (imap-url-mailbox url) "/" base-name))))
 
-(define-method url-container ((url <imap-url>))
-  (imap-url-new-mailbox
-   url
-   (let ((mailbox (imap-mailbox-container-string url (imap-url-mailbox url))))
-     (if (string-suffix? "/" mailbox)
-        (string-head mailbox (fix:- (string-length mailbox) 1))
-        mailbox))))
-
-(define (imap-mailbox-container-string url mailbox)
-  (let ((index (string-search-backward "/" mailbox)))
-    (if index
-       (string-head mailbox index)
-       (or (let ((response
-                  (let ((connection
-                         (search-imap-connections
-                          (lambda (connection)
-                            (and (compatible-imap-urls?
-                                  (imap-connection-url connection)
-                                  url)
-                                 (not
-                                  (eq? (imap-connection-delimiter connection)
-                                       'UNKNOWN)))))))
-                    (and connection
-                         (imap-connection-namespace connection)))))
-             (and response
-                  (let ((namespace
-                         (imap:response:namespace-personal response)))
-                    (and (pair? namespace)
-                         (car namespace)
-                         (let ((prefix
-                                (imap:decode-mailbox-name (caar namespace)))
-                               (delimiter (cadar namespace)))
-                           (cond ((not delimiter)
-                                  prefix)
-                                 ((and (fix:= (string-length prefix) 6)
-                                       (string-prefix-ci? "inbox" prefix)
-                                       (string-suffix? delimiter prefix))
-                                  "inbox/")
-                                 (else
-                                  (string-replace prefix
-                                                  (string-ref delimiter 0)
-                                                  #\/))))))))
-           ""))))
-\f
 (define-method parse-url-body (string (default-url <imap-url>))
   (call-with-values (lambda () (parse-imap-url-body string default-url))
     (lambda (user-id host port mailbox)
@@ -204,6 +160,70 @@
                        (imap-url-mailbox default-url)))
            (values #f #f #f #f))))))
 \f
+(define-method url-container ((url <imap-url>))
+  (imap-url-new-mailbox
+   url
+   (let ((mailbox (imap-url-mailbox url)))
+     (let ((index (string-find-previous-char mailbox #\/)))
+       (if index
+          (string-head mailbox index)
+          (or (get-personal-namespace url) ""))))))
+
+(define (get-personal-namespace url)
+  (let ((response
+        (let ((connection
+               (search-imap-connections
+                (lambda (connection)
+                  (and (compatible-imap-urls? (imap-connection-url connection)
+                                              url)
+                       (not (eq? (imap-connection-namespace connection)
+                                 'UNKNOWN)))))))
+          (and connection
+               (imap-connection-namespace connection)))))
+    (and response
+        (let ((namespace (imap:response:namespace-personal response)))
+          (and (pair? namespace)
+               (car namespace)
+               (let ((prefix (imap:decode-mailbox-name (caar namespace)))
+                     (delimiter (cadar namespace)))
+                 (if delimiter
+                     (let ((base
+                            (if (string-suffix? delimiter prefix)
+                                (string-head prefix
+                                             (fix:- (string-length prefix) 1))
+                                prefix)))
+                       (if (string-ci=? "inbox" base)
+                           "inbox"
+                           (string-replace base
+                                           (string-ref delimiter 0)
+                                           #\/)))
+                     prefix)))))))
+
+(define-method container-url-contents ((url <imap-url>))
+  (with-open-imap-connection url
+    (lambda (connection)
+      (map (lambda (response)
+            (imap-url-new-mailbox
+             url
+             (let ((delimiter (imap:response:list-delimiter response))
+                   (mailbox
+                    (imap:decode-mailbox-name
+                     (imap:response:list-mailbox response))))
+               (if delimiter
+                   (string-replace mailbox (string-ref delimiter 0) #\/)
+                   mailbox))))
+          (imap:command:list connection
+                             ""
+                             (string-append
+                              (imap-mailbox/url->server
+                               url
+                               (let ((mailbox (imap-url-mailbox url)))
+                                 (if (or (string-null? mailbox)
+                                         (string-suffix? "/" mailbox))
+                                     mailbox
+                                     (string-append mailbox "/"))))
+                              "%"))))))
+\f
 (define-method %url-complete-string
     ((string <string>) (default-url <imap-url>)
                       if-unique if-not-unique if-not-found)
@@ -254,36 +274,27 @@
 (define (imap-mailbox-completions prefix url)
   (with-open-imap-connection url
     (lambda (connection)
-      (let ((get-list
-            (lambda (prefix)
-              (imap:command:list connection "" (string-append prefix "%")))))
-       (append-map!
-        (lambda (response)
-          (let ((flags (imap:response:list-flags response))
-                (delimiter (imap:response:list-delimiter response))
-                (mailbox
-                 (imap:decode-mailbox-name
-                  (imap:response:list-mailbox response))))
-            (let ((mailbox*
-                   (if delimiter
-                       (string-replace mailbox (string-ref delimiter 0) #\/)
-                       mailbox)))
-              (let ((tail
-                     (if (and delimiter
-                              (or (memq '\NOSELECT flags)
-                                  (and (not (memq '\NOINFERIORS flags))
-                                       (pair?
-                                        (get-list
-                                         (string-append mailbox
-                                                        delimiter))))))
-                         (list (string-append mailbox* "/"))
-                         '())))
-                (if (memq '\NOSELECT flags)
-                    tail
-                    (cons mailbox* tail))))))
-        (get-list (imap-mailbox/url->server url prefix)))))))
+      (map (lambda (response)
+            (let ((flags (imap:response:list-flags response))
+                  (delimiter (imap:response:list-delimiter response))
+                  (mailbox
+                   (imap:decode-mailbox-name
+                    (imap:response:list-mailbox response))))
+              (let ((mailbox
+                     (if delimiter
+                         (string-replace mailbox (string-ref delimiter 0) #\/)
+                         mailbox)))
+                (if (and delimiter
+                         (memq '\NOSELECT flags)
+                         (not (memq '\NOINFERIORS flags)))
+                    (string-append mailbox "/")
+                    mailbox))))
+          (imap:command:list
+           connection
+           ""
+           (string-append (imap-mailbox/url->server url prefix) "%"))))))
 \f
-;;;; URL/server delimiter conversion
+;;;; URL->server delimiter conversion
 
 (define (imap-url-server-mailbox url)
   (imap-mailbox/url->server url (imap-url-mailbox url)))
@@ -294,46 +305,29 @@
        (string-replace mailbox #\/ delimiter)
        mailbox)))
 
-(define (imap-mailbox/server->url url mailbox)
-  (let ((delimiter (imap-mailbox-delimiter url mailbox)))
-    (if (and delimiter (not (char=? delimiter #\/)))
-       (string-replace mailbox delimiter #\/)
-       mailbox)))
-
 (define (imap-mailbox-delimiter url mailbox)
-  (or (let ((entry (find-imap-namespace-entry url mailbox)))
-       (and entry
-            (cadr entry)))
-      (let ((delimiter (imap-url-delimiter url)))
-       (and delimiter
-            (string-ref delimiter 0)))))
-
-(define (find-imap-namespace-entry url mailbox)
-  (let ((response (imap-url-namespace url)))
-    (and response
-        (let ((try
-               (lambda (namespace)
-                 (let loop ((entries namespace))
-                   (and (pair? entries)
-                        (or (let ((prefix
-                                   (imap:decode-mailbox-name (caar entries)))
-                                  (delimiter (cadar entries)))
-                              (if (and delimiter
-                                       (fix:= (string-length prefix) 6)
-                                       (string-prefix-ci? "inbox" prefix)
-                                       (string-suffix? delimiter prefix))
-                                  (and (string-prefix-ci? prefix mailbox)
-                                       (list (string-append "inbox" delimiter)
-                                             (string-ref delimiter 0)))
-                                  (and (string-prefix? prefix mailbox)
-                                       (list prefix
-                                             (and delimiter
-                                                  (string-ref delimiter
-                                                              0))))))
-                            (loop (cdr entries))))))))
-          (or (try (imap:response:namespace-personal response))
-              (try (imap:response:namespace-shared response))
-              (try (imap:response:namespace-other response)))))))
+  (let* ((slash (string-find-next-char mailbox #\/))
+        (root
+         (if slash
+             (string-head mailbox (fix:+ slash 1))
+             mailbox))
+        (key (imap-url-new-mailbox url (if slash root ""))))
+    (let ((delimiter (hash-table/get imap-delimiters-table key 'UNKNOWN)))
+      (if (eq? delimiter 'UNKNOWN)
+         (let ((delimiter
+                (imap:response:list-delimiter
+                 (with-open-imap-connection url
+                   (lambda (connection)
+                     (imap:command:get-delimiter connection root))))))
+           (let ((delimiter
+                  (and delimiter
+                       (string-ref delimiter 0))))
+             (hash-table/put! imap-delimiters-table key delimiter)
+             delimiter))
+         delimiter))))
+
+(define imap-delimiters-table
+  (make-equal-hash-table))
 \f
 ;;;; Server connection
 
@@ -342,8 +336,7 @@
   (port            define standard initial-value #f)
   (greeting        define standard initial-value #f)
   (capabilities    define standard initial-value '())
-  (delimiter       define standard initial-value 'UNKNOWN)
-  (namespace       define standard initial-value #f)
+  (namespace      define standard initial-value 'UNKNOWN)
   (sequence-number define standard initial-value 0)
   (response-queue  define accessor initializer (lambda () (cons '() '())))
   (folder          define standard initial-value #f)
@@ -526,16 +519,11 @@
                  (imail-ui:delete-stored-pass-phrase url)
                  (error "Unable to log in:"
                         (imap:response:response-text-string response))))))
-       (if (eq? (imap-connection-delimiter connection) 'UNKNOWN)
-           (begin
-             (set-imap-connection-delimiter!
-              connection
-              (imap:response:list-delimiter
-               (car (imap:command:list connection "" "inbox"))))
-             (if (memq 'NAMESPACE (imap-connection-capabilities connection))
-                 (set-imap-connection-namespace!
-                  connection
-                  (imap:command:namespace connection)))))
+       (if (eq? (imap-connection-namespace connection) 'UNKNOWN)
+           (set-imap-connection-namespace!
+            connection
+            (and (memq 'NAMESPACE (imap-connection-capabilities connection))
+                 (imap:command:namespace connection))))
        #t)))
 \f
 (define (close-imap-connection connection)
@@ -572,19 +560,6 @@
        (if (imap-connection-port connection)
            (imap:command:logout connection))
        (close-imap-connection connection))))
-
-(define (imap-url-delimiter url)
-  (let ((connection (get-imap-connection url)))
-    (let ((delimiter (imap-connection-delimiter connection)))
-      (if (eq? delimiter 'UNKNOWN)
-         (with-open-imap-connection url imap-connection-delimiter)
-         delimiter))))
-
-(define (imap-url-namespace url)
-  (let ((connection (get-imap-connection url)))
-    (if (eq? (imap-connection-delimiter connection) 'UNKNOWN)
-       (with-open-imap-connection url imap-connection-namespace)
-       (imap-connection-namespace connection))))
 \f
 ;;;; Folder datatype
 
@@ -1470,8 +1445,14 @@
         'SEARCH key-plist))
 
 (define (imap:command:list connection reference pattern)
-  (imap:command:multiple-response imap:response:list? connection
-                                 'LIST reference pattern))
+  (imap:command:multiple-response imap:response:list? connection 'LIST
+                                 (imap:encode-mailbox-name reference)
+                                 (imap:encode-mailbox-name pattern)))
+
+(define (imap:command:get-delimiter connection reference)
+  (imap:command:single-response imap:response:list? connection 'LIST
+                               (imap:encode-mailbox-name reference)
+                               (imap:encode-mailbox-name "")))
 \f
 (define (imap:command:no-response connection command . arguments)
   (let ((responses (apply imap:command connection command arguments)))

diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 9288c5cf5d673ce38b6ed4dbce205c4e58ad471c..b4d0eff69d453c10381b9985b75019abb3d20664 100644 (file)
--- a/v7/src/imail/imail-rmail.scm
+++ b/v7/src/imail/imail-rmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-rmail.scm,v 1.62 2001/05/13 03:46:04 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.63 2001/05/15 19:46:57 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -28,23 +28,13 @@
 (define-class <rmail-url> (<file-url>))
 (define make-rmail-url (pathname-url-constructor <rmail-url>))
 
-(define-pathname-url-predicate <rmail-url>
+(define-pathname-url-predicates <rmail-url>
+  (lambda (pathname) (check-file-prefix pathname "BABYL OPTIONS:"))
+  (lambda (pathname) pathname #f)
   (lambda (pathname)
-    (case (file-type-indirect pathname)
-      ((REGULAR)
-       (let* ((magic "BABYL OPTIONS:")
-             (n-to-read (string-length magic))
-             (buffer (make-string n-to-read))
-             (n-read
-              (call-with-input-file pathname
-                (lambda (port)
-                  (read-string! buffer port)))))
-        (and (fix:= n-to-read n-read)
-             (string=? buffer magic))))
-      ((#F)
-       (or (string=? (pathname-type pathname) "rmail")
-          (string=? (file-namestring pathname) "RMAIL")))
-      (else #f))))
+    (or (equal? (pathname-type pathname) "rmail")
+       (and (equal? (pathname-name pathname) "RMAIL")
+            (not (pathname-type pathname))))))
 
 (define-method make-peer-url ((url <rmail-url>) name)
   (make-rmail-url

diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 4e9d24ee41cd77b60be62c7d42c482e556da6b7d..df53735aa9b9f726950477e5c8af976208b02ec1 100644 (file)
--- a/v7/src/imail/imail-umail.scm
+++ b/v7/src/imail/imail-umail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-umail.scm,v 1.43 2001/05/13 03:46:17 cph Exp $
+;;; $Id: imail-umail.scm,v 1.44 2001/05/15 19:46:59 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -28,21 +28,10 @@
 (define-class <umail-url> (<file-url>))
 (define make-umail-url (pathname-url-constructor <umail-url>))
 
-(define-pathname-url-predicate <umail-url>
-  (lambda (pathname)
-    (case (file-type-indirect pathname)
-      ((REGULAR)
-       (let* ((magic "From ")
-             (n-to-read (string-length magic))
-             (buffer (make-string n-to-read))
-             (n-read
-              (call-with-input-file pathname
-                (lambda (port)
-                  (read-string! buffer port)))))
-        (and (fix:= n-to-read n-read)
-             (string=? buffer magic))))
-      ((#F) (string=? (pathname-type pathname) "mail"))
-      (else #f))))
+(define-pathname-url-predicates <umail-url>
+  (lambda (pathname) (check-file-prefix pathname "From "))
+  (lambda (pathname) pathname #f)
+  (lambda (pathname) (equal? (pathname-type pathname) "mail")))
 
 (define-method make-peer-url ((url <umail-url>) name)
   (make-umail-url

diff --git a/v7/src/imail/imail-util.scm b/v7/src/imail/imail-util.scm
index b6de90b27c419d3d3e7dbfe0d3c2bd91645aa2d7..9321feb137c25629a7e73c7b9a17069fb934bf34 100644 (file)
--- a/v7/src/imail/imail-util.scm
+++ b/v7/src/imail/imail-util.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-util.scm,v 1.37 2001/05/14 19:27:54 cph Exp $
+;;; $Id: imail-util.scm,v 1.38 2001/05/15 19:47:02 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2001 Massachusetts Institute of Technology
 ;;;
@@ -176,6 +176,19 @@
                           (if (default-object? line-ending) "\n" line-ending)
                           lines))
 \f
+(define (check-file-prefix pathname magic)
+  (let* ((n-to-read (string-length magic))
+        (buffer (make-string n-to-read))
+        (n-read
+         (catch-file-errors (lambda (condition) condition #f)
+           (lambda ()
+             (call-with-input-file pathname
+               (lambda (port)
+                 (read-string! buffer port)))))))
+    (and n-read
+        (fix:= n-to-read n-read)
+        (string=? buffer magic))))
+
 (define (read-required-char port)
   (let ((char (read-char port)))
     (if (eof-object? char)
@@ -376,11 +389,13 @@
              result))))))
 
 (define ((result-filter filter) name directory result)
-  (let ((pathname (parse-namestring (string-append directory name) #f #f)))
-    (cond ((safe-file-directory? pathname)
-          (cons (pathname-as-directory pathname) result))
-         ((filter pathname) (cons pathname result))
-         (else result))))
+  (if (or (string=? name ".") (string=? name ".."))
+      result
+      (let ((pathname (parse-namestring (string-append directory name) #f #f)))
+       (cond ((safe-file-directory? pathname)
+              (cons (pathname-as-directory pathname) result))
+             ((filter pathname) (cons pathname result))
+             (else result)))))
 
 (define (safe-file-directory? pathname)
   (catch-file-errors (lambda (condition) condition #f)