From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 31 Jan 2006 18:50:03 +0000 (+0000)
Subject: Implement PATHNAME->URI.
X-Git-Tag: 20090517-FFI~1115
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=50751db7773bf34ba2d62dd4fd806dbdd62b85d2;p=mit-scheme.git

Implement PATHNAME->URI.
---

diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index 0239d1ac6..f57e25d68 100644
--- a/v7/src/runtime/pathnm.scm
+++ b/v7/src/runtime/pathnm.scm
@@ -1,10 +1,10 @@
 #| -*-Scheme-*-
 
-$Id: pathnm.scm,v 14.42 2004/11/26 05:04:27 cph Exp $
+$Id: pathnm.scm,v 14.43 2006/01/31 18:50:02 cph Exp $
 
 Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright 1993,1994,1995,1996,2000,2001 Massachusetts Institute of Technology
-Copyright 2004 Massachusetts Institute of Technology
+Copyright 2004,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -298,6 +298,41 @@ 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)))
+    (receive (scheme authority)
+	(if (pathname-absolute? pathname)
+	    (values 'file (make-uri-authority #f "" #f))
+	    (values #f #f))
+      (make-uri scheme
+		authority
+		(map (lambda (x)
+		       (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))))))
+		#f
+		#f))))
 
 ;;;; Pathname Syntax
 
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 5874bf535..26a3123eb 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,10 +1,11 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.571 2005/12/25 17:04:39 riastradh Exp $
+$Id: runtime.pkg,v 14.572 2006/01/31 18:50:03 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
 Copyright 2000,2001,2002,2003,2004,2005 Massachusetts Institute of Technology
+Copyright 2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -2570,6 +2571,7 @@ USA.
 	  make-pathname
 	  merge-pathnames
 	  parse-namestring
+	  pathname->uri
 	  pathname-absolute?
 	  pathname-as-directory
 	  pathname-default