From d42d558f2b20cc2a89cf95fc1d1e54a2c3771aba Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 7 Mar 2006 20:22:49 +0000
Subject: [PATCH] Implement URI->PATHNAME.

---
 v7/src/runtime/pathnm.scm  | 92 +++++++++++++++++++++++++++++---------
 v7/src/runtime/runtime.pkg |  3 +-
 2 files changed, 72 insertions(+), 23 deletions(-)

diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index 4734b51ac..aabd723b3 100644
--- a/v7/src/runtime/pathnm.scm
+++ b/v7/src/runtime/pathnm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: pathnm.scm,v 14.44 2006/02/16 05:36:38 cph Exp $
+$Id: pathnm.scm,v 14.45 2006/03/07 20:22:45 cph Exp $
 
 Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright 1993,1994,1995,1996,2000,2001 Massachusetts Institute of Technology
@@ -298,7 +298,7 @@ these rules:
 		    (or (%pathname-name pathname) name)
 		    (or (%pathname-type pathname) type)
 		    (or (%pathname-version pathname) version))))
-
+
 (define (pathname->uri pathname)
   (let ((pathname (->pathname pathname)))
     (make-uri (if (pathname-absolute? pathname) 'file #f)
@@ -307,28 +307,76 @@ these rules:
 		     (if (eq? x 'WILD)
 			 "*"
 			 (string->utf8-string x)))
-		   (let ((missing?
-			  (lambda (x)
-			    (or (not x)
-				(eq? x 'UNSPECIFIC)))))
-		     (append (if (pathname-absolute? pathname)
-				 (list "")
-				 '())
-			     (let ((device (pathname-device pathname))
-				   (directory (pathname-directory pathname)))
-			       (if (missing? device)
-				   (if (missing? directory)
-				       '()
-				       (cdr directory))
-				   (cons device (cdr directory))))
-			     (let ((name (file-namestring pathname)))
-			       (if (missing? name)
-				   (if (pathname-absolute? pathname)
-				       (list "")
-				       '())
-				   (list name))))))
+		   (append (if (pathname-absolute? pathname)
+			       (list "")
+			       '())
+			   (let ((device (pathname-device pathname))
+				 (directory (pathname-directory pathname)))
+			     (if (missing-component? device)
+				 (if (missing-component? directory)
+				     '()
+				     (cdr directory))
+				 (cons device (cdr directory))))
+			   (let ((name (file-namestring pathname)))
+			     (if (missing-component? name)
+				 (if (pathname-absolute? pathname)
+				     (list "")
+				     '())
+				 (list name)))))
 	      #f
 	      #f)))
+
+(define (uri->pathname uri)
+  (let ((uri (->uri uri 'URI->PATHNAME))
+	(defaults *default-pathname-defaults*)
+	(lose (lambda () (error:bad-range-argument uri 'URI->PATHNAME)))
+	(finish
+	 (lambda (device path keyword)
+	   (receive (directory name type)
+	       (if (pair? path)
+		   (let ((d (cons keyword (except-last-pair path)))
+			 (s (car (last-pair path))))
+		     (if (string-null? s)
+			 (values d #f #f)
+			 (let ((pn (parse-namestring s)))
+			   (values d
+				   (pathname-name pn)
+				   (pathname-type pn)))))
+		   (values (list keyword) #f #f))
+	     (make-pathname #f
+			    device
+			    directory
+			    name
+			    type
+			    #f)))))
+    (let ((scheme (uri-scheme uri))
+	  (path
+	   (map (lambda (x)
+		  (if (string=? x "*")
+		      'WILD
+		      (utf8-string->string x)))
+		(uri-path uri))))
+      (case scheme
+	((file)
+	 (if (not (and (pair? path)
+		       (string-null? (car path))))
+	     (lose))
+	 (let ((path (cdr path)))
+	   (receive (device path)
+	       (let ((device (pathname-device defaults)))
+		 (if (and (pair? path)
+			  (not (missing-component? device)))
+		     (values (car path) (cdr path))
+		     (values device path)))
+	     (if (not (pair? path))
+		 (lose))
+	     (finish device path 'ABSOLUTE))))
+	((#f) (finish #f path 'RELATIVE))
+	(else (error:bad-range-argument uri 'URI->PATHNAME))))))
+
+(define (missing-component? x)
+  (or (not x)
+      (eq? x 'UNSPECIFIC)))
 
 ;;;; Pathname Syntax
 
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index ee20de1c1..9481f5b08 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.577 2006/03/07 19:56:21 cph Exp $
+$Id: runtime.pkg,v 14.578 2006/03/07 20:22:49 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -2628,6 +2628,7 @@ USA.
 	  pathname?
 	  system-library-directory-pathname
 	  system-library-pathname
+	  uri->pathname
 	  user-homedir-pathname)
   (initialization (initialize-package!)))
 
-- 
2.25.1