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.

diff --git a/v7/src/runtime/dosprm.scm b/v7/src/runtime/dosprm.scm
index 607b301139a283b918b9285cd9d7eafd285c605b..2808abef5e158f77d7b3841d5f573c7f0d71d13f 100644 (file)
--- 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))))
 \f
+(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))))))))
+\f
 (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 e5f5eb596da5f0e64aa12f13ab97e0b488ebc935..685caf852f44735691163fed324c33df4d11a7e6 100644 (file)
--- 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))))
 \f
+(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))))))))))
+\f
 (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 b0d0e119ab20da4f61b4448f781a22250f23354b..fe67546090ddc2fe1b67bf95c85fddaa8140990c 100644 (file)
--- 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))))
 \f
+(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))))))))))
+\f
 (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 32125460f9ddbf1fcbd7ddc92cc6848d083470a9..d2b2804d4abeca9a01d6cf27d042c67a51cdd486 100644 (file)
--- 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))
+\f
+(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 e210bee4dc83e4092e507893e780aaa92b1482af..d89451a091a739390faf7969d38279728c5224f6 100644 (file)
--- 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)))
 \f
 ;;; Queues after-restart daemon to clean up environment space