From cfef23f1b3acffc2c44e7f83a25ed83950dab8d0 Mon Sep 17 00:00:00 2001
From: michel-schinz <michel-schinz>
Date: Sun, 8 Feb 2004 09:50:14 +0000
Subject: [PATCH] Implemented suggestions by Anthony Carrico: - display an
 error message when an unknown layout is given, - the version number in
 "define-package" is now quasi-quoted, - added "install-string" to install an
 arbitrary string in a file, - forbid relative prefixes.

---
 scheme/install-lib/install-lib.scm | 44 ++++++++++++++++++++++++------
 1 file changed, 35 insertions(+), 9 deletions(-)

diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm
index 0be104d..f0d0da1 100755
--- a/scheme/install-lib/install-lib.scm
+++ b/scheme/install-lib/install-lib.scm
@@ -1,5 +1,5 @@
 ;;; Installation library for scsh modules.
-;;; $Id: install-lib.scm,v 1.7 2004/02/01 23:14:39 frese Exp $
+;;; $Id: install-lib.scm,v 1.8 2004/02/08 09:50:14 michel-schinz Exp $
 
 ;; TODO
 ;; - add support for communication between configure and pkg-def.scm
@@ -230,14 +230,20 @@
 ;; Parse a layout given as a string of comma-separated bindings. A
 ;; binding consists of the name of a location, followed by an equal
 ;; sign and the name of the directory to associate to the location.
+;; Return #f if parsing fails.
 (define parse-layout
   (let ((split-defs (infix-splitter ","))
         (split-sides (infix-splitter "=")))
     (lambda (str)
-      (map (lambda (name&value)
-             (let ((name/value (split-sides name&value)))
-               (cons (string->symbol (first name/value)) (second name/value))))
-           (split-defs str)))))
+      (call-with-current-continuation
+       (lambda (return)
+         (map (lambda (name&value)
+                (let ((name/value (split-sides name&value)))
+                  (if (= 2 (length name/value))
+                      (cons (string->symbol (first name/value))
+                            (second name/value))
+                      (return #f))))
+              (split-defs str)))))))
 
 ;; Combine layouts L1 and L2 by adding to L1 all the additional
 ;; mappings found in L2.
@@ -329,8 +335,8 @@
   (syntax-rules ()
     ((define-package name version extensions body ...)
      (add-package (make-package name
-                                (quote version)
-				(quasiquote extensions)
+                                (quasiquote version)
+                                (quasiquote extensions)
                                 (lambda () body ...))))))
 
 ;;
@@ -415,7 +421,7 @@
   (let ((dir (get-directory 'base #t)))
     (create-directory&parents dir)
     (if (not (or (get-option-value 'dry-run)
-		 (get-option-value 'non-shared-only)))
+                 (get-option-value 'non-shared-only)))
         (with-output-to-file (absolute-file-name "load.scm" dir)
           thunk))))
 
@@ -504,6 +510,22 @@
                                      target-rel-dir
                                      perms-fn))))
 
+(define (install-string% layout str target-name location target-rel-dir)
+  (let ((target-dir (absolute-file-name target-rel-dir
+                                        (layout-dir layout location))))
+    (create-directory&parents target-dir)
+    (call-with-output-file (absolute-file-name target-name target-dir)
+      (lambda (port) (write-string str port)))))
+
+(define (install-string str target-name location . rest)
+  (let-optionals rest ((target-rel-dir "."))
+    (if (active-location? location)
+        (install-string% (fluid *install-layout*)
+                         str
+                         target-name
+                         location
+                         target-rel-dir))))
+
 (define *layout* (make-fluid #f))
 (define *install-layout* (make-fluid #f))
 
@@ -631,7 +653,9 @@ END
              (lambda (opt name arg alist)
                (alist-replace 'layout
                               (cond ((assoc arg predefined-layouts) => cdr)
-                                    (else (parse-layout arg)))
+                                    ((parse-layout arg) => identity)
+                                    (else (display-error-and-exit
+                                           "invalid layout ~a" arg)))
                               alist)))
      (option '("layout-from") #t #f
              (lambda (opt name arg alist)
@@ -690,6 +714,8 @@ END
            (activate? (not (alist-get 'inactive options-values))))
       (if (not prefix)
           (display-error-and-exit "no prefix specified (use --prefix option)"))
+      (if (not (file-name-absolute? prefix))
+          (display-error-and-exit "prefix must be an absolute path"))
       (let-fluids *options-values* options-values
         (lambda ()
           (for-each