From 0f85d43cf24368092e73b0dd219987a1f02c1f63 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 24 Apr 1996 03:39:47 +0000 Subject: [PATCH] Implement new "init-file" procedures for maintaining a database of files in the user's home directory. This is used by the Edwin News reader, which needs a convenient place to save its database files. --- v7/src/runtime/dosprm.scm | 58 +++++++++++++++++++++++++++++++++-- v7/src/runtime/ntprm.scm | 63 ++++++++++++++++++++++++++++++++++++++- v7/src/runtime/os2prm.scm | 63 ++++++++++++++++++++++++++++++++++++++- v7/src/runtime/sfile.scm | 36 ++++++++++++++++++++-- v7/src/runtime/unxprm.scm | 10 ++++++- 5 files changed, 222 insertions(+), 8 deletions(-) diff --git a/v7/src/runtime/dosprm.scm b/v7/src/runtime/dosprm.scm index 607b30113..2808abef5 100644 --- a/v7/src/runtime/dosprm.scm +++ b/v7/src/runtime/dosprm.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: dosprm.scm,v 1.37 1996/04/24 03:21:49 cph Exp $ +$Id: dosprm.scm,v 1.38 1996/04/24 03:39:47 cph Exp $ -Copyright (c) 1992-95 Massachusetts Institute of Technology +Copyright (c) 1992-96 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -349,6 +349,60 @@ MIT in each case. |# (file-modification-time input-filename)) (set-file-modes! output-filename (file-modes input-filename)))) +(define (init-file-specifier->pathname specifier) + + (define (read-fat-init-file-map port) + (let loop ((result '())) + (let ((item (read port))) + (if (eof-object? item) + result + (begin + (if (not (and (pair? item) + (init-file-specifier? (car item)) + (string? (cdr item)))) + (error "Malformed init-file map item:" item)) + (loop (cons item result))))))) + + (define (generate-fat-init-file directory) + (let loop ((index 1)) + (let ((filename + (string-append "ini" + (string-pad-left (number->string index) 5 #\0) + ".dat"))) + (if (file-exists? (merge-pathnames filename directory)) + (loop (+ index 1)) + filename)))) + + (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME) + (let ((short-base (merge-pathnames "mitschem.ini/" (user-homedir-pathname)))) + (let ((file-map-pathname (merge-pathnames "filemap.dat" short-base))) + (let ((port #f)) + (dynamic-wind + (lambda () + (set! port (open-i/o-file file-map-pathname)) + unspecific) + (lambda () + (merge-pathnames + (or (let ((entry + (assoc specifier (read-fat-init-file-map port)))) + (and entry + (cdr entry))) + (let ((filename (generate-fat-init-file short-base))) + (let ((channel (port/output-channel port))) + (channel-file-set-position + channel + (channel-file-length channel))) + (write (cons specifier filename) port) + (newline port) + filename)) + short-base)) + (lambda () + (if port + (begin + (close-port port) + (set! port #f) + unspecific)))))))) + (define (select-internal console? handles block?) (let* ((nt/qs-allinput #xff) (select diff --git a/v7/src/runtime/ntprm.scm b/v7/src/runtime/ntprm.scm index e5f5eb596..685caf852 100644 --- a/v7/src/runtime/ntprm.scm +++ b/v7/src/runtime/ntprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: ntprm.scm,v 1.5 1996/04/24 03:21:37 cph Exp $ +$Id: ntprm.scm,v 1.6 1996/04/24 03:39:38 cph Exp $ Copyright (c) 1992-96 Massachusetts Institute of Technology @@ -355,6 +355,67 @@ MIT in each case. |# ((ucode-primitive nt-copy-file 2) (->namestring (merge-pathnames from)) (->namestring (merge-pathnames to)))) +(define (init-file-specifier->pathname specifier) + + (define (read-fat-init-file-map port) + (let loop ((result '())) + (let ((item (read port))) + (if (eof-object? item) + result + (begin + (if (not (and (pair? item) + (init-file-specifier? (car item)) + (string? (cdr item)))) + (error "Malformed init-file map item:" item)) + (loop (cons item result))))))) + + (define (generate-fat-init-file directory) + (let loop ((index 1)) + (let ((filename + (string-append "ini" + (string-pad-left (number->string index) 5 #\0) + ".dat"))) + (if (file-exists? (merge-pathnames filename directory)) + (loop (+ index 1)) + filename)))) + + (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME) + (let ((long-base (merge-pathnames ".mit-scheme/" (user-homedir-pathname)))) + (if (dos/fs-long-filenames? long-base) + (merge-pathnames (apply string-append + (append-map (lambda (string) (list "/" string)) + specifier)) + long-base) + (let ((short-base + (merge-pathnames "mitschem.ini/" (user-homedir-pathname)))) + (let ((file-map-pathname (merge-pathnames "filemap.dat" short-base))) + (let ((port #f)) + (dynamic-wind + (lambda () + (set! port (open-i/o-file file-map-pathname)) + unspecific) + (lambda () + (merge-pathnames + (or (let ((entry + (assoc specifier (read-fat-init-file-map port)))) + (and entry + (cdr entry))) + (let ((filename (generate-fat-init-file short-base))) + (let ((channel (port/output-channel port))) + (channel-file-set-position + channel + (channel-file-length channel))) + (write (cons specifier filename) port) + (newline port) + filename)) + short-base)) + (lambda () + (if port + (begin + (close-port port) + (set! port #f) + unspecific)))))))))) + (define (select-internal console? handles block?) (let* ((nt/qs-allinput #xff) (select diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm index b0d0e119a..fe6754609 100644 --- a/v7/src/runtime/os2prm.scm +++ b/v7/src/runtime/os2prm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: os2prm.scm,v 1.26 1996/04/24 03:25:32 cph Exp $ +$Id: os2prm.scm,v 1.27 1996/04/24 03:39:17 cph Exp $ Copyright (c) 1994-95 Massachusetts Institute of Technology @@ -260,6 +260,67 @@ MIT in each case. |# ((ucode-primitive os2-copy-file 2) (->namestring (merge-pathnames from)) (->namestring (merge-pathnames to)))) +(define (init-file-specifier->pathname specifier) + + (define (read-fat-init-file-map port) + (let loop ((result '())) + (let ((item (read port))) + (if (eof-object? item) + result + (begin + (if (not (and (pair? item) + (init-file-specifier? (car item)) + (string? (cdr item)))) + (error "Malformed init-file map item:" item)) + (loop (cons item result))))))) + + (define (generate-fat-init-file directory) + (let loop ((index 1)) + (let ((filename + (string-append "ini" + (string-pad-left (number->string index) 5 #\0) + ".dat"))) + (if (file-exists? (merge-pathnames filename directory)) + (loop (+ index 1)) + filename)))) + + (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME) + (let ((long-base (merge-pathnames ".mit-scheme/" (user-homedir-pathname)))) + (if (dos/fs-long-filenames? long-base) + (merge-pathnames (apply string-append + (append-map (lambda (string) (list "/" string)) + specifier)) + long-base) + (let ((short-base + (merge-pathnames "mitschem.ini/" (user-homedir-pathname)))) + (let ((file-map-pathname (merge-pathnames "filemap.dat" short-base))) + (let ((port #f)) + (dynamic-wind + (lambda () + (set! port (open-i/o-file file-map-pathname)) + unspecific) + (lambda () + (merge-pathnames + (or (let ((entry + (assoc specifier (read-fat-init-file-map port)))) + (and entry + (cdr entry))) + (let ((filename (generate-fat-init-file short-base))) + (let ((channel (port/output-channel port))) + (channel-file-set-position + channel + (channel-file-length channel))) + (write (cons specifier filename) port) + (newline port) + filename)) + short-base)) + (lambda () + (if port + (begin + (close-port port) + (set! port #f) + unspecific)))))))))) + (define (initialize-system-primitives!) (discard-select-registry-result-vectors!) (add-event-receiver! event:after-restart diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm index 32125460f..d2b2804d4 100644 --- a/v7/src/runtime/sfile.scm +++ b/v7/src/runtime/sfile.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: sfile.scm,v 14.18 1995/10/28 01:16:09 cph Exp $ +$Id: sfile.scm,v 14.19 1996/04/24 03:39:30 cph Exp $ -Copyright (c) 1988-95 Massachusetts Institute of Technology +Copyright (c) 1988-96 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -101,4 +101,34 @@ MIT in each case. |# ((ucode-primitive set-fixed-objects-vector! 1) objects))))) (define (current-file-time) - (call-with-temporary-file-pathname file-modification-time)) \ No newline at end of file + (call-with-temporary-file-pathname file-modification-time)) + +(define (guarantee-init-file-specifier object procedure) + (if (not (init-file-specifier? object)) + (error:wrong-type-argument object "init-file specifier" procedure))) + +(define (init-file-specifier? object) + (and (list? object) + (for-all? object + (lambda (object) + (and (string? object) + (not (string-null? object))))))) + +(define (guarantee-init-file-directory pathname) + (let ((directory (user-homedir-pathname))) + (if (not (file-directory? directory)) + (error "Home directory doesn't exist:" directory))) + (let loop ((pathname pathname)) + (let ((directory (directory-pathname pathname))) + (if (not (file-directory? directory)) + (begin + (loop (directory-pathname-as-file directory)) + (make-directory directory)))))) + +(define (open-input-init-file specifier) + (open-input-file (init-file-specifier->pathname specifier))) + +(define (open-output-init-file specifier #!optional append?) + (let ((pathname (init-file-specifier->pathname specifier))) + (guarantee-init-file-directory pathname) + (open-output-file pathname (if (default-object? append?) #f append?)))) \ No newline at end of file diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm index e210bee4d..d89451a09 100644 --- a/v7/src/runtime/unxprm.scm +++ b/v7/src/runtime/unxprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: unxprm.scm,v 1.43 1996/04/24 03:29:54 cph Exp $ +$Id: unxprm.scm,v 1.44 1996/04/24 03:39:08 cph Exp $ Copyright (c) 1988-95 Massachusetts Institute of Technology @@ -356,6 +356,14 @@ MIT in each case. |# #f (file-modification-time input-filename)) (set-file-modes! output-filename (file-modes input-filename)))) + +(define (init-file-specifier->pathname specifier) + (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME) + (merge-pathnames (apply string-append + (cons ".mit-scheme" + (append-map (lambda (string) (list "/" string)) + specifier))) + (user-homedir-pathname))) ;;; Queues after-restart daemon to clean up environment space -- 2.25.1