From: Chris Hanson Date: Thu, 28 Oct 2004 03:22:07 +0000 (+0000) Subject: Cache contents of MIME-type files. Also, simplify implementation of X-Git-Tag: 20090517-FFI~1518 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0fc24df10bb5e8853e18a3d3ab8841f62c43583e;p=mit-scheme.git Cache contents of MIME-type files. Also, simplify implementation of environment variables on unix systems. --- diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index f5bf1115f..42a30bf7a 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.93 2004/10/18 04:11:41 cph Exp $ +$Id: make.scm,v 14.94 2004/10/28 03:21:23 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1996,1997,1998,2000 Massachusetts Institute of Technology @@ -488,6 +488,7 @@ USA. (RUNTIME WORKING-DIRECTORY) (RUNTIME LOAD) (RUNTIME UNICODE) + ((RUNTIME OS-PRIMITIVES) INITIALIZE-MIME-TYPES! #f) ;; Syntax (RUNTIME NUMBER-PARSER) (RUNTIME PARSER) diff --git a/v7/src/runtime/ntprm.scm b/v7/src/runtime/ntprm.scm index d504317eb..b85487002 100644 --- a/v7/src/runtime/ntprm.scm +++ b/v7/src/runtime/ntprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ntprm.scm,v 1.46 2004/10/18 05:05:28 cph Exp $ +$Id: ntprm.scm,v 1.47 2004/10/28 03:21:31 cph Exp $ Copyright 1995,1996,1998,1999,2000,2001 Massachusetts Institute of Technology Copyright 2003,2004 Massachusetts Institute of Technology @@ -111,20 +111,18 @@ 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 (os/suffix-mime-type suffix) + (let* ((name (string-append "HKEY_CLASSES_ROOT\\." suffix)) + (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/os2prm.scm b/v7/src/runtime/os2prm.scm index aa5d480ec..f057aad15 100644 --- a/v7/src/runtime/os2prm.scm +++ b/v7/src/runtime/os2prm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: os2prm.scm,v 1.53 2004/10/22 04:47:29 cph Exp $ +$Id: os2prm.scm,v 1.54 2004/10/28 03:21:39 cph Exp $ Copyright 1994,1995,1997,1998,1999,2000 Massachusetts Institute of Technology Copyright 2001,2003,2004 Massachusetts Institute of Technology @@ -286,9 +286,9 @@ USA. ((ucode-primitive os2-copy-file 2) (->namestring (merge-pathnames from)) (->namestring (merge-pathnames to)))) -(define (os/pathname-mime-type pathname) +(define (os/suffix-mime-type suffix) ;; **** not yet implemented **** - pathname + suffix #f) (define (init-file-specifier->pathname specifier) diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm index f01abe13a..2a52cf74e 100644 --- a/v7/src/runtime/pathnm.scm +++ b/v7/src/runtime/pathnm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: pathnm.scm,v 14.38 2004/10/22 04:47:34 cph Exp $ +$Id: pathnm.scm,v 14.39 2004/10/28 03:21:47 cph Exp $ Copyright 1987,1988,1989,1990,1991,1992 Massachusetts Institute of Technology Copyright 1993,1994,1995,1996,2000,2001 Massachusetts Institute of Technology @@ -289,19 +289,21 @@ these rules: (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)))))))) + (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))) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 9c4ede2a3..65c5402b1 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.501 2004/10/22 04:47:42 cph Exp $ +$Id: runtime.pkg,v 14.502 2004/10/28 03:21:59 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,8 +623,8 @@ USA. os/form-shell-command os/make-subprocess os/parse-path-string - os/pathname-mime-type os/shell-file-name + os/suffix-mime-type set-file-modes! set-file-times! temporary-directory-pathname diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm index 51f14ddc9..f988c0baf 100644 --- a/v7/src/runtime/unxprm.scm +++ b/v7/src/runtime/unxprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: unxprm.scm,v 1.67 2004/10/18 05:05:52 cph Exp $ +$Id: unxprm.scm,v 1.68 2004/10/28 03:22:07 cph Exp $ Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology Copyright 1994,1995,1997,1998,1999,2000 Massachusetts Institute of Technology @@ -147,76 +147,107 @@ USA. (or access-time (file-access-time-direct filename)) (or modification-time (file-modification-time-direct filename))))) -(define get-environment-variable) -(define set-environment-variable!) -(define delete-environment-variable!) -(define reset-environment-variables!) - -(let ((environment-variables '())) - ;; Kludge: since getenv returns #f for unbound, - ;; that can also be the marker for a deleted variable - (define-integrable *variable-deleted* #f) - - (set! get-environment-variable - (lambda (variable) - (cond ((not (string? variable)) - (error "GET-ENVIRONMENT-VARIABLE: Variable must be a string" - variable)) - ((assoc variable environment-variables) - => - cdr) - (else ((ucode-primitive get-environment-variable 1) - variable))))) - - (set! set-environment-variable! - (lambda (variable value) - (cond ((not (string? variable)) - (error "SET-ENVIRONMENT-VARIABLE!: Variable must be a string" - variable value)) - ((assoc variable environment-variables) - => - (lambda (pair) - (set-cdr! pair value))) - (else - (set! environment-variables - (cons (cons variable value) - environment-variables)))) - unspecific)) - - (set! delete-environment-variable! - (lambda (variable) - (set-environment-variable! variable *variable-deleted*))) - - (set! reset-environment-variables! - (lambda () (set! environment-variables '())))) +(define environment-variables) + +(define (get-environment-variable name) + (guarantee-string name 'GET-ENVIRONMENT-VARIABLE) + (let ((value (hash-table/get environment-variables name 'NONE))) + (if (eq? value 'NONE) + (let ((value ((ucode-primitive get-environment-variable 1) name))) + (hash-table/put! environment-variables name value) + value) + value))) + +(define (set-environment-variable! name value) + (guarantee-string name 'SET-ENVIRONMENT-VARIABLE!) + (if value + (guarantee-string value 'SET-ENVIRONMENT-VARIABLE!)) + (hash-table/put! environment-variables name value)) + +(define (delete-environment-variable! name) + (guarantee-string name 'DELETE-ENVIRONMENT-VARIABLE!) + (hash-table/remove! environment-variables name)) + +(define (reset-environment-variables!) + (hash-table/clear! environment-variables)) (define (initialize-system-primitives!) + (set! environment-variables (make-string-hash-table)) (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))) + +(define (os/suffix-mime-type suffix) + (import-mime-types) + (hash-table/get mime-types suffix #f)) + +(define (initialize-mime-types!) + (set! mime-types (make-string-hash-table)) + (set! mime-types-files (make-vector (length mime-types-pathnames) (list #f))) + unspecific) + +(define mime-types) +(define mime-types-files) + +(define mime-types-pathnames + '("/etc/mime.types" "~/.mime.types")) + +(define (import-mime-types) + (if (let loop ((pathnames mime-types-pathnames) (index 0) (changed? #f)) + (if (pair? pathnames) + (loop (cdr pathnames) + (fix:+ index 1) + (boolean/or (import-mime-types-file (car pathnames) index) + changed?)) + changed?)) + (with-thread-events-blocked + (lambda () + (hash-table/clear! mime-types) + (for-each-vector-element mime-types-files + (lambda (p) + (for-each (lambda (entry) + (let ((type (car entry))) + (for-each (lambda (suffix) + (hash-table/put! mime-types + suffix + type)) + (cdr entry)))) + (cdr p)))))))) + +(define (import-mime-types-file pathname index) + (let ((changed? #f)) + (let loop ((t (file-modification-time pathname))) + (with-thread-events-blocked + (lambda () + (let ((t* (car (vector-ref mime-types-files index)))) + (cond ((eqv? t* t) + unspecific) + (t + (vector-set! mime-types-files + index + (cons t (read-mime-types-file pathname))) + (set! changed? #t)) + (t* + (vector-set! mime-types-files + index + (list #f)) + (set! changed? #t)))))) + (let ((t* (file-modification-time pathname))) + (if (not (eqv? t* t)) + (loop t*)))) + changed?)) + +(define (read-mime-types-file pathname) + (call-with-input-file pathname + (lambda (port) + (let loop ((entries '())) + (let ((line (read-line port))) + (if (eof-object? line) + (reverse! entries) + (loop (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)))))))))))) + entries + (cons (burst-string line char-set:whitespace #t) + entries)))))))))) (define (user-home-directory user-name) (let ((directory ((ucode-primitive get-user-home-directory 1) user-name)))