- added with-output-to-load-script(*) and write-to-load-script
functions, which provide support for creating the package-loading script, - added a code template to load libtool's ".la" files, stolen from scsh-yp (by Eric Knauel), - added "--verbose" option, - preserve permissions of copied files/directories, and use a function to obtain permissions for new directories.
This commit is contained in:
parent
a4bde841c8
commit
6687435871
|
@ -1,10 +1,12 @@
|
||||||
;;; Installation library for scsh modules.
|
;;; Installation library for scsh modules.
|
||||||
;;; $Id: install-lib-module.scm,v 1.4 2003/12/21 20:55:40 michel-schinz Exp $
|
;;; $Id: install-lib-module.scm,v 1.5 2004/02/01 17:22:43 michel-schinz Exp $
|
||||||
|
|
||||||
;;; Interfaces
|
;;; Interfaces
|
||||||
|
|
||||||
(define-interface install-interface
|
(define-interface install-interface
|
||||||
(export version->string
|
(export tmpl-libtool-la-reader
|
||||||
|
|
||||||
|
version->string
|
||||||
string->version
|
string->version
|
||||||
version-compare
|
version-compare
|
||||||
version<?
|
version<?
|
||||||
|
@ -25,6 +27,9 @@
|
||||||
|
|
||||||
get-directory
|
get-directory
|
||||||
get-option-value
|
get-option-value
|
||||||
|
with-output-to-load-script*
|
||||||
|
(with-output-to-load-script :syntax)
|
||||||
|
write-to-load-script
|
||||||
|
|
||||||
install-main))
|
install-main))
|
||||||
|
|
||||||
|
@ -38,5 +43,6 @@
|
||||||
srfi-9
|
srfi-9
|
||||||
srfi-13
|
srfi-13
|
||||||
srfi-37
|
srfi-37
|
||||||
configure)
|
configure
|
||||||
|
pp)
|
||||||
(files install-lib))
|
(files install-lib))
|
||||||
|
|
|
@ -1,18 +1,56 @@
|
||||||
;;; Installation library for scsh modules.
|
;;; Installation library for scsh modules.
|
||||||
;;; $Id: install-lib.scm,v 1.5 2003/12/22 14:13:13 frese Exp $
|
;;; $Id: install-lib.scm,v 1.6 2004/02/01 17:22:43 michel-schinz Exp $
|
||||||
|
|
||||||
;; TODO
|
;; TODO
|
||||||
|
;; - add support for communication between configure and pkg-def.scm
|
||||||
;; - add support for image creation,
|
;; - add support for image creation,
|
||||||
;; - add support to maintain a documentation index,
|
;; - add support to maintain a documentation index,
|
||||||
;; - add "--verbose" to show whats being done.
|
;; - maybe add a "--force" option to overwrite existing files
|
||||||
;; - add "--log" option to specify a log file.
|
|
||||||
;; - decide what to do when target files already exist
|
;;
|
||||||
|
;; Support code templates
|
||||||
|
;;
|
||||||
|
;; These templates are meant to be inserted in package-loading
|
||||||
|
;; scripts.
|
||||||
|
|
||||||
|
;; Template to parse libtool's ".la" files.
|
||||||
|
(define tmpl-libtool-la-reader
|
||||||
|
'((define (normalize-la-entry key val)
|
||||||
|
(let ((left-quotes-rx (rx (: bos #\')))
|
||||||
|
(right-quotes-rx (rx (: #\' eos)))
|
||||||
|
(kill-matches
|
||||||
|
(lambda (rx str)
|
||||||
|
(regexp-substitute/global #f rx str 'pre 'post))))
|
||||||
|
(cons (string->symbol key)
|
||||||
|
(kill-matches left-quotes-rx
|
||||||
|
(kill-matches right-quotes-rx val)))))
|
||||||
|
(define add-la-entry
|
||||||
|
(let ((splitter (infix-splitter (rx #\=)))
|
||||||
|
(comment-rx (rx (: bos #\#))))
|
||||||
|
(lambda (line alist)
|
||||||
|
(cond
|
||||||
|
((and (not (regexp-search? comment-rx line))
|
||||||
|
(string-index line #\=))
|
||||||
|
(let ((lst (splitter line)))
|
||||||
|
(if (= 2 (length lst))
|
||||||
|
(cons (apply normalize-la-entry lst) alist)
|
||||||
|
(error "Could not read la entry" line list))))
|
||||||
|
(else alist)))))
|
||||||
|
(define (read-libtool-la file-name)
|
||||||
|
(call-with-input-file
|
||||||
|
file-name
|
||||||
|
(lambda (port)
|
||||||
|
(let lp ((line (read-line port)) (alist '()))
|
||||||
|
(if (eof-object? line)
|
||||||
|
alist
|
||||||
|
(lp (read-line port) (add-la-entry line alist)))))))))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Utilities
|
;; Utilities
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define default-perms #o755)
|
(define default-perms-fn
|
||||||
|
(lambda (name) #o755))
|
||||||
|
|
||||||
;; Return the name of the parent directory of FNAME.
|
;; Return the name of the parent directory of FNAME.
|
||||||
(define (parent-directory fname)
|
(define (parent-directory fname)
|
||||||
|
@ -20,12 +58,13 @@
|
||||||
|
|
||||||
;; Create directory FNAME and all its parents, as needed.
|
;; Create directory FNAME and all its parents, as needed.
|
||||||
(define (create-directory&parents fname . rest)
|
(define (create-directory&parents fname . rest)
|
||||||
(let-optionals rest ((perms default-perms))
|
(let-optionals rest ((perms-fn default-perms-fn))
|
||||||
(let ((parent (parent-directory fname)))
|
(let ((parent (parent-directory fname)))
|
||||||
(if (not (file-exists? parent))
|
(if (not (file-exists? parent))
|
||||||
(apply create-directory&parents parent rest))
|
(apply create-directory&parents parent rest))
|
||||||
(if (not (file-exists? fname))
|
(if (not (file-exists? fname))
|
||||||
(-create-directory fname perms)))))
|
(-create-directory fname
|
||||||
|
(perms-fn (absolute-file-name fname)))))))
|
||||||
|
|
||||||
;; Return the length of the longest prefix common to lists L1 and L2,
|
;; Return the length of the longest prefix common to lists L1 and L2,
|
||||||
;; by comparing elements using PRED (defaults to EQUAL?).
|
;; by comparing elements using PRED (defaults to EQUAL?).
|
||||||
|
@ -54,17 +93,16 @@
|
||||||
(path-list->file-name (append new-root-pl (cdr fname-pl)))
|
(path-list->file-name (append new-root-pl (cdr fname-pl)))
|
||||||
(error "no root to replace in relative file name" fname))))
|
(error "no root to replace in relative file name" fname))))
|
||||||
|
|
||||||
;; Copy file/symlink SOURCE to TARGET and set the permisions of TARGET
|
;; Copy file/symlink SOURCE to TARGET. TARGET must be the name of a
|
||||||
;; to PERMS. TARGET must be the name of a non-existing file (i.e. it
|
;; non-existing file (i.e. it cannot be the name of a directory).
|
||||||
;; cannot be the name of a directory).
|
(define (copy-file source target)
|
||||||
(define (copy-file source target perms)
|
|
||||||
(if (file-exists? target)
|
(if (file-exists? target)
|
||||||
(error "copy-file: target file exists" target))
|
(error "copy-file: target file exists" target))
|
||||||
(if (file-symlink? source)
|
(if (file-symlink? source)
|
||||||
(create-symlink (read-symlink source) target)
|
(create-symlink (read-symlink source) target)
|
||||||
(begin
|
(begin
|
||||||
(run (cp ,source ,target))
|
(run (cp ,source ,target))
|
||||||
(set-file-mode target perms))))
|
(set-file-mode target (file-mode source)))))
|
||||||
|
|
||||||
;; Like "load" but without printing anything.
|
;; Like "load" but without printing anything.
|
||||||
(define load-quietly
|
(define load-quietly
|
||||||
|
@ -91,49 +129,47 @@
|
||||||
((not (null? rest)) (first rest))
|
((not (null? rest)) (first rest))
|
||||||
(else (error "internal error: cannot find key in alist" key alist))))
|
(else (error "internal error: cannot find key in alist" key alist))))
|
||||||
|
|
||||||
|
;; Convert all arguments to strings using DISPLAY and concatenate the
|
||||||
|
;; result in a single string which is returned.
|
||||||
|
(define (as-string . args)
|
||||||
|
(call-with-string-output-port
|
||||||
|
(lambda (port) (for-each (lambda (arg) (display arg port)) args))))
|
||||||
|
|
||||||
;; Return a string of max(M,N) white spaces.
|
;; Return a string of max(M,N) white spaces.
|
||||||
(define (spaces m n) (make-string (max m n) #\space))
|
(define (spaces m n) (make-string (max m n) #\space))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Support for dry runs.
|
;; Support for dry runs / verbose operation.
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(define (wrap-for-dry-run real-fn dry-fn)
|
(define (wrap real-fn info-fn)
|
||||||
(lambda args
|
(lambda args
|
||||||
(apply (if (get-option-value 'dry-run) dry-fn real-fn) args)))
|
(if (or (get-option-value 'verbose) (get-option-value 'dry-run))
|
||||||
|
(begin (display (apply info-fn args)) (newline)))
|
||||||
(define (dry-run-print msg . args)
|
(if (not (get-option-value 'dry-run))
|
||||||
(apply format #t msg args) (newline))
|
(apply real-fn args))))
|
||||||
|
|
||||||
(define -create-directory
|
(define -create-directory
|
||||||
(wrap-for-dry-run
|
(wrap create-directory
|
||||||
create-directory
|
|
||||||
(lambda (fname . rest)
|
(lambda (fname . rest)
|
||||||
(let-optionals rest ((perms default-perms))
|
(let-optionals rest ((perms #o777))
|
||||||
(dry-run-print "creating directory ~a with permissions ~a"
|
(as-string "creating directory " fname
|
||||||
fname
|
" (perms: " (permissions->string perms) ")")))))
|
||||||
(permissions->string perms))))))
|
|
||||||
|
|
||||||
(define -create-symlink
|
(define -create-symlink
|
||||||
(wrap-for-dry-run
|
(wrap create-symlink
|
||||||
create-symlink
|
|
||||||
(lambda (old-name new-name)
|
(lambda (old-name new-name)
|
||||||
(dry-run-print "creating symbolic link ~a pointing to ~a"
|
(as-string "creating symbolic link " new-name
|
||||||
new-name
|
" pointing to " old-name))))
|
||||||
old-name))))
|
|
||||||
|
|
||||||
(define -copy-file
|
(define -copy-file
|
||||||
(wrap-for-dry-run
|
(wrap copy-file
|
||||||
copy-file
|
(lambda (source target)
|
||||||
(lambda (source target perms)
|
(as-string "copying file " source " to " target))))
|
||||||
(dry-run-print "copying file ~a to ~a with permissions ~a"
|
|
||||||
source
|
|
||||||
target
|
|
||||||
(permissions->string perms)))))
|
|
||||||
|
|
||||||
(define -delete-file
|
(define -delete-file
|
||||||
(wrap-for-dry-run delete-file
|
(wrap delete-file
|
||||||
(lambda (fname) (dry-run-print "deleting file ~a" fname))))
|
(lambda (fname) (as-string "deleting file " fname))))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Versions
|
;; Versions
|
||||||
|
@ -368,6 +404,31 @@
|
||||||
(else '())))
|
(else '())))
|
||||||
packages))
|
packages))
|
||||||
|
|
||||||
|
;;
|
||||||
|
;; Load script handling
|
||||||
|
;;
|
||||||
|
|
||||||
|
;; Evaluate THUNK with CURRENT-OUTPUT-PORT opened on the current
|
||||||
|
;; package's loading script (in the install directory). During a dry
|
||||||
|
;; run, or when only non-shared data has to be installed, do nothing.
|
||||||
|
(define (with-output-to-load-script* thunk)
|
||||||
|
(let ((dir (get-directory 'base #t)))
|
||||||
|
(create-directory&parents dir)
|
||||||
|
(if (not (or (get-option-value 'dry-run) (get-option 'non-shared-only)))
|
||||||
|
(with-output-to-file (absolute-file-name "load.scm" dir)
|
||||||
|
thunk))))
|
||||||
|
|
||||||
|
;; Sugar for with-output-to-load-script*.
|
||||||
|
(define-syntax with-output-to-load-script
|
||||||
|
(syntax-rules ()
|
||||||
|
((with-output-to-load-script body ...)
|
||||||
|
(with-output-to-load-script* (lambda () body ...)))))
|
||||||
|
|
||||||
|
;; Pretty-print all the elements of s-exps, one after the other, to
|
||||||
|
;; the current package's loading script (in the install directory).
|
||||||
|
(define (write-to-load-script s-exps)
|
||||||
|
(with-output-to-load-script (for-each p s-exps)))
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Actions
|
;; Actions
|
||||||
;;
|
;;
|
||||||
|
@ -383,7 +444,7 @@
|
||||||
(file-name-directory lnk-name))
|
(file-name-directory lnk-name))
|
||||||
lnk-name)))
|
lnk-name)))
|
||||||
|
|
||||||
(define (install-thing% layout name-or-pair location target-rel-dir perms)
|
(define (install-thing% layout name-or-pair location target-rel-dir perms-fn)
|
||||||
(let* ((target-dir (absolute-file-name target-rel-dir
|
(let* ((target-dir (absolute-file-name target-rel-dir
|
||||||
(layout-dir layout location)))
|
(layout-dir layout location)))
|
||||||
(source (if (pair? name-or-pair) (car name-or-pair) name-or-pair))
|
(source (if (pair? name-or-pair) (car name-or-pair) name-or-pair))
|
||||||
|
@ -391,33 +452,37 @@
|
||||||
(cdr name-or-pair)
|
(cdr name-or-pair)
|
||||||
name-or-pair)))
|
name-or-pair)))
|
||||||
(target (absolute-file-name target-name target-dir)))
|
(target (absolute-file-name target-name target-dir)))
|
||||||
(create-directory&parents target-dir perms)
|
(create-directory&parents target-dir perms-fn)
|
||||||
(cond ((or (file-regular? source) (file-symlink? source))
|
(cond ((or (file-regular? source) (file-symlink? source))
|
||||||
(-copy-file source target perms))
|
(-copy-file source target))
|
||||||
((file-directory? source)
|
((file-directory? source)
|
||||||
(-create-directory target perms)
|
(-create-directory target (file-mode source))
|
||||||
(install-directory-contents% layout
|
(install-directory-contents% layout
|
||||||
source
|
source
|
||||||
location
|
location
|
||||||
(absolute-file-name target-name
|
(absolute-file-name target-name
|
||||||
target-rel-dir)
|
target-rel-dir)
|
||||||
perms))
|
perms-fn))
|
||||||
(else (error "cannot install file-system object" source)))))
|
(else (error "cannot install file-system object" source)))))
|
||||||
|
|
||||||
(define (install-directory-contents% layout name location target-rel-dir perms)
|
(define (install-directory-contents% layout
|
||||||
|
name
|
||||||
|
location
|
||||||
|
target-rel-dir
|
||||||
|
perms-fn)
|
||||||
(for-each (lambda (thing)
|
(for-each (lambda (thing)
|
||||||
(install-thing% layout thing location target-rel-dir perms))
|
(install-thing% layout thing location target-rel-dir perms-fn))
|
||||||
(map (lambda (f) (absolute-file-name f name))
|
(map (lambda (f) (absolute-file-name f name))
|
||||||
(directory-files name #t))))
|
(directory-files name #t))))
|
||||||
|
|
||||||
(define (install-thing name-or-pair location . rest)
|
(define (install-thing name-or-pair location . rest)
|
||||||
(if (active-location? location)
|
(if (active-location? location)
|
||||||
(let-optionals rest ((target-rel-dir ".") (perms default-perms))
|
(let-optionals rest ((target-rel-dir ".") (perms-fn default-perms-fn))
|
||||||
(install-thing% (fluid *install-layout*)
|
(install-thing% (fluid *install-layout*)
|
||||||
name-or-pair
|
name-or-pair
|
||||||
location
|
location
|
||||||
target-rel-dir
|
target-rel-dir
|
||||||
perms))))
|
perms-fn))))
|
||||||
|
|
||||||
(define (install-things names-or-pairs . rest)
|
(define (install-things names-or-pairs . rest)
|
||||||
(for-each (lambda (name-or-pair)
|
(for-each (lambda (name-or-pair)
|
||||||
|
@ -431,23 +496,12 @@
|
||||||
|
|
||||||
(define (install-directory-contents name location . rest)
|
(define (install-directory-contents name location . rest)
|
||||||
(if (active-location? location)
|
(if (active-location? location)
|
||||||
(let-optionals rest ((target-rel-dir ".") (perms default-perms))
|
(let-optionals rest ((target-rel-dir ".") (perms-fn default-perms-fn))
|
||||||
(install-directory-contents% (fluid *install-layout*)
|
(install-directory-contents% (fluid *install-layout*)
|
||||||
name
|
name
|
||||||
location
|
location
|
||||||
target-rel-dir
|
target-rel-dir
|
||||||
perms))))
|
perms-fn))))
|
||||||
|
|
||||||
(define (install-empty-directory% layout name location dir . rest)
|
|
||||||
(let-optionals rest ((perms default-perms))
|
|
||||||
(-create-directory (absolute-file-name dir (layout-dir layout location))
|
|
||||||
perms)))
|
|
||||||
|
|
||||||
(define (install-empty-directory&parents% layout name location dir . rest)
|
|
||||||
(let-optionals rest ((perms default-perms))
|
|
||||||
(create-directory&parents
|
|
||||||
(absolute-file-name dir (layout-dir layout location))
|
|
||||||
perms)))
|
|
||||||
|
|
||||||
(define *layout* (make-fluid #f))
|
(define *layout* (make-fluid #f))
|
||||||
(define *install-layout* (make-fluid #f))
|
(define *install-layout* (make-fluid #f))
|
||||||
|
@ -488,6 +542,7 @@ options:
|
||||||
--layout <layout> specify layout of installation directory
|
--layout <layout> specify layout of installation directory
|
||||||
(predefined: ~a)
|
(predefined: ~a)
|
||||||
--dry-run don't do anything, print what would have been done
|
--dry-run don't do anything, print what would have been done
|
||||||
|
--verbose print messages about what is being done
|
||||||
--inactive don't activate package after installing it
|
--inactive don't activate package after installing it
|
||||||
--non-shared-only only install platform-dependent files, if any
|
--non-shared-only only install platform-dependent files, if any
|
||||||
|
|
||||||
|
@ -588,7 +643,8 @@ END
|
||||||
(option '("non-shared-only") #f #f
|
(option '("non-shared-only") #f #f
|
||||||
(alist-boolean-updater 'non-shared-only))
|
(alist-boolean-updater 'non-shared-only))
|
||||||
(option '("inactive") #f #f (alist-boolean-updater 'inactive))
|
(option '("inactive") #f #f (alist-boolean-updater 'inactive))
|
||||||
(option '("dry-run") #f #f (alist-boolean-updater 'dry-run)))))
|
(option '("dry-run") #f #f (alist-boolean-updater 'dry-run))
|
||||||
|
(option '("verbose") #f #f (alist-boolean-updater 'verbose)))))
|
||||||
|
|
||||||
(define options-defaults
|
(define options-defaults
|
||||||
`((prefix . #f)
|
`((prefix . #f)
|
||||||
|
@ -598,7 +654,8 @@ END
|
||||||
(build . ,(host))
|
(build . ,(host))
|
||||||
(non-shared-only . #f)
|
(non-shared-only . #f)
|
||||||
(inactive . #f)
|
(inactive . #f)
|
||||||
(dry-run . #f)))
|
(dry-run . #f)
|
||||||
|
(verbose . #f)))
|
||||||
|
|
||||||
(define (parse-options args options defaults)
|
(define (parse-options args options defaults)
|
||||||
(args-fold args
|
(args-fold args
|
||||||
|
|
|
@ -1,3 +1,3 @@
|
||||||
#!/bin/sh
|
#!/bin/sh
|
||||||
exec scsh -lm configure.scm -lm install-lib-module.scm -o configure -o install -e install-main -s "$0" "$@"
|
exec scsh -lm configure.scm -lm install-lib-module.scm -o pp -o configure -o install -e install-main -s "$0" "$@"
|
||||||
!#
|
!#
|
||||||
|
|
Loading…
Reference in New Issue