From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 28 Oct 2004 22:53:28 +0000 (+0000)
Subject: Add ability to define associations between pathname types and MIME
X-Git-Tag: 20090517-FFI~1511
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3e731884b4da6b17c5326b26bc252a269ab0ddd7;p=mit-scheme.git

Add ability to define associations between pathname types and MIME
types.
---

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 5be646180..44113480e 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.503 2004/10/28 19:38:18 cph Exp $
+$Id: runtime.pkg,v 14.504 2004/10/28 22:53:20 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -415,6 +415,7 @@ USA.
   (export ()
 	  <mime-type>
 	  allocate-temporary-file
+	  associate-pathname-type-with-mime-type
 	  call-with-temporary-file-pathname
 	  call-with-temporary-filename
 	  current-file-time
@@ -423,6 +424,7 @@ USA.
 	  delete-file
 	  delete-file-no-errors
 	  directory-file-names
+	  disassociate-pathname-type-from-mime-type
 	  error:not-mime-token
 	  error:not-mime-token-string
 	  error:not-mime-type
diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm
index 971fb68a3..839ceeeac 100644
--- a/v7/src/runtime/sfile.scm
+++ b/v7/src/runtime/sfile.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sfile.scm,v 14.37 2004/10/28 22:39:56 cph Exp $
+$Id: sfile.scm,v 14.38 2004/10/28 22:53:28 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1999,2001,2003,2004 Massachusetts Institute of Technology
@@ -258,9 +258,19 @@ USA.
 
 (define (pathname-type->mime-type type)
   (and (string? type)
-       (let ((string (os/suffix-mime-type type)))
-	 (and string
-	      (string->mime-type string)))))
+       (or (hash-table/get local-type-map type #f)
+	   (let ((string (os/suffix-mime-type type)))
+	     (and string
+		  (string->mime-type string))))))
+
+(define (associate-pathname-type-with-mime-type type mime-type)
+  (guarantee-string type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE)
+  (guarantee-mime-type mime-type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE)
+  (hash-table/put! local-type-map type mime-type))
+
+(define (disassociate-pathname-type-from-mime-type type)
+  (guarantee-string type 'DISASSOCIATE-PATHNAME-TYPE-FROM-MIME-TYPE)
+  (hash-table/remove! local-type-map type))
 
 (define-record-type <mime-type>
     (%%make-mime-type top-level subtype)
@@ -299,19 +309,19 @@ USA.
 (define interned-mime-types)
 (define unusual-interned-mime-types)
 (define char-set:mime-token)
+(define local-type-map)
+
 (define (initialize-package!)
   (set! interned-mime-types
-	(let ((e (vector-length top-level-mime-types)))
-	  (let ((v (make-vector e)))
-	    (do ((i 0 (fix:+ i 1)))
-		((not (fix:< i e)))
-	      (vector-set! v i (make-eq-hash-table)))
-	    v)))
-  (set! unusual-interned-mime-types
-	(make-equal-hash-table))
+	(vector-map (lambda (token) token (make-eq-hash-table))
+		    top-level-mime-types))
+  (set! unusual-interned-mime-types (make-equal-hash-table))
   (set! char-set:mime-token
 	(char-set-difference (ascii-range->char-set #x21 #x7F)
 			     (string->char-set "()<>@,;:\\\"/[]?=")))
+  (set! local-type-map (make-string-hash-table))
+  (associate-pathname-type-with-mime-type "scm"
+					  (make-mime-type 'TEXT 'X-SCHEME))
   unspecific)
 
 (define (mime-type->string mime-type)