#| -*-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
(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))))))
\f
(define get-environment-variable)
(define set-environment-variable!)
#| -*-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
(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)))
#| -*-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
(or access-time (file-access-time-direct filename))
(or modification-time (file-modification-time-direct filename)))))
\f
-(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)))
+\f
+(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))))))))))
\f
(define (user-home-directory user-name)
(let ((directory ((ucode-primitive get-user-home-directory 1) user-name)))
projects / mit-scheme.git / commitdiff