- permissions can now be specified as a function or an integer

(equivalent to a constant function) everywhere,
- create-directory&parents is now independent from the installation
  library and could be reused in other contexts,
- incorporated first part of Martin's changes, which fix a problem
  with install-string: it now accepts optional permissions, and does
  not create a file in a dry run.

scheme/install-lib/install-lib.scm

@@ -1,8 +1,8 @@
 ;;; Installation library for scsh modules.
-;;; $Id: install-lib.scm,v 1.15 2004/04/01 18:36:43 michel-schinz Exp $
+;;; $Id: install-lib.scm,v 1.16 2004/05/12 18:39:04 michel-schinz Exp $
 
 ;; TODO
-;; - think about --host: does it make sense?
+;; - think about --build: does it make sense?
 ;; - get-directory should get 'install or 'final instead of #f #t
 ;; - add a "--debug" option
 ;; - add support for communication between configure and pkg-def.scm
@@ -34,7 +34,7 @@
 ;; requested "major" number matches the one of the library, and the
 ;; requested "minor" is smaller or equal to the one of the library.
 
-(define install-lib-version '(1 0 0))
+(define install-lib-version '(1 1 0))
 
 ;;
 ;; Support code templates
@@ -78,8 +78,7 @@
 ;; Utilities
 ;;
 
-(define default-perms-fn
+(define default-perms #o755)
-  (lambda (name) #o755))
 
 ;; Fail if CONDITION is not true, displaying ERROR-MSG with ARGUMENTS.
 (define (assert condition error-msg . arguments)
@@ -93,15 +92,20 @@
 (define (parent-directory fname)
   (file-name-directory (directory-as-file-name fname)))
 
+(define (get-perms integer/fun fname)
+  (cond ((procedure? integer/fun) (integer/fun fname))
+        ((integer? integer/fun) integer/fun)
+        (else (error "invalid permission specification" integer/fun))))
+
 ;; Create directory FNAME and all its parents, as needed.
 (define (create-directory&parents fname . rest)
-  (let-optionals rest ((perms-fn default-perms-fn))
+  (let-optionals rest ((perms default-perms))
     (let ((parent (parent-directory fname)))
       (if (not (file-exists? parent))
           (apply create-directory&parents parent rest))
       (if (not (file-exists? fname))
-          (-create-directory fname
+          (create-directory fname
-                             (perms-fn (absolute-file-name fname)))))))
+                            (get-perms perms (absolute-file-name fname)))))))
 
 ;; Return the length of the longest prefix common to lists L1 and L2,
 ;; by comparing elements using PRED (defaults to EQUAL?).
@@ -212,6 +216,11 @@
             (as-string "creating directory " fname
                        " (perms: " (permissions->string perms) ")")))))
 
+(define -create-directory&parents
+  (wrap create-directory&parents
+        (lambda (fname . rest)
+          (as-string "creating directory " fname " (and its parents)"))))
+
 (define -create-symlink
   (wrap create-symlink
         (lambda (old-name new-name)
@@ -227,6 +236,20 @@
   (wrap delete-file
         (lambda (fname) (as-string "deleting file " fname))))
 
+(define -call-with-output-file
+  (wrap call-with-output-file
+        (lambda (fname port-function)
+          (let ((string-out (make-string-output-port)))
+            (port-function string-out)
+            (as-string "writing>>\n"
+                       (string-output-port-output string-out)
+                       "<<to file " fname)))))
+
+(define -set-file-mode
+  (wrap set-file-mode
+        (lambda (fname mode)
+          (as-string "setting permissions of " fname " to "
+                     (permissions->string mode)))))
 ;;
 ;; Versions
 ;;
@@ -538,7 +561,7 @@
 (define (with-output-to-load-script* thunk)
   (let* ((dir (get-directory 'base #t))
          (file (absolute-file-name load-script-name dir)))
-    (create-directory&parents dir)
+    (-create-directory&parents dir)
     (if (not (or (get-option-value 'dry-run)
                  (get-option-value 'non-shared-only)))
         (begin
@@ -571,7 +594,7 @@
                                          (file-name-directory lnk-name))
                      lnk-name)))
 
-(define (install-thing% layout name-or-pair location target-rel-dir perms-fn)
+(define (install-thing% layout name-or-pair location target-rel-dir perms)
   (let* ((target-dir (absolute-file-name target-rel-dir
                                          (layout-dir layout location)))
          (source (if (pair? name-or-pair) (car name-or-pair) name-or-pair))
@@ -581,14 +604,14 @@
          (target (absolute-file-name target-name target-dir)))
     (if (not ((get-option-value 'exclude) source))
         (begin
-          (create-directory&parents target-dir perms-fn)
+          (-create-directory&parents target-dir perms)
           (cond ((or (file-regular? source) (file-symlink? source))
                  (-copy-file source target))
                 ((file-directory? source)
                  (if (file-exists? target)
                      (if (file-directory? target)
                          (if (get-option-value 'force)
-                             (set-file-mode target (file-mode source))
+                             (-set-file-mode target (file-mode source))
                              (display-error-and-exit
                               "target directory already exists: " target))
                          (begin
@@ -601,7 +624,7 @@
                                               (absolute-file-name
                                                target-name
                                                target-rel-dir)
-                                              perms-fn))
+                                              perms))
                 (else (display-error-and-exit
                        "cannot install file-system object: " source)))))))
 
@@ -609,20 +632,20 @@
                                      name
                                      location
                                      target-rel-dir
-                                     perms-fn)
+                                     perms)
   (for-each (lambda (thing)
-              (install-thing% layout thing location target-rel-dir perms-fn))
+              (install-thing% layout thing location target-rel-dir perms))
             (map (lambda (f) (absolute-file-name f name))
                  (directory-files name #t))))
 
 (define (install-thing name-or-pair location . rest)
   (if (active-location? location)
-      (let-optionals rest ((target-rel-dir ".") (perms-fn default-perms-fn))
+      (let-optionals rest ((target-rel-dir ".") (perms default-perms))
         (install-thing% (fluid *install-layout*)
                         name-or-pair
                         location
                         target-rel-dir
-                        perms-fn))))
+                        perms))))
 
 (define (install-things names-or-pairs . rest)
   (for-each (lambda (name-or-pair)
@@ -636,30 +659,32 @@
 
 (define (install-directory-contents name location . rest)
   (if (active-location? location)
-      (let-optionals rest ((target-rel-dir ".") (perms-fn default-perms-fn))
+      (let-optionals rest ((target-rel-dir ".") (perms default-perms))
         (install-directory-contents% (fluid *install-layout*)
                                      name
                                      location
                                      target-rel-dir
-                                     perms-fn))))
+                                     perms))))
 
-(define (install-string% layout str target-name location target-rel-dir)
+(define (install-string% layout str target-name location target-rel-dir perms)
   (let* ((target-dir (absolute-file-name target-rel-dir
                                          (layout-dir layout location)))
          (target-full-name (absolute-file-name target-name target-dir)))
-    (create-directory&parents target-dir)
+    (-create-directory&parents target-dir)
     (delete-file-or-fail target-full-name)
-    (call-with-output-file target-full-name
+    (-call-with-output-file target-full-name
-      (lambda (port) (write-string str port)))))
+      (lambda (port) (write-string str port)))
+    (-set-file-mode target-full-name (get-perms perms target-full-name))))
 
 (define (install-string str target-name location . rest)
-  (let-optionals rest ((target-rel-dir "."))
+  (let-optionals rest ((target-rel-dir ".") (perms default-perms))
     (if (active-location? location)
         (install-string% (fluid *install-layout*)
                          str
                          target-name
                          location
-                         target-rel-dir))))
+                         target-rel-dir
+                         perms))))
 
 (define *layout* (make-fluid #f))
 (define *install-layout* (make-fluid #f))