From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 18 Oct 2004 05:05:52 +0000 (+0000)
Subject: Add support for looking up the MIME type associated with a pathname.
X-Git-Tag: 20090517-FFI~1526
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=03d4491794cde12c74e6f28597bcabc36ce59378;p=mit-scheme.git

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 2b52065d3..d504317eb 100644
--- 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))))))))
 
 (define get-environment-variable)
 (define set-environment-variable!)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 7a4668ae9..6db8ae437 100644
--- 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 4adc9fd18..51f14ddc9 100644
--- 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))))))))))))
 
 (define (user-home-directory user-name)
   (let ((directory ((ucode-primitive get-user-home-directory 1) user-name)))