Removed files from install-lib.
This commit is contained in:
mainzelm
parent
805a374149
commit
d717897ee6
|
|
@ -1,48 +0,0 @@
|
|||
;;; Installation library for scsh modules.
|
||||
;;; $Id: install-lib-module.scm,v 1.4 2004/02/01 23:12:26 frese Exp $
|
||||
|
||||
;;; Interfaces
|
||||
|
||||
(define-interface install-interface
|
||||
(export tmpl-libtool-la-reader
|
||||
|
||||
version->string
|
||||
string->version
|
||||
version-compare
|
||||
version<?
|
||||
version>?
|
||||
version=?
|
||||
|
||||
(define-package :syntax)
|
||||
|
||||
install-file
|
||||
install-files
|
||||
install-directory
|
||||
install-directories
|
||||
install-directory-contents
|
||||
|
||||
identity
|
||||
parse-boolean
|
||||
show-boolean
|
||||
|
||||
get-directory
|
||||
get-option-value
|
||||
with-output-to-load-script*
|
||||
(with-output-to-load-script :syntax)
|
||||
write-to-load-script
|
||||
|
||||
install-main))
|
||||
|
||||
;;; Structures
|
||||
|
||||
(define-structure install install-interface
|
||||
(open scheme-with-scsh
|
||||
fluids
|
||||
let-opt
|
||||
srfi-1
|
||||
srfi-9
|
||||
srfi-13
|
||||
srfi-37
|
||||
configure
|
||||
pp)
|
||||
(files install-lib))
|
||||
707
install-lib.scm
707
install-lib.scm
|
|
@ -1,707 +0,0 @@
|
|||
;;; Installation library for scsh modules.
|
||||
;;; $Id: install-lib.scm,v 1.4 2004/02/01 23:12:26 frese Exp $
|
||||
|
||||
;; TODO
|
||||
;; - add support for communication between configure and pkg-def.scm
|
||||
;; - add support for image creation,
|
||||
;; - add support to maintain a documentation index,
|
||||
;; - maybe add a "--force" option to overwrite existing files
|
||||
|
||||
;;
|
||||
;; 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
|
||||
;;
|
||||
|
||||
(define default-perms-fn
|
||||
(lambda (name) #o755))
|
||||
|
||||
;; Return the name of the parent directory of FNAME.
|
||||
(define (parent-directory fname)
|
||||
(file-name-directory (directory-as-file-name fname)))
|
||||
|
||||
;; Create directory FNAME and all its parents, as needed.
|
||||
(define (create-directory&parents fname . rest)
|
||||
(let-optionals rest ((perms-fn default-perms-fn))
|
||||
(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)))))))
|
||||
|
||||
;; Return the length of the longest prefix common to lists L1 and L2,
|
||||
;; by comparing elements using PRED (defaults to EQUAL?).
|
||||
(define (common-prefix-length l1 l2 . rest)
|
||||
(let-optionals rest ((pred equal?))
|
||||
(if (or (null? l1) (null? l2) (not (pred (first l1) (first l2))))
|
||||
0
|
||||
(+ 1 (apply common-prefix-length (cdr l1) (cdr l2) rest)))))
|
||||
|
||||
;; Return the name of file NAME relative to DIR (defaults to current
|
||||
;; directory).
|
||||
(define (relative-file-name name . rest)
|
||||
(let-optionals rest ((dir (cwd)))
|
||||
(let* ((abs-pl (split-file-name (absolute-file-name name)))
|
||||
(dir-pl (split-file-name (directory-as-file-name dir)))
|
||||
(cp-len (common-prefix-length abs-pl dir-pl)))
|
||||
(path-list->file-name (append (make-list (- (length dir-pl) cp-len) "..")
|
||||
(drop abs-pl cp-len))))))
|
||||
|
||||
;; Return the name of FNAME, which must be absolute, with NEW-ROOT as
|
||||
;; root.
|
||||
(define (re-root-file-name fname new-root)
|
||||
(let ((fname-pl (split-file-name fname))
|
||||
(new-root-pl (split-file-name new-root)))
|
||||
(if (string=? (first fname-pl) "")
|
||||
(path-list->file-name (append new-root-pl (cdr fname-pl)))
|
||||
(error "no root to replace in relative file name" fname))))
|
||||
|
||||
;; Copy file/symlink SOURCE to TARGET. TARGET must be the name of a
|
||||
;; non-existing file (i.e. it cannot be the name of a directory).
|
||||
(define (copy-file source target)
|
||||
(if (file-exists? target)
|
||||
(error "copy-file: target file exists" target))
|
||||
(if (file-symlink? source)
|
||||
(create-symlink (read-symlink source) target)
|
||||
(begin
|
||||
(run (cp ,source ,target))
|
||||
(set-file-mode target (file-mode source)))))
|
||||
|
||||
;; Like "load" but without printing anything.
|
||||
(define load-quietly
|
||||
(let ((eval (lambda (expr t) (eval expr (interaction-environment)))))
|
||||
(lambda (file-name)
|
||||
(call-with-input-file file-name
|
||||
(lambda (port) (port-fold port read eval #f))))))
|
||||
|
||||
(define (permissions->string perms)
|
||||
(let ((decode (lambda (mask str)
|
||||
(if (zero? (bitwise-and perms mask)) "-" str))))
|
||||
(string-append (decode #o400 "r") (decode #o200 "w") (decode #o100 "x")
|
||||
(decode #o040 "r") (decode #o020 "w") (decode #o010 "x")
|
||||
(decode #o004 "r") (decode #o002 "w") (decode #o001 "x"))))
|
||||
|
||||
;; Replace all bindings of KEY in ALIST with one binding KEY to DATUM.
|
||||
(define (alist-replace key datum alist)
|
||||
(alist-cons key datum (alist-delete key alist)))
|
||||
|
||||
;; Return the value associated with KEY in ALIST. If none exists,
|
||||
;; return DEFAULT, or signal an error if no DEFAULT was given.
|
||||
(define (alist-get key alist . rest)
|
||||
(cond ((assoc key alist) => cdr)
|
||||
((not (null? rest)) (first rest))
|
||||
(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.
|
||||
(define (spaces m n) (make-string (max m n) #\space))
|
||||
|
||||
;;
|
||||
;; Support for dry runs / verbose operation.
|
||||
;;
|
||||
|
||||
(define (wrap real-fn info-fn)
|
||||
(lambda args
|
||||
(if (or (get-option-value 'verbose) (get-option-value 'dry-run))
|
||||
(begin (display (apply info-fn args)) (newline)))
|
||||
(if (not (get-option-value 'dry-run))
|
||||
(apply real-fn args))))
|
||||
|
||||
(define -create-directory
|
||||
(wrap create-directory
|
||||
(lambda (fname . rest)
|
||||
(let-optionals rest ((perms #o777))
|
||||
(as-string "creating directory " fname
|
||||
" (perms: " (permissions->string perms) ")")))))
|
||||
|
||||
(define -create-symlink
|
||||
(wrap create-symlink
|
||||
(lambda (old-name new-name)
|
||||
(as-string "creating symbolic link " new-name
|
||||
" pointing to " old-name))))
|
||||
|
||||
(define -copy-file
|
||||
(wrap copy-file
|
||||
(lambda (source target)
|
||||
(as-string "copying file " source " to " target))))
|
||||
|
||||
(define -delete-file
|
||||
(wrap delete-file
|
||||
(lambda (fname) (as-string "deleting file " fname))))
|
||||
|
||||
;;
|
||||
;; Versions
|
||||
;;
|
||||
;; Versions are represented as lists of integers, the most significant
|
||||
;; being at the head.
|
||||
|
||||
;; Return the printed representation of VERSION.
|
||||
(define (version->string version)
|
||||
(string-join (map number->string version) "."))
|
||||
|
||||
;; Convert the printed representation of a version found in
|
||||
;; VERSION-STRING to the version it represents.
|
||||
(define string->version
|
||||
(let ((split-version (infix-splitter ".")))
|
||||
(lambda (version-string)
|
||||
(map string->number (split-version version-string)))))
|
||||
|
||||
;; Compare two versions lexicographically and return the symbol
|
||||
;; 'smaller if the first is strictly smaller than the second, 'equal
|
||||
;; if both are equal, and 'greater otherwise.
|
||||
(define (version-compare v1 v2)
|
||||
(cond ((and (null? v1) (null? v2)) 'equal)
|
||||
((null? v1) 'smaller)
|
||||
((null? v2) 'greater)
|
||||
(else (let ((v1h (car v1)) (v2h (car v2)))
|
||||
(cond ((< v1h v2h) 'smaller)
|
||||
((> v1h v2h) 'greater)
|
||||
(else (version-compare (cdr v1) (cdr v2))))))))
|
||||
|
||||
(define (version<? v1 v2) (eq? (version-compare v1 v2) 'smaller))
|
||||
(define (version>? v1 v2) (eq? (version-compare v1 v2) 'greater))
|
||||
(define (version=? v1 v2) (eq? (version-compare v1 v2) 'equal))
|
||||
|
||||
;;
|
||||
;; Layouts
|
||||
;;
|
||||
|
||||
;; Names of all shared locations (i.e. the ones which do not depend on
|
||||
;; the platform).
|
||||
(define shared-locations
|
||||
'(active base misc-shared scheme doc))
|
||||
|
||||
;; Names of all non-shared (i.e. platform-dependent) locations.
|
||||
(define non-shared-locations
|
||||
'(lib))
|
||||
|
||||
;; All locations defined for a layout.
|
||||
(define all-locations (append shared-locations non-shared-locations))
|
||||
|
||||
;; Return true iff the given location is "active", that is if files
|
||||
;; should be installed in it.
|
||||
(define (active-location? location)
|
||||
(member location (if (get-option-value 'non-shared-only)
|
||||
non-shared-locations
|
||||
all-locations)))
|
||||
|
||||
;; Parse a layout given as a string of comma-separated bindings. A
|
||||
;; binding consists of the name of a location, followed by an equal
|
||||
;; sign and the name of the directory to associate to the location.
|
||||
(define parse-layout
|
||||
(let ((split-defs (infix-splitter ","))
|
||||
(split-sides (infix-splitter "=")))
|
||||
(lambda (str)
|
||||
(map (lambda (name&value)
|
||||
(let ((name/value (split-sides name&value)))
|
||||
(cons (string->symbol (first name/value)) (second name/value))))
|
||||
(split-defs str)))))
|
||||
|
||||
;; Combine layouts L1 and L2 by adding to L1 all the additional
|
||||
;; mappings found in L2.
|
||||
(define (combine-layouts l1 l2)
|
||||
(fold (lambda (key/value layout)
|
||||
(if (assoc (car key/value) layout) layout (cons key/value layout)))
|
||||
l1
|
||||
l2))
|
||||
|
||||
;; Return an absolute version of LAYOUT by prepending PREFIX to all
|
||||
;; its components (which must be relative).
|
||||
(define (absolute-layout layout prefix)
|
||||
(map (lambda (key/value)
|
||||
(cons (car key/value) (absolute-file-name (cdr key/value) prefix)))
|
||||
layout))
|
||||
|
||||
;; Return the directory associated with the LOCATION in LAYOUT.
|
||||
(define (layout-dir layout location)
|
||||
(alist-get location layout #f))
|
||||
|
||||
;; Predefined layouts
|
||||
|
||||
(define (scsh-layout platform base)
|
||||
`((base . ,base)
|
||||
(misc-shared . ,base)
|
||||
(scheme . ,(absolute-file-name "scheme" base))
|
||||
(lib . ,(absolute-file-name "lib" base))
|
||||
(doc . ,(absolute-file-name "doc" base))))
|
||||
|
||||
(define (scsh-layout-1 platform pkg)
|
||||
(combine-layouts '((active . "."))
|
||||
(scsh-layout platform (package-full-name pkg))))
|
||||
|
||||
(define (scsh-layout-2 platform pkg)
|
||||
(combine-layouts
|
||||
'((active . "active"))
|
||||
(scsh-layout platform
|
||||
(path-list->file-name
|
||||
(list "installed"
|
||||
(package-name pkg)
|
||||
(version->string (package-version pkg)))))))
|
||||
|
||||
(define (fhs-layout platform pkg)
|
||||
(let ((base (absolute-file-name (package-full-name pkg)
|
||||
"share/scsh/modules")))
|
||||
`((base . ,base)
|
||||
(misc-shared . ,base)
|
||||
(scheme . ,(absolute-file-name "scheme" base))
|
||||
(lib . ,(absolute-file-name (package-full-name pkg)
|
||||
"lib/scsh/modules"))
|
||||
(doc . ,(absolute-file-name (package-full-name pkg) "share/doc"))
|
||||
(active . "share/scsh/modules"))))
|
||||
|
||||
(define predefined-layouts
|
||||
`(("scsh" . ,scsh-layout-1)
|
||||
("scsh-alt" . ,scsh-layout-2)
|
||||
("fhs" . ,fhs-layout)))
|
||||
|
||||
;;
|
||||
;; Packages
|
||||
;;
|
||||
|
||||
(define-record-type package
|
||||
(make-package name version extensions install-thunk)
|
||||
package?
|
||||
(name package-name)
|
||||
(version package-version)
|
||||
(extensions package-extensions)
|
||||
(install-thunk package-install-thunk))
|
||||
|
||||
;; Return the full name of PKG.
|
||||
(define (package-full-name pkg)
|
||||
(string-append
|
||||
(package-name pkg) "-" (version->string (package-version pkg))))
|
||||
|
||||
;; Return the value of extension called EXT for PKG. If such an
|
||||
;; extension doesn't exist, return #f.
|
||||
(define (package-extension pkg ext)
|
||||
(alist-get ext (package-extensions pkg) #f))
|
||||
|
||||
;; List of all defined packages
|
||||
(define packages '())
|
||||
|
||||
;; Add PKG to the above list of all defined packages.
|
||||
(define (add-package pkg)
|
||||
(set! packages (cons pkg packages)))
|
||||
|
||||
(define-syntax define-package
|
||||
(syntax-rules ()
|
||||
((define-package name version extensions body ...)
|
||||
(add-package (make-package name
|
||||
(quote version)
|
||||
(quasiquote extensions)
|
||||
(lambda () body ...))))))
|
||||
|
||||
;;
|
||||
;; Package options
|
||||
;;
|
||||
|
||||
(define-record-type pkg-opt
|
||||
(really-make-pkg-opt key
|
||||
help
|
||||
arg-help
|
||||
required-arg?
|
||||
optional-arg?
|
||||
default
|
||||
parse
|
||||
show
|
||||
transform)
|
||||
pkg-opt?
|
||||
(key pkg-opt-key)
|
||||
(help pkg-opt-help)
|
||||
(arg-help pkg-opt-arg-help)
|
||||
(required-arg? pkg-opt-required-arg?)
|
||||
(optional-arg? pkg-opt-optional-arg?)
|
||||
(default pkg-opt-default)
|
||||
(parse pkg-opt-parse)
|
||||
(show pkg-opt-show)
|
||||
(transform pkg-opt-transform))
|
||||
|
||||
(define (make-pkg-opt key help arg-help req-arg? opt-arg? default . rest)
|
||||
(let-optionals rest ((parse identity)
|
||||
(show identity)
|
||||
(transform (lambda (old new) new)))
|
||||
(really-make-pkg-opt key
|
||||
help
|
||||
arg-help
|
||||
req-arg?
|
||||
opt-arg?
|
||||
default
|
||||
parse
|
||||
show
|
||||
transform)))
|
||||
|
||||
;; Return the name of PKG-OPT
|
||||
(define (pkg-opt-name pkg-opt)
|
||||
(symbol->string (pkg-opt-key pkg-opt)))
|
||||
|
||||
;; Convert PKG-OPT into an SRFI-37 option.
|
||||
(define (pkg-opt->option pkg-opt)
|
||||
(let ((key (pkg-opt-key pkg-opt))
|
||||
(transform (pkg-opt-transform pkg-opt))
|
||||
(parse (pkg-opt-parse pkg-opt)))
|
||||
(option (list (pkg-opt-name pkg-opt))
|
||||
(pkg-opt-required-arg? pkg-opt)
|
||||
(pkg-opt-optional-arg? pkg-opt)
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace key
|
||||
(transform (alist-get key alist) (parse arg))
|
||||
alist)))))
|
||||
|
||||
;; Return a pair (key, default) which associates the default value of
|
||||
;; PKG-OPT to its key.
|
||||
(define (pkg-opt-key&default pkg-opt)
|
||||
(cons (pkg-opt-key pkg-opt) (pkg-opt-default pkg-opt)))
|
||||
|
||||
;; Return the list of all package options of the PACKAGES.
|
||||
(define (all-package-options packages)
|
||||
(append-map
|
||||
(lambda (pkg)
|
||||
(cond ((package-extension pkg 'options)
|
||||
=> (lambda (opts)
|
||||
(map (lambda (args) (apply make-pkg-opt args)) opts)))
|
||||
(else '())))
|
||||
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
|
||||
;;
|
||||
|
||||
;; Perform all actions required to make the given version of the
|
||||
;; package active (i.e. the default version for that package).
|
||||
(define (activate-package layout pkg)
|
||||
(let ((lnk-name (absolute-file-name (package-name pkg)
|
||||
(layout-dir layout 'active))))
|
||||
(if (and (file-exists? lnk-name) (file-symlink? lnk-name))
|
||||
(-delete-file lnk-name))
|
||||
(-create-symlink (relative-file-name (layout-dir layout 'base)
|
||||
(file-name-directory lnk-name))
|
||||
lnk-name)))
|
||||
|
||||
(define (install-thing% layout name-or-pair location target-rel-dir perms-fn)
|
||||
(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))
|
||||
(target-name (file-name-nondirectory (if (pair? name-or-pair)
|
||||
(cdr name-or-pair)
|
||||
name-or-pair)))
|
||||
(target (absolute-file-name target-name target-dir)))
|
||||
(create-directory&parents target-dir perms-fn)
|
||||
(cond ((or (file-regular? source) (file-symlink? source))
|
||||
(-copy-file source target))
|
||||
((file-directory? source)
|
||||
(-create-directory target (file-mode source))
|
||||
(install-directory-contents% layout
|
||||
source
|
||||
location
|
||||
(absolute-file-name target-name
|
||||
target-rel-dir)
|
||||
perms-fn))
|
||||
(else (error "cannot install file-system object" source)))))
|
||||
|
||||
(define (install-directory-contents% layout
|
||||
name
|
||||
location
|
||||
target-rel-dir
|
||||
perms-fn)
|
||||
(for-each (lambda (thing)
|
||||
(install-thing% layout thing location target-rel-dir perms-fn))
|
||||
(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))
|
||||
(install-thing% (fluid *install-layout*)
|
||||
name-or-pair
|
||||
location
|
||||
target-rel-dir
|
||||
perms-fn))))
|
||||
|
||||
(define (install-things names-or-pairs . rest)
|
||||
(for-each (lambda (name-or-pair)
|
||||
(apply install-thing name-or-pair rest))
|
||||
names-or-pairs))
|
||||
|
||||
(define install-file install-thing)
|
||||
(define install-files install-things)
|
||||
(define install-directory install-thing)
|
||||
(define install-directories install-things)
|
||||
|
||||
(define (install-directory-contents name location . rest)
|
||||
(if (active-location? location)
|
||||
(let-optionals rest ((target-rel-dir ".") (perms-fn default-perms-fn))
|
||||
(install-directory-contents% (fluid *install-layout*)
|
||||
name
|
||||
location
|
||||
target-rel-dir
|
||||
perms-fn))))
|
||||
|
||||
(define *layout* (make-fluid #f))
|
||||
(define *install-layout* (make-fluid #f))
|
||||
|
||||
;; Return the directory identified by LOCATION in the current layout.
|
||||
;; If INSTALL? is true, return the directory valid during the
|
||||
;; installation of the package, otherwise return the directory valid
|
||||
;; after installation (i.e. during package use).
|
||||
(define (get-directory location install?)
|
||||
(layout-dir (fluid (if install? *install-layout* *layout*)) location))
|
||||
|
||||
;; Perform all actions to install PKG in INSTALL-LAYOUT. If LAYOUT is
|
||||
;; not the same as INSTALL-LAYOUT, assume that some external tool will
|
||||
;; move the installed files so that they are laid out according to
|
||||
;; LAYOUT.
|
||||
(define (install-package layout install-layout pkg)
|
||||
(let-fluids *layout* layout
|
||||
*install-layout* install-layout
|
||||
(package-install-thunk pkg)))
|
||||
|
||||
;;
|
||||
;; Error handling
|
||||
;;
|
||||
|
||||
;; Display MSG (a format string with ARGS as arguments) on the error
|
||||
;; port, then exit with an error code of 1.
|
||||
(define (display-error-and-exit msg . args)
|
||||
(apply format (current-error-port) (string-append "Error: " msg) args)
|
||||
(newline)
|
||||
(exit 1))
|
||||
|
||||
(define usage #<<END
|
||||
Usage: ~a [options]
|
||||
|
||||
options:
|
||||
-h, --help display this help message, then exit
|
||||
--prefix <dir> specify directory where files are installed
|
||||
--layout <layout> specify layout of installation directory
|
||||
(predefined: ~a)
|
||||
--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
|
||||
--non-shared-only only install platform-dependent files, if any
|
||||
|
||||
advanced options:
|
||||
--build <name> name of platform for which to build
|
||||
--layout-from <file> load layout of installation directory from file
|
||||
--layout-to <file> output layout to given file
|
||||
--install-prefix <dir> specify prefix to used during installation
|
||||
(to be used only during staged installations)
|
||||
|
||||
END
|
||||
)
|
||||
|
||||
(define usage-descr-col 26)
|
||||
|
||||
;; Complete the above USAGE string to include information about the
|
||||
;; package options PKG-OPTS.
|
||||
(define (complete-usage! pkg-opts)
|
||||
(let ((usage-port (make-string-output-port)))
|
||||
(write-string usage usage-port)
|
||||
(write-string "\npackage-specific options:\n" usage-port)
|
||||
(for-each
|
||||
(lambda (pkg-opt)
|
||||
(let ((option/arg (format #f "--~a ~a"
|
||||
(pkg-opt-name pkg-opt)
|
||||
(pkg-opt-arg-help pkg-opt))))
|
||||
(format usage-port
|
||||
" ~a~a~a [~a]\n"
|
||||
option/arg
|
||||
(spaces 2 (- usage-descr-col (string-length option/arg)))
|
||||
(pkg-opt-help pkg-opt)
|
||||
((pkg-opt-show pkg-opt) (pkg-opt-default pkg-opt)))))
|
||||
pkg-opts)
|
||||
(set! usage (string-output-port-output usage-port))))
|
||||
|
||||
;; Display the usage string, then MSG (a format string with ARGS as
|
||||
;; arguments) on the standard output port, then exit with an error
|
||||
;; code of 1.
|
||||
(define (display-usage-and-exit msg . args)
|
||||
(format #t
|
||||
usage
|
||||
(car (command-line))
|
||||
(string-join (map car predefined-layouts) ", "))
|
||||
(if msg (begin (apply format #t msg args) (newline)))
|
||||
(exit 1))
|
||||
|
||||
;;
|
||||
;; Command line parsing
|
||||
;;
|
||||
|
||||
;; Predefined parsers/unparsers
|
||||
(define (parse-boolean s)
|
||||
(cond ((string=? s "yes") #t)
|
||||
((string=? s "no") #f)
|
||||
(else (display-error-and-exit
|
||||
"unknown boolean value '~a'. Use 'yes' or 'no'." s))))
|
||||
|
||||
(define (show-boolean b)
|
||||
(if b "yes" "no"))
|
||||
|
||||
;; The identity function, sometimes useful for parsers/unparsers.
|
||||
(define (identity x) x)
|
||||
|
||||
;; Fluid containing the value of all options.
|
||||
(define *options-values* (make-fluid #f))
|
||||
|
||||
(define package-definition-file "pkg-def.scm")
|
||||
|
||||
(define (get-option-value key)
|
||||
(alist-get key (fluid *options-values*)))
|
||||
|
||||
(define options
|
||||
(let ((alist-arg-updater (lambda (key)
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace key arg alist))))
|
||||
(alist-boolean-updater (lambda (key)
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace key #t alist)))))
|
||||
(list
|
||||
(option '(#\h "help") #f #f
|
||||
(lambda args (display-usage-and-exit #f)))
|
||||
(option '("prefix") #t #f (alist-arg-updater 'prefix))
|
||||
(option '("dest-dir") #t #f (alist-arg-updater 'dest-dir))
|
||||
(option '("layout") #t #f
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace 'layout
|
||||
(cond ((assoc arg predefined-layouts) => cdr)
|
||||
(else (parse-layout arg)))
|
||||
alist)))
|
||||
(option '("layout-from") #t #f
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace 'layout
|
||||
(let ((layout (call-with-input-file arg read)))
|
||||
(lambda args layout))
|
||||
alist)))
|
||||
(option '("layout-to") #t #f (alist-arg-updater 'layout-to))
|
||||
(option '("build") #t #f (alist-arg-updater 'build))
|
||||
(option '("non-shared-only") #f #f
|
||||
(alist-boolean-updater 'non-shared-only))
|
||||
(option '("inactive") #f #f (alist-boolean-updater 'inactive))
|
||||
(option '("dry-run") #f #f (alist-boolean-updater 'dry-run))
|
||||
(option '("verbose") #f #f (alist-boolean-updater 'verbose)))))
|
||||
|
||||
(define options-defaults
|
||||
`((prefix . #f)
|
||||
(dest-dir . "/")
|
||||
(layout . ,scsh-layout-1)
|
||||
(layout-to . #f)
|
||||
(build . ,(host))
|
||||
(non-shared-only . #f)
|
||||
(inactive . #f)
|
||||
(dry-run . #f)
|
||||
(verbose . #f)))
|
||||
|
||||
(define (parse-options args options defaults)
|
||||
(args-fold args
|
||||
options
|
||||
(lambda (option name . rest)
|
||||
(display-usage-and-exit "Unknown option ~a" name))
|
||||
(lambda (operand . rest)
|
||||
(display-usage-and-exit "Don't know what to do with ~a"
|
||||
operand))
|
||||
defaults))
|
||||
|
||||
(define (install-main cmd-line)
|
||||
(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)))
|
||||
(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))))
|
||||
(if (not prefix)
|
||||
(display-error-and-exit "no prefix specified (use --prefix option)"))
|
||||
(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))))))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#!/bin/sh
|
||||
exec scsh -lm install-lib-module.scm -o pp -o configure -o install -e install-main -s "$0" "$@"
|
||||
!#
|
||||
Loading…
Reference in New Issue