Finish implementing PATHNAME-MIME-TYPE.

diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm
index b76d7faf4f076c042cbf483ebc6f4950154d37fc..aa5d480ec222539e70dc76e90d984d2604dd4804 100644 (file)
--- 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)
 \f
 (define (init-file-specifier->pathname specifier)
 

diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm
index eca8954839f429b1bf6b1a8328df144e62470e2a..f01abe13ac7f4ce0b378a9e6a7d7c083208fe772 100644 (file)
--- 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)
 \f
 ;;;; 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 6db8ae4374e926e800c5deba9b465980f63fe048..9c4ede2a38922729547aa76519ae338d4e23095f 100644 (file)
--- 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