From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 22 Oct 2004 04:47:42 +0000 (+0000)
Subject: Finish implementing PATHNAME-MIME-TYPE.
X-Git-Tag: 20090517-FFI~1525
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=54fe001be7e514769f90a2d92ab28ebf51774401;p=mit-scheme.git

Finish implementing PATHNAME-MIME-TYPE.
---

diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm
index b76d7faf4..aa5d480ec 100644
--- a/v7/src/runtime/os2prm.scm
+++ b/v7/src/runtime/os2prm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: os2prm.scm,v 1.52 2004/02/16 05:37:14 cph Exp $
+$Id: os2prm.scm,v 1.53 2004/10/22 04:47:29 cph Exp $
 
 Copyright 1994,1995,1997,1998,1999,2000 Massachusetts Institute of Technology
 Copyright 2001,2003,2004 Massachusetts Institute of Technology
@@ -285,6 +285,11 @@ USA.
 (define (copy-file from to)
   ((ucode-primitive os2-copy-file 2) (->namestring (merge-pathnames from))
 				     (->namestring (merge-pathnames to))))
+
+(define (os/pathname-mime-type pathname)
+  ;; **** not yet implemented ****
+  pathname
+  #f)
 
 (define (init-file-specifier->pathname specifier)
 
diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index eca895483..f01abe13a 100644
--- a/v7/src/runtime/pathnm.scm
+++ b/v7/src/runtime/pathnm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: pathnm.scm,v 14.37 2004/02/16 05:37:40 cph Exp $
+$Id: pathnm.scm,v 14.38 2004/10/22 04:47:34 cph Exp $
 
 Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright 1993,1994,1995,1996,2000,2001 Massachusetts Institute of Technology
@@ -287,6 +287,35 @@ these rules:
 		    (or (%pathname-name pathname) name)
 		    (or (%pathname-type pathname) type)
 		    (or (%pathname-version pathname) version))))
+
+(define (pathname-mime-type pathname)
+  (let ((type (os/pathname-mime-type pathname)))
+    (and type
+	 (begin
+	   (guarantee-string type 'PATHNAME-MIME-TYPE)
+	   (let ((parts (burst-string type #\/ #f)))
+	     (if (not (and (pair? parts)
+			   (mime-token? (car parts))
+			   (pair? (cdr parts))
+			   (mime-token? (cadr parts))
+			   (null? (cddr parts))))
+		 (error "Malformed MIME-type string:" type))
+	     (cons (intern (car parts))
+		   (intern (cadr parts))))))))
+
+(define (mime-token? string)
+  (let ((end (string-length string)))
+    (let loop ((i 0))
+      (or (fix:= i end)
+	  (and (char-set-member? char-set:mime-token (string-ref string i))
+	       (loop (fix:+ i 1)))))))
+
+(define char-set:mime-token)
+(define (initialize-mime-token!)
+  (set! char-set:mime-token
+	(char-set-difference (ascii-range->char-set #x21 #x7F)
+			     (string->char-set "()<>@,;:\\\"/[]?=")))
+  unspecific)
 
 ;;;; Pathname Syntax
 
@@ -614,4 +643,5 @@ these rules:
 
 (define (initialize-package!)
   (reset-package!)
-  (add-event-receiver! event:after-restore reset-package!))
\ No newline at end of file
+  (add-event-receiver! event:after-restore reset-package!)
+  (initialize-mime-token!))
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 6db8ae437..9c4ede2a3 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.500 2004/10/18 05:05:44 cph Exp $
+$Id: runtime.pkg,v 14.501 2004/10/22 04:47:42 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -2466,6 +2466,7 @@ USA.
 	  pathname-device
 	  pathname-directory
 	  pathname-host
+	  pathname-mime-type
 	  pathname-name
 	  pathname-new-device
 	  pathname-new-directory