diff --git a/scheme/install-lib/install-lib-module.scm b/scheme/install-lib/install-lib-module.scm index bdb21b6..cbf79e7 100644 --- a/scheme/install-lib/install-lib-module.scm +++ b/scheme/install-lib/install-lib-module.scm @@ -1,5 +1,5 @@ ;;; Installation library for scsh modules. -;;; $Id: install-lib-module.scm,v 1.1 2003/12/14 12:23:36 michel-schinz Exp $ +;;; $Id: install-lib-module.scm,v 1.2 2003/12/14 12:33:59 michel-schinz Exp $ ;;; Interfaces @@ -26,6 +26,8 @@ package-installation-dir package-installation-staging-dir + with-optional-part? + is-running-dry? install-main)) diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index c33a2a0..f104361 100755 --- a/scheme/install-lib/install-lib.scm +++ b/scheme/install-lib/install-lib.scm @@ -1,5 +1,5 @@ ;;; Installation library for scsh modules. -;;; $Id: install-lib.scm,v 1.1 2003/12/14 12:23:36 michel-schinz Exp $ +;;; $Id: install-lib.scm,v 1.2 2003/12/14 12:33:59 michel-schinz Exp $ ;; TODO ;; - copy symbolic links as such, do not duplicate contents, @@ -147,10 +147,11 @@ ;; (define-record-type package - (make-package name version install-thunk) + (make-package name version extensions install-thunk) package? (name package:name) (version package:version) + (extensions package:extensions) (install-thunk package:install-thunk)) ;; List of all defined packages @@ -162,9 +163,10 @@ (define-syntax define-package (syntax-rules () - ((define-package name version body ...) + ((define-package name version extensions body ...) (add-package (make-package name (quote version) + (quote extensions) (lambda () body ...)))))) ;; @@ -347,10 +349,10 @@ (define usage #< specify root directory - -n, --dry-run don't do anything, print what would have been done - -i, --inactive don't activate package after installing it + -h, --help display this help message, then exit + -r, --root specify root directory + -n, --dry-run don't do anything, print what would have been done + -i, --inactive don't activate package after installing it advanced options: -d, --dest-root specify staging root directory @@ -361,6 +363,7 @@ END (define (display-usage-and-exit msg . args) (if msg (begin (apply format #t msg args) (newline))) (format #t usage (car (command-line))) + (display-optional-parts-usage) (exit 1)) (define (check-root-directory root) @@ -382,47 +385,121 @@ END (lambda args (display-usage-and-exit #f))) (option '(#\r "root") #t #f - (lambda (option name arg root dest-root activate? dry-run?) - (values arg dest-root activate? dry-run?))) + (lambda (option name arg root dest-root activate? dry-run? opt-parts) + (values arg dest-root activate? dry-run? opt-parts))) (option '(#\d "dest-root") #t #f - (lambda (option name arg root dest-root activate? dry-run?) - (values root arg activate? dry-run?))) + (lambda (option name arg root dest-root activate? dry-run? opt-parts) + (values root arg activate? dry-run? opt-parts))) (option '(#\n "dry-run") #f #f - (lambda (option name arg root dest-root activate? dry-run?) - (values root dest-root activate? #t))) + (lambda (option name arg root dest-root activate? dry-run? opt-parts) + (values root dest-root activate? #t opt-parts))) (option '(#\i "inactive") #f #f - (lambda (option name arg root dest-root activate? dry-run?) - (values root dest-root #f dry-run?))))) + (lambda (option name arg root dest-root activate? dry-run? opt-parts) + (values root dest-root #f dry-run? opt-parts))))) + +;; +;; optional parts stuff +;; + +(define (booleanize 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 (unbooleanize b) + (if b "yes" "no")) + +(define (spaces min n) + (make-string (if (< n min) min n) #\space)) + +(define (get-all-optional-parts packages) + (if (null? packages) + '() + (let* ((p (car packages)) + (ext (package:extensions p)) + (op (assq 'optional-parts ext))) + (append (if op (cdr op) '()) + (get-all-optional-parts (cdr packages)))))) + +(define optional-part:name car) +(define optional-part:description cadr) +(define (optional-part:default part) + (if (null? (cddr part)) #f (caddr part))) + +(define (optional-parts->options parts) + (map (lambda (part) + (let ((part-name (optional-part:name part))) + (option (list (string-append "with-" (symbol->string part-name))) #t #f + (lambda (option name arg root dest-root activate? dry-run? opt-parts) + (values root dest-root activate? dry-run? + (cons (cons part-name (booleanize arg)) + opt-parts)))))) + parts)) + +(define (optional-parts-defaults parts) + (map (lambda (part) + (cons (optional-part:name part) (optional-part:default part))) + parts)) + +(define *all-optional-parts* (make-fluid '())) +(define *optional-parts-alist* (make-fluid '())) + +(define *usage-description-column* 25) + +(define (display-optional-parts-usage) + (display "\noptionals parts:\n") + (map (lambda (part) + (let* ((sname (symbol->string (optional-part:name part))) + (pf (string-append " --with-" sname"=[yes|no]"))) + (display pf) + (display (spaces 2 (- *usage-description-column* (string-length pf)))) + (display (optional-part:description part)) + (display (string-append " [" (unbooleanize (optional-part:default part)) "]")) + (newline))) + (fluid *all-optional-parts*))) + +(define (with-optional-part? name) + (cdr (assq name (fluid *optional-parts-alist*)))) + +;; main (define package-definition-file "pkg-def.scm") +(define (is-running-dry?) + (fluid *dry-run*)) + (define (install-main cmd-line) (let ((prog (car cmd-line)) (args (cdr cmd-line))) - (receive (root maybe-dest-root activate? dry-run?) + (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) + (set-fluid! *all-optional-parts* (get-all-optional-parts packages)) + (receive (root maybe-dest-root activate? dry-run? opt-parts) (args-fold args - options + (append options + (optional-parts->options (fluid *all-optional-parts*))) (lambda (option name arg . seeds) (display-usage-and-exit "Unknown option ~a" name)) - (lambda (operand root activate?) ; operand + (lambda (operand . seeds) ; operand (display-usage-and-exit "Don't know what to do with ~a" operand)) #f ; default root #f ; default dest-root #t ; default activation - #f) ; default dry run - (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) + #f ; default dry run + (optional-parts-defaults (fluid *all-optional-parts*))) (if (not root) (display-error-and-exit "No package root specified (use --root option)")) (let ((dest-root (or maybe-dest-root root))) (check-root-directory dest-root) (let-fluids *dry-run* dry-run? + *optional-parts-alist* opt-parts (lambda () (for-each (lambda (pkg)