scsh-conservatory
/
scx
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- updated to new install-lib version 

- now load.scm is generated from within pkg-def.scm
This commit is contained in:
frese 2004-02-01 23:12:26 +00:00
parent e2a99da645
commit 573a31f9ea
5 changed files with 165 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
install-lib-module.scm
View File

@ -1,10 +1,12 @@
;;; Installation library for scsh modules. ;;; Installation library for scsh modules.
;;; $Id: install-lib-module.scm,v 1.3 2004/01/04 14:34:32 frese Exp $ ;;; $Id: install-lib-module.scm,v 1.4 2004/02/01 23:12:26 frese 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))

185
install-lib.scm
View File

@ -1,18 +1,56 @@
;;; Installation library for scsh modules. ;;; Installation library for scsh modules.
;;; $Id: install-lib.scm,v 1.3 2004/01/04 14:34:32 frese Exp $ ;;; $Id: install-lib.scm,v 1.4 2004/02/01 23:12:26 frese 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 #o777))
(let-optionals rest ((perms default-perms)) (as-string "creating directory " fname
(dry-run-print "creating directory ~a with permissions ~a" " (perms: " (permissions->string perms) ")")))))
fname
(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) (as-string "creating symbolic link " new-name
(dry-run-print "creating symbolic link ~a pointing to ~a" " pointing to " old-name))))
new-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-value '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

2
install-pkg
View File

@ -1,3 +1,3 @@
#!/bin/sh #!/bin/sh
exec scsh -lm install-lib-module.scm -o configure -o install -e install-main -s "$0" "$@" exec scsh -lm install-lib-module.scm -o pp -o configure -o install -e install-main -s "$0" "$@"
!# !#

78
load.scm.in
View File

@ -1,78 +0,0 @@
(user)
(load-package 'dynamic-externals)
(open 'dynamic-externals)
(open 'external-calls)
(open 'configure)
(open 'signals)
(run
'(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))))))
(run
'(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))))))
(run
'(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))))))))
(run '(let* ((lib-dir (string-append "@yplibdir@/" @yphost@))
(la-file-name (string-append lib-dir "/libscshyp.la"))
(initializer-name "scsh_yp_main"))
(let ((la-alist (read-libtool-la la-file-name)))
(cond
((assoc 'dlname la-alist)
=> (lambda (p)
(dynamic-load (string-append lib-dir "/" (cdr p)))
(call-external (get-external initializer-name))))
(else
(error "Could not figure out libscshyp's name" la-file-name))))))
(run '(let ((lib-dir (string-append "@scxlibdir@/" @scxhost@))
(la-file-name (string-append lib-dir "/libscx.la"))
(initializer-name "scx_init_xlib"))
(let ((la-alist (read-libtool-la la-file-name)))
(cond
((assoc 'dlname la-alist)
=> (lambda (p)
(let ((module-file (string-append lib-dir "/" (cdr p))))
(dynamic-load module-file)
(call-external (get-external initializer-name))
(if (string=? "@scxload_xft_packages@" "yes")
(begin
(call-external (get-external "scx_xft_init"))
(call-external (get-external "scx_xrender_init")))))))
(else
(error "Could not figure out libscx's name" la-file-name))))))
(config)
(load "@scxschemedir@/xlib/xlib-interfaces.scm")
(load "@scxschemedir@/xlib/xlib-packages.scm")
(load "@scxschemedir@/libs/libs-interfaces.scm")
(load "@scxschemedir@/libs/libs-packages.scm")
(user)

55
pkg-def.scm
View File

@ -24,27 +24,40 @@
(zero? (run ,make)))) (zero? (run ,make))))
(exit)))) (exit))))
;; create load.scm with sed, this is platform-independent ;; create load.scm
(if (not (get-option-value 'non-shared-only)) (let ((schemedir (get-directory 'scheme #f))
(begin (libdir (get-directory 'lib #f))
(display "creating load.scm\n") (load-xft-packages (get-option-value 'with-xft)))
(let ((schemedir (get-directory 'scheme #f)) (write-to-load-script
(libdir (get-directory 'lib #f)) `((user)
(load-xft-packages (if (get-option-value 'with-xft) "yes" "no")) (load-package 'dynamic-externals)
(target-dir (get-directory 'base #t)) (open 'dynamic-externals)
(sed-replace (lambda (from to) (open 'external-calls)
(string-append "s|" from "|" to "|g")))) (open 'configure)
(let ((cmd `(sed -e ,(sed-replace "@scxschemedir@" schemedir) (open 'signals)
-e ,(sed-replace "@scxhost@" "(host)") ,@(map (lambda (x) `(run ',x)) tmpl-libtool-la-reader)
-e ,(sed-replace "@scxlibdir@" libdir) (run '(let* ((lib-dir (string-append ,libdir "/" (host)))
-e ,(sed-replace "@scxload_xft_packages@" (la-file-name (string-append lib-dir "/libscx.la"))
load-xft-packages) (initializer-name "scx_init_xlib"))
"load.scm.in")) (let ((la-alist (read-libtool-la la-file-name)))
(tgt (string-append target-dir "/load.scm"))) (cond
(if (get-option-value 'dry-run) ((assoc 'dlname la-alist)
(begin (display cmd) (display " > ") (display tgt) (newline)) => (lambda (p)
(if (not (zero? (run ,cmd (> ,tgt)))) (let ((module-file (string-append lib-dir "/" (cdr p))))
(exit))))))) (dynamic-load module-file)
(call-external (get-external initializer-name))
,(if load-xft-packages
'(begin
(call-external (get-external "scx_xft_init"))
(call-external (get-external "scx_xrender_init")))))))
(else
(error "Could not figure out libscx's name" la-file-name))))))
(config)
(load ,(string-append schemedir "/xlib/xlib-interfaces.scm"))
(load ,(string-append schemedir "/xlib/xlib-packages.scm"))
(load ,(string-append schemedir "/libs/libs-interfaces.scm"))
(load ,(string-append schemedir "/libs/libs-packages.scm"))
(user))))
(install-directory-contents "scheme" 'scheme) (install-directory-contents "scheme" 'scheme)
) )