Add support for looking up the MIME type associated with a pathname.

diff --git a/v7/src/runtime/ntprm.scm b/v7/src/runtime/ntprm.scm
index 2b52065d3b4de2e4cab1fe648170b90490b76443..d504317ebabe1dd45156c9c6b0b7bb75c8cf2292 100644 (file)
--- a/v7/src/runtime/ntprm.scm
+++ b/v7/src/runtime/ntprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: ntprm.scm,v 1.45 2004/02/16 05:37:03 cph Exp $
+$Id: ntprm.scm,v 1.46 2004/10/18 05:05:28 cph Exp $
 
 Copyright 1995,1996,1998,1999,2000,2001 Massachusetts Institute of Technology
 Copyright 2003,2004 Massachusetts Institute of Technology
@@ -110,6 +110,21 @@ USA.
 
 (define (file-time->universal-time time) (+ time epoch))
 (define (universal-time->file-time time) (- time epoch))
+
+(define (os/pathname-mime-type pathname)
+  (let ((type (pathname-type pathname)))
+    (and (string? type)
+        (let* ((name (string-append "HKEY_CLASSES_ROOT\\." type))
+               (key (win32-registry/open-key name #f)))
+          (and key
+               (receive (type value)
+                   (win32-registry/get-value key "Content Type")
+                 (and type
+                      (begin
+                        (if (not (eq? type 'REG_SZ))
+                            (error "Wrong value type in registry entry:"
+                                   name))
+                        value))))))))
 \f
 (define get-environment-variable)
 (define set-environment-variable!)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 7a4668ae923caf057401596640260bf6a2364e8c..6db8ae4374e926e800c5deba9b465980f63fe048 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.499 2004/10/18 04:11:54 cph Exp $
+$Id: runtime.pkg,v 14.500 2004/10/18 05:05:44 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -623,6 +623,7 @@ USA.
          os/form-shell-command
          os/make-subprocess
          os/parse-path-string
+         os/pathname-mime-type
          os/shell-file-name
          set-file-modes!
          set-file-times!

diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm
index 4adc9fd18fc045ced5da57f8cbdb1cf183d40fd2..51f14ddc971a2eae0d72298baeecbdfa723f3a0c 100644 (file)
--- a/v7/src/runtime/unxprm.scm
+++ b/v7/src/runtime/unxprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: unxprm.scm,v 1.66 2004/02/16 05:39:29 cph Exp $
+$Id: unxprm.scm,v 1.67 2004/10/18 05:05:52 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1997,1998,1999,2000 Massachusetts Institute of Technology
@@ -192,6 +192,31 @@ USA.
 
 (define (initialize-system-primitives!)
   (add-event-receiver! event:after-restart reset-environment-variables!))
+
+(define (os/pathname-mime-type pathname)
+  (let ((suffix (pathname-type pathname)))
+    (and (string? suffix)
+        (or (search-mime-types-file "~/.mime.types" suffix)
+            (search-mime-types-file "/etc/mime.types" suffix)))))
+
+(define (search-mime-types-file pathname suffix)
+  (and (file-readable? pathname)
+       (call-with-input-file pathname
+        (lambda (port)
+          (let loop ()
+            (let ((line (read-line port)))
+              (and (not (eof-object? line))
+                   (let ((line (string-trim line)))
+                     (if (or (string-null? line)
+                             (char=? (string-ref line 0) #\#))
+                         (loop)
+                         (let ((tokens
+                                (burst-string line char-set:whitespace #t)))
+                           (if (there-exists? (cdr tokens)
+                                 (lambda (suffix*)
+                                   (string=? suffix* suffix)))
+                               (car tokens)
+                               (loop))))))))))))
 \f
 (define (user-home-directory user-name)
   (let ((directory ((ucode-primitive get-user-home-directory 1) user-name)))