fixed processing of file: URLs to not assume Unix conventions and to distinguish relative and absolute paths

svn: r1463

collects/net/doc.txt

@@ -48,10 +48,15 @@ TYPES ----------------------------------------------------------------
   5 = path,  6 = param, 7 = query, 8 = fragment
 
   If the scheme is "file", then the path is a platform-dependent
-  string assumed to have been constructed using build-path.  The library
+  string. The library does, however, check for the presence of a
-  does, however, check for the presence of a fragment designator and, if
+  fragment designator and, if there is one, separates it from the rest
-  there is one, separates it from the rest of the path.  For non-"file"
+  of the path. If the path is syntactically a directory, the last
-  schemes, the path is a URL path as defined in the standard.
+  string the resulting structure's `path' list is an empty string.
+  If the path is absolute, the `host' is the root path, otherwise
+  `host' is #f.
+
+  For non-"file" schemes, the path is a URL path as defined in the
+  standard.
 
   If a path segment has a parameter, it is represented with
   an instance of the path/param struct. Otherwise, it is
@@ -156,6 +161,8 @@ PROCEDURES -----------------------------------------------------------
 > (url->string url) -> string
 
   Generates a string corresponding to the contents of the url struct.
+  For a "file:" URL, empty strings in the path list are treated as
+  'same for `build-path'.
 
   The `url->string' procedure uses `alist->form-urlencoded' when
   formatting the query, so it it sensitive to the

collects/net/url-unit.ss

@@ -61,6 +61,11 @@
                                            args)))))
             (raise (make-url-exception s (current-continuation-marks))))))
 
+      (define (url->file-path url)
+	(path->string
+	 (apply build-path (or (url-host url) 'same)
+		(map (lambda (x) (if (equal? x "") 'same x)) (url-path url)))))
+
       (define url->string
         (lambda (url)
           (let ((scheme (url-scheme url))
@@ -72,7 +77,8 @@
                 (fragment (url-fragment url)))
             (cond
              ((and scheme (string=? scheme "file"))
-              (string-append "file:" (combine-path-strings path)
+              (string-append "file:" 
+			     (url->file-path url)
                              (or (and (not fragment) "")
                                  (string-append "#" fragment))))
              (else
@@ -142,9 +148,7 @@
       ;; file://get-pure-port : url -> in-port
       (define file://get-pure-port
         (lambda (url)
-          (when (url-host url)
+          (open-input-file (url->file-path url))))
-            (url-error "Don't know how to get files from remote hosts"))
-          (open-input-file (apply build-path (url-path url)))))
 
       (define (schemeless-url url)
         (url-error "Missing protocol (usually \"http:\") at the beginning of URL: ~a" url))
@@ -343,13 +347,28 @@
                           [fragment (caddr path+fragment)])
                       (if (or (relative-path? path)
                               (absolute-path? path))
-                          (make-url "file"
+			  (let-values ([(root elems kind)
-                                    #f  ; user
+					(let loop ([path (simplify-path path)][accum null][kind #f])
-                                    #f  ; host
+					  (let-values ([(base name dir?) (split-path path)])
-                                    #f  ; port
+					    (let ([kind (or kind
-                                    (separate-path-strings path)
+							    (if dir? 'dir 'file))])
-                                    '()  ; query
+					      (cond
-                                    fragment)
+					       [(path? base)
+						(loop base (cons name accum) kind)]
+					       [(eq? base 'relative)
+						(values #f (cons name accum) kind)]
+					       [else
+						(values path accum kind)]))))])
+			    (make-url "file"
+				      #f  ; user
+				      (and root (path->string root))  ; host
+				      #f  ; port
+				      (append (map path->string elems)
+					      (if (eq? kind 'dir)
+						  '("")
+						  null))
+				      '()  ; query
+				      fragment))
                           (url-error "scheme 'file' path ~s neither relative nor absolute" path))))
                   ;; Other scheme:
                   (let ((match (regexp-match-positions rx str)))