Change file URL syntax to obey RFC 1738.

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 7ada7b06fc8803574f4c63f99ae4981c34ec72c1..1a72b7d7b0b7f0adca004858ee34cef2054c72f3 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.52 2000/06/30 17:21:26 cph Exp $
+;;; $Id: imail-file.scm,v 1.53 2000/07/05 19:13:11 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -28,13 +28,13 @@
   (pathname define accessor))
 
 (define-method url-body ((url <file-url>))
-  (->namestring (file-url-pathname url)))
+  (pathname->url-body (file-url-pathname url)))
 
 (define-method url-presentation-name ((url <file-url>))
   (file-namestring (file-url-pathname url)))
 
 (define-method url-body-container-string ((url <file-url>))
-  (directory-namestring (file-url-pathname url)))
+  (pathname->url-body (directory-namestring (file-url-pathname url))))
 
 (define-method url-base-name ((url <file-url>))
   (pathname-name (file-url-pathname url)))
@@ -42,30 +42,71 @@
 (define-method url-exists? ((url <file-url>))
   (file-exists? (file-url-pathname url)))
 
+(define (pathname->url-body pathname)
+  (case (host/type-name (pathname-host pathname))
+    ((UNIX)
+     (let ((string (->namestring pathname)))
+       (if (pathname-absolute? pathname)
+          (string-append "//localhost" string)
+          string)))
+    ((DOS)
+     (let ((string (string-replace (->namestring pathname) #\\ #\/)))
+       (cond ((pathname-device pathname)
+             (string-append "//localhost/" string))
+            ((pathname-absolute? pathname)
+             (string-append "//localhost" string))
+            (else string))))
+    (else (error "Unknown host type:" pathname))))
+
+(define (parse-file-url-body string default-pathname)
+  (let ((finish
+        (lambda (string)
+          (merge-pathnames
+           (case (host/type-name (pathname-host default-pathname))
+             ((UNIX) string)
+             ((DOS)
+              (if (and (fix:>= (string-length string) 3)
+                       (char=? (string-ref string 0) #\/)
+                       (char-alphabetic? (string-ref string 1))
+                       (char=? (string-ref string 0) #\:))
+                  (string-tail string 1)
+                  string))
+             (else (error "Unknown host type:" default-pathname)))
+           default-pathname))))
+    (cond ((string-prefix? "//localhost/" string)
+          (finish (string-tail string (string-length "//localhost"))))
+         ((string-prefix? "///" string)
+          (finish (string-tail string (string-length "//"))))
+         ((string-prefix? "//" string)
+          (error:bad-range-argument string 'PARSE-URL-BODY))
+         (else
+          (finish string)))))
+\f
+;;;; Server operations
+
 (define-method %url-complete-string
     ((string <string>) (default-url <file-url>)
                       if-unique if-not-unique if-not-found)
   (pathname-complete-string
-   (merge-pathnames string
-                   (directory-pathname (file-url-pathname default-url)))
+   (parse-file-url-body string
+                       (directory-pathname (file-url-pathname default-url)))
    (lambda (pathname) pathname #t)
    (lambda (string)
-     (if-unique (->namestring string)))
+     (if-unique (pathname->url-body string)))
    (lambda (prefix get-completions)
-     (if-not-unique (->namestring prefix)
-                   (lambda () (map ->namestring (get-completions)))))
+     (if-not-unique (pathname->url-body prefix)
+                   (lambda () (map pathname->url-body (get-completions)))))
    if-not-found))
 
 (define-method %url-string-completions
     ((string <string>) (default-url <file-url>))
-  (map ->namestring
+  (map pathname->url-body
        (pathname-completions-list
-       (merge-pathnames string
-                        (directory-pathname (file-url-pathname default-url)))
+       (parse-file-url-body
+        string
+        (directory-pathname (file-url-pathname default-url)))
        (lambda (pathname) pathname #t))))
 
-;;;; Server operations
-
 (define-method %delete-folder ((url <file-url>))
   (delete-file (file-url-pathname url)))