From 3eee4ba1a80fbd2be127955f71c0c43f514538c5 Mon Sep 17 00:00:00 2001 From: michel-schinz Date: Wed, 12 May 2004 18:39:04 +0000 Subject: [PATCH] - 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 | 75 ++++++++++++++++++++---------- 1 file changed, 50 insertions(+), 25 deletions(-) diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index 1e5b849..008f175 100755 --- a/scheme/install-lib/install-lib.scm +++ b/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 - (lambda (name) #o755)) +(define default-perms #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 - (perms-fn (absolute-file-name fname))))))) + (create-directory 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) + "<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 - (lambda (port) (write-string str port))))) + (-call-with-output-file target-full-name + (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))