From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 5 Jul 2000 19:13:11 +0000 (+0000)
Subject: Change file URL syntax to obey RFC 1738.
X-Git-Tag: 20090517-FFI~3382
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=697feae2ee3bda8aa98557ab532323d2d943a8e9;p=mit-scheme.git

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 7ada7b06f..1a72b7d7b 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.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)))))
+
+;;;; 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)))