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

- added user-specific defaults (stored in file ~/.scsh-pkg-defaults), 

- added "exclude" option, to exclude some files,
- parse layouts *after* processing the options,
- changed "display-error-and-exit" to not use "format" anymore.
This commit is contained in:
michel-schinz 2004-02-23 20:11:40 +00:00
parent 47391a548d
commit 06427ff520
1 changed files with 91 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,5 +1,5 @@
;;; Installation library for scsh modules.
;;; $Id: install-lib.scm,v 1.11 2004/02/20 08:22:07 michel-schinz Exp $
;;; $Id: install-lib.scm,v 1.12 2004/02/23 20:11:40 michel-schinz Exp $
;; TODO
;; - add a "--debug" option
@ -128,6 +128,14 @@
(define (alist-replace key datum alist)
(alist-cons key datum (alist-delete key alist)))
;; Add all mappings from ALIST-2 to ALIST-1. If a key is mapped in
;; both lists, the mapping in the first list takes precedence.
(define (alist-combine alist-1 alist-2)
(fold (lambda (key/value result)
(if (assoc (car key/value) result) result (cons key/value result)))
alist-1
alist-2))
;; 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)
@ -251,14 +259,6 @@
(return #f))))
(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)
@ -280,11 +280,11 @@
(doc . ,(absolute-file-name "doc" base))))
(define (scsh-layout-1 platform pkg)
(combine-layouts '((active . "."))
(alist-combine '((active . "."))
(scsh-layout platform (package-full-name pkg))))
(define (scsh-layout-2 platform pkg)
(combine-layouts
(alist-combine
'((active . "active"))
(scsh-layout platform
(path-list->file-name
@ -308,6 +308,13 @@
("scsh-alt" . ,scsh-layout-2)
("fhs" . ,fhs-layout)))
;; If NAME-OR-LAYOUT refers to a predefined layout, return it.
;; Otherwise, if NAME-OR-LAYOUT is a valid layout definition, parse
;; and return it. Otherwise, return false.
(define (resolve-layout name-or-layout)
(or (alist-get name-or-layout predefined-layouts #f)
(parse-layout name-or-layout)))
;;
;; Packages
;;
@ -481,6 +488,8 @@
(cdr name-or-pair)
name-or-pair)))
(target (absolute-file-name target-name target-dir)))
(if (not ((get-option-value 'exclude) source))
(begin
(create-directory&parents target-dir perms-fn)
(cond ((or (file-regular? source) (file-symlink? source))
(-copy-file source target))
@ -489,10 +498,11 @@
(install-directory-contents% layout
source
location
(absolute-file-name target-name
(absolute-file-name
target-name
target-rel-dir)
perms-fn))
(else (error "cannot install file-system object" source)))))
(else (error "cannot install file-system object" source)))))))
(define (install-directory-contents% layout
name
@ -575,7 +585,7 @@
(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-fn (resolve-layout (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))
@ -616,10 +626,10 @@
;; 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)
;; Display all the MSGS on the error port, then exit with an error
;; code of 1.
(define (display-error-and-exit . msgs)
(for-each display (cons "Error: " msgs))
(newline)
(exit 1))
@ -669,15 +679,15 @@ END
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)
;; Display the usage string, then all MSGS on the standard output
;; port, then exit with an error code of 1.
(define (display-usage-and-exit . msgs)
(format #t
usage
(car (command-line))
(string-join (map car predefined-layouts) ", "))
(if msg (begin (apply format #t msg args) (newline)))
(for-each display msgs)
(newline)
(exit 1))
;;
@ -689,7 +699,7 @@ END
(cond ((string=? s "yes") #t)
((string=? s "no") #f)
(else (display-error-and-exit
"unknown boolean value '~a'. Use 'yes' or 'no'." s))))
"unknown boolean value '"s"'. Use 'yes' or 'no'."))))
(define (show-boolean b)
(if b "yes" "no"))
@ -714,17 +724,10 @@ END
(alist-replace key #t alist)))))
(list
(option '(#\h "help") #f #f
(lambda args (display-usage-and-exit #f)))
(lambda args (display-usage-and-exit)))
(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)
((parse-layout arg) => identity)
(else (display-error-and-exit
"invalid layout ~a" arg)))
alist)))
(option '("layout") #t #f (alist-arg-updater 'layout))
(option '("layout-from") #t #f
(lambda (opt name arg alist)
(alist-replace 'layout
@ -740,43 +743,70 @@ END
(option '("verbose") #f #f (alist-boolean-updater 'verbose))
(option '("force") #f #f (alist-boolean-updater 'force)))))
(define no-user-defaults-option "--no-user-defaults")
(define (parse-options args options defaults)
(args-fold args
options
(lambda (option name . rest)
(display-usage-and-exit "Unknown option "name))
(lambda (operand . rest)
(display-usage-and-exit "Don't know what to do with " operand))
defaults))
;; Return user-specific defaults.
(define (read-user-defaults)
(let ((file (expand-file-name "~/.scsh-pkg-defaults.scm")))
(if (file-exists? file)
(call-with-input-file file
(lambda (port)
(let ((defaults (read port)))
(if (or (eof-object? defaults))
(display-error-and-exit "no valid defaults found in "file))
(if (not (eof-object? (read port)))
(display-error-and-exit
"more than one expression found in "file))
(eval (list 'quasiquote defaults) (interaction-environment)))))
'())))
(define options-defaults
`((prefix . #f)
(dest-dir . "/")
(layout . ,scsh-layout-1)
(layout . "scsh")
(layout-to . #f)
(build . ,(host))
(non-shared-only . #f)
(inactive . #f)
(dry-run . #f)
(verbose . #f)
(force . #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))
(force . #f)
(exclude . ,(lambda args #f))))
(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))
(display-error-and-exit "cannot find package definition file"
"("package-definition-file")"))
(let* ((packages (load-packages))
(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
(all-dfts (append (alist-combine
(if (member no-user-defaults-option cmd-line)
'()
(read-user-defaults))
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)))
(options-values (parse-options (delete no-user-defaults-option
(cdr cmd-line))
all-opts
all-dfts))
(prefix (alist-get 'prefix options-values))
(layout (alist-get 'layout 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"))
(if (not (resolve-layout layout))
(display-error-and-exit "invalid layout "layout))
(install-packages packages options-values))))