From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 28 Oct 2004 19:38:23 +0000 (+0000)
Subject: Move MIME-type support to "sfile.scm" and flesh it out.  Define a new
X-Git-Tag: 20090517-FFI~1517
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2fba0e7fd1d1c0718b3a6ef71a9c66c0fa10e1a3;p=mit-scheme.git

Move MIME-type support to "sfile.scm" and flesh it out.  Define a new
record type to represent MIME types.
---

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index 42a30bf7a..19074f5b2 100644
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.94 2004/10/28 03:21:23 cph Exp $
+$Id: make.scm,v 14.95 2004/10/28 19:38:09 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,2000 Massachusetts Institute of Technology
@@ -371,7 +371,8 @@ USA.
        '(("prop1d" . (RUNTIME 1D-PROPERTY))
 	 ("events" . (RUNTIME EVENT-DISTRIBUTOR))
 	 ("gdatab" . (RUNTIME GLOBAL-DATABASE))
-	 ("gcfinal" . (RUNTIME GC-FINALIZER))))
+	 ("gcfinal" . (RUNTIME GC-FINALIZER))
+	 ("string" . (RUNTIME STRING))))
       (load-files
        (lambda (files)
 	 (do ((files files (cdr files)))
@@ -400,6 +401,7 @@ USA.
   (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t)
   (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t)
   (package-initialize '(RUNTIME GC-FINALIZER) 'INITIALIZE-PACKAGE! #t)
+  (package-initialize '(RUNTIME STRING) 'INITIALIZE-PACKAGE! #t)
 
   ;; Load everything else.
   ((lexical-reference environment-for-package 'LOAD-PACKAGES-FROM-FILE)
@@ -488,6 +490,7 @@ USA.
    (RUNTIME WORKING-DIRECTORY)
    (RUNTIME LOAD)
    (RUNTIME UNICODE)
+   (RUNTIME SIMPLE-FILE-OPS)
    ((RUNTIME OS-PRIMITIVES) INITIALIZE-MIME-TYPES! #f)
    ;; Syntax
    (RUNTIME NUMBER-PARSER)
@@ -517,7 +520,6 @@ USA.
    (RUNTIME STARBASE-GRAPHICS)
    (RUNTIME X-GRAPHICS)
    (RUNTIME OS2-GRAPHICS)
-   (RUNTIME STRING)
    ;; Emacs -- last because it installs hooks everywhere which must be initted.
    (RUNTIME EMACS-INTERFACE)
    ;; More debugging
diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index 2a52cf74e..d0470dd0a 100644
--- a/v7/src/runtime/pathnm.scm
+++ b/v7/src/runtime/pathnm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: pathnm.scm,v 14.39 2004/10/28 03:21:47 cph Exp $
+$Id: pathnm.scm,v 14.40 2004/10/28 19:38:13 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,37 +287,6 @@ these rules:
 		    (or (%pathname-name pathname) name)
 		    (or (%pathname-type pathname) type)
 		    (or (%pathname-version pathname) version))))
-
-(define (pathname-mime-type pathname)
-  (let ((suffix (pathname-type pathname)))
-    (and (string? suffix)
-	 (let ((type (os/suffix-mime-type suffix)))
-	   (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
 
@@ -645,5 +614,4 @@ these rules:
 
 (define (initialize-package!)
   (reset-package!)
-  (add-event-receiver! event:after-restore reset-package!)
-  (initialize-mime-token!))
\ No newline at end of file
+  (add-event-receiver! event:after-restore reset-package!))
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 65c5402b1..5be646180 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.502 2004/10/28 03:21:59 cph Exp $
+$Id: runtime.pkg,v 14.503 2004/10/28 19:38:18 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -413,6 +413,7 @@ USA.
   (files "sfile")
   (parent (runtime))
   (export ()
+	  <mime-type>
 	  allocate-temporary-file
 	  call-with-temporary-file-pathname
 	  call-with-temporary-filename
@@ -422,6 +423,10 @@ USA.
 	  delete-file
 	  delete-file-no-errors
 	  directory-file-names
+	  error:not-mime-token
+	  error:not-mime-token-string
+	  error:not-mime-type
+	  error:not-mime-type-string
 	  file-access
 	  file-directory?
 	  file-eq?
@@ -443,13 +448,29 @@ USA.
 	  file-writeable?
 	  guarantee-init-file-directory
 	  guarantee-init-file-specifier
+	  guarantee-mime-token
+	  guarantee-mime-token-string
+	  guarantee-mime-type
+	  guarantee-mime-type-string
 	  hard-link-file
 	  init-file-specifier?
 	  make-directory
+	  make-mime-type
+	  mime-token-string?
+	  mime-token?
+	  mime-type->string
+	  mime-type-string?
+	  mime-type/subtype
+	  mime-type/top-level
+	  mime-type?
 	  open-input-init-file
 	  open-output-init-file
+	  pathname-mime-type
+	  pathname-type->mime-type
 	  rename-file
-	  soft-link-file))
+	  soft-link-file
+	  string->mime-type)
+  (initialization (initialize-package!)))
 
 (define-package (runtime symbol)
   (files "symbol")
@@ -2466,7 +2487,6 @@ USA.
 	  pathname-device
 	  pathname-directory
 	  pathname-host
-	  pathname-mime-type
 	  pathname-name
 	  pathname-new-device
 	  pathname-new-directory
diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm
index d1d79d3e2..c96b2685f 100644
--- a/v7/src/runtime/sfile.scm
+++ b/v7/src/runtime/sfile.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: sfile.scm,v 14.35 2003/09/05 20:51:22 cph Exp $
+$Id: sfile.scm,v 14.36 2004/10/28 19:38:23 cph Exp $
 
 Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology
 Copyright 1999,2001,2003 Massachusetts Institute of Technology
@@ -245,4 +245,107 @@ USA.
 (define (open-output-init-file specifier #!optional append?)
   (let ((pathname (init-file-specifier->pathname specifier)))
     (guarantee-init-file-directory pathname)
-    (open-output-file pathname (if (default-object? append?) #f append?))))
\ No newline at end of file
+    (open-output-file pathname (if (default-object? append?) #f append?))))
+
+;;;; MIME types
+
+(define-record-type <mime-type>
+    (%make-mime-type top-level subtype)
+    mime-type?
+  (top-level mime-type/top-level)
+  (subtype mime-type/subtype))
+
+(set-record-type-unparser-method! <mime-type>
+  (standard-unparser-method 'MIME-TYPE
+    (lambda (mime-type port)
+      (write-char #\space port)
+      (write-string (mime-type->string mime-type) port))))
+
+(define (make-mime-type top-level subtype)
+  (guarantee-mime-token top-level 'MAKE-MIME-TYPE)
+  (guarantee-mime-token subtype 'MAKE-MIME-TYPE)
+  (%make-mime-type top-level subtype))
+
+(define (mime-type->string mime-type)
+  (guarantee-mime-type mime-type 'MIME-TYPE->STRING)
+  (string-append (symbol-name (mime-type/top-level mime-type))
+		 "/"
+		 (symbol-name (mime-type/subtype mime-type))))
+
+(define (string->mime-type string)
+  (guarantee-mime-type-string string 'STRING->MIME-TYPE)
+  (let ((slash (string-find-next-char string #\/)))
+    (%make-mime-type (intern (string-head string slash))
+		     (intern (string-tail string (fix:+ slash 1))))))
+
+(define (mime-type-string? object)
+  (and (string? object)
+       (string-is-mime-type? object)))
+
+(define (string-is-mime-type? string)
+  (let ((end (string-length string)))
+    (let ((i (check-mime-token-syntax string 0 end)))
+      (and (fix:> i 0)
+	   (fix:< i end)
+	   (char=? (string-ref string i) #\/)
+	   (fix:< (fix:+ i 1) end)
+	   (fix:= end (check-mime-token-syntax string (fix:+ i 1) end))
+	   i))))
+
+(define (mime-token? object)
+  (and (interned-symbol? object)
+       (string-is-mime-token? (symbol-name object))))
+
+(define (mime-token-string? object)
+  (and (string? object)
+       (string-is-mime-token? object)))
+
+(define (string-is-mime-token? string)
+  (let ((end (string-length string)))
+    (fix:= end (check-mime-token-syntax string 0 end))))
+
+(define (check-mime-token-syntax string start end)
+  (let loop ((i start))
+    (if (fix:< i end)
+	(if (char-set-member? char-set:mime-token (string-ref string i))
+	    (loop (fix:+ i 1))
+	    i)
+	end)))
+
+(define char-set:mime-token)
+(define (initialize-package!)
+  (set! char-set:mime-token
+	(char-set-difference (ascii-range->char-set #x21 #x7F)
+			     (string->char-set "()<>@,;:\\\"/[]?=")))
+  unspecific)
+
+(define (pathname-mime-type pathname)
+  (pathname-type->mime-type (pathname-type pathname)))
+
+(define (pathname-type->mime-type type)
+  (and (string? type)
+       (let ((string (os/suffix-mime-type type)))
+	 (and string
+	      (string->mime-type string)))))
+
+(define-syntax define-guarantee
+  (sc-macro-transformer
+   (lambda (form environment)
+     (if (syntax-match? '(SYMBOL EXPRESSION) (cdr form))
+	 (let ((root (cadr form))
+	       (desc (close-syntax (caddr form) environment)))
+	   (let ((p-name (symbol root '?))
+		 (g-name (symbol 'guarantee- root))
+		 (e-name (symbol 'error:not- root)))
+	     `(BEGIN
+		(DEFINE (,g-name OBJECT CALLER)
+		  (IF (NOT (,(close-syntax p-name environment) OBJECT))
+		      (,(close-syntax e-name environment) OBJECT CALLER)))
+		(DEFINE (,e-name OBJECT CALLER)
+		  (ERROR:WRONG-TYPE-ARGUMENT OBJECT ,desc CALLER)))))
+	 (ill-formed-syntax form)))))
+
+(define-guarantee mime-type "MIME type")
+(define-guarantee mime-type-string "MIME type string")
+(define-guarantee mime-token "MIME token")
+(define-guarantee mime-token-string "MIME token string")
\ No newline at end of file