- 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.
This commit is contained in:
michel-schinz
parent
001f7057c1
commit
3eee4ba1a8
|
|
@ -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)
|
||||
"<<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
|
||||
(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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue