Incorporated changes by David Frese:
- added support for optional parts - added is-running-dry? function
This commit is contained in:
michel-schinz
parent
ca9d89951d
commit
0d791e3332
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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 #<<END
|
||||
Usage: ~a [options]
|
||||
-h, --help display this help message, then exit
|
||||
-r, --root <dir> 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 <dir> 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 <dir> 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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue