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

- added "install-sub-package" function

This commit is contained in:
michel-schinz 2004-02-19 07:29:16 +00:00
parent 9f7024b044
commit 01e77fb69f
2 changed files with 64 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
scheme/install-lib/install-lib-module.scm
View File

@ -1,5 +1,5 @@
;;; Installation library for scsh modules.
;;; $Id: install-lib-module.scm,v 1.6 2004/02/08 09:50:47 michel-schinz Exp $
;;; $Id: install-lib-module.scm,v 1.7 2004/02/19 07:29:16 michel-schinz Exp $
;;; Interfaces
@ -21,6 +21,7 @@
install-directories
install-directory-contents
install-string
install-sub-package
identity
parse-boolean
@ -38,6 +39,7 @@
(define-structure install install-interface
(open scheme-with-scsh
cells
fluids
let-opt
srfi-1

92
scheme/install-lib/install-lib.scm
View File

@ -1,10 +1,11 @@
;;; Installation library for scsh modules.
;;; $Id: install-lib.scm,v 1.9 2004/02/10 20:25:47 michel-schinz Exp $
;;; $Id: install-lib.scm,v 1.10 2004/02/19 07:29:16 michel-schinz Exp $
;; TODO
;; - add a "--debug" option
;; - add support for communication between configure and pkg-def.scm
;; - add support for image creation,
;; - add support to maintain a documentation index,
;; - add support for image creation
;; - add support to maintain a documentation index
;;
;; Support code templates
@ -330,11 +331,12 @@
(alist-get ext (package-extensions pkg) #f))
;; List of all defined packages
(define packages '())
(define *packages* (make-fluid #f))
;; Add PKG to the above list of all defined packages.
(define (add-package pkg)
(set! packages (cons pkg packages)))
(cell-set! (fluid *packages*)
(cons pkg (cell-ref (fluid *packages*)))))
(define-syntax define-package
(syntax-rules ()
@ -344,6 +346,14 @@
(quasiquote extensions)
(lambda () body ...))))))
;; Load (and evaluate the contents of) the FILE and return the list of
;; packages it defines.
(define (load-packages file)
(let-fluid *packages* (make-cell '())
(lambda ()
(load-quietly file)
(cell-ref (fluid *packages*)))))
;;
;; Package options
;;
@ -554,6 +564,48 @@
*install-layout* install-layout
(package-install-thunk pkg)))
;; Install all PACKAGES with the given OPTIONS-VALUES.
(define (install-packages packages options-values)
(let* ((prefix (alist-get 'prefix options-values))
(dest-dir (alist-get 'dest-dir options-values))
(dest-prefix (and prefix (re-root-file-name prefix dest-dir)))
(layout-fn (alist-get 'layout options-values))
(layout-to (alist-get 'layout-to options-values))
(build (alist-get 'build options-values))
(non-shared-only? (alist-get 'non-shared-only options-values))
(activate? (not (alist-get 'inactive options-values))))
(let-fluids *options-values* options-values
(lambda ()
(for-each
(lambda (pkg)
(let* ((rel-layout (layout-fn build pkg))
(layout (absolute-layout rel-layout prefix))
(i-layout (absolute-layout rel-layout dest-prefix)))
(if layout-to
(call-with-output-file
(string-append layout-to "_" (package-full-name pkg))
(lambda (port)
(write rel-layout port) (newline port))))
(install-package layout i-layout pkg)
(if (and activate? (not non-shared-only?))
(activate-package i-layout pkg))))
packages)))))
(define (install-sub-package dir . rest)
(let-optionals rest ((options-diff '()))
(with-cwd dir
(install-packages
(load-packages package-definition-file)
(fold (lambda (diff options)
(cond ((pair? diff)
(cons diff (alist-delete (car diff) options)))
((symbol? diff)
(alist-delete diff options))
(else
(error "invalid option difference" diff))))
(fluid *options-values*)
options-diff)))))
;;
;; Error handling
;;
@ -708,39 +760,17 @@ END
(if (not (file-exists? package-definition-file))
(display-error-and-exit "cannot find package definition file (~a)"
package-definition-file))
(load-quietly package-definition-file)
(let ((all-pkg-opts (all-package-options packages)))
(let* ((packages (load-packages package-definition-file))
(all-pkg-opts (all-package-options packages)))
(if (not (null? all-pkg-opts))
(complete-usage! all-pkg-opts))
(let* ((all-opts (append options (map pkg-opt->option all-pkg-opts)))
(all-dfts (append options-defaults
(map pkg-opt-key&default all-pkg-opts)))
(options-values (parse-options (cdr cmd-line) all-opts all-dfts))
(prefix (alist-get 'prefix options-values))
(dest-dir (alist-get 'dest-dir options-values))
(dest-prefix (and prefix (re-root-file-name prefix dest-dir)))
(layout-fn (alist-get 'layout options-values))
(layout-to (alist-get 'layout-to options-values))
(build (alist-get 'build options-values))
(non-shared-only? (alist-get 'non-shared-only options-values))
(activate? (not (alist-get 'inactive options-values))))
(prefix (alist-get 'prefix options-values)))
(if (not prefix)
(display-error-and-exit "no prefix specified (use --prefix option)"))
(if (not (file-name-absolute? prefix))
(display-error-and-exit "prefix must be an absolute path"))
(let-fluids *options-values* options-values
(lambda ()
(for-each
(lambda (pkg)
(let* ((rel-layout (layout-fn build pkg))
(layout (absolute-layout rel-layout prefix))
(i-layout (absolute-layout rel-layout dest-prefix)))
(if layout-to
(call-with-output-file
(string-append layout-to "_" (package-full-name pkg))
(lambda (port)
(write rel-layout port) (newline port))))
(install-package layout i-layout pkg)
(if (and activate? (not non-shared-only?))
(activate-package i-layout pkg))))
packages))))))
(install-packages packages options-values))))