first commit
This commit is contained in:
frese
parent
8c463b59fd
commit
4aabba91ef
|
|
@ -0,0 +1,41 @@
|
|||
;;; Interfaces
|
||||
|
||||
(define-interface install-interface
|
||||
(export version->string
|
||||
string->version
|
||||
version-compare
|
||||
version<?
|
||||
version>?
|
||||
version=?
|
||||
|
||||
installed-packages
|
||||
active-packages
|
||||
installed-packages&versions
|
||||
active-packages&versions
|
||||
active-version
|
||||
|
||||
(define-package :syntax)
|
||||
|
||||
install-file
|
||||
install-files
|
||||
install-directory
|
||||
install-directories
|
||||
|
||||
package-installation-dir
|
||||
package-installation-staging-dir
|
||||
with-optional-part?
|
||||
is-running-dry?
|
||||
|
||||
install-main))
|
||||
|
||||
;;; Structures
|
||||
|
||||
(define-structure install install-interface
|
||||
(open scheme-with-scsh
|
||||
fluids
|
||||
let-opt
|
||||
srfi-1
|
||||
srfi-9
|
||||
srfi-13
|
||||
srfi-37)
|
||||
(files install-lib))
|
||||
|
|
@ -0,0 +1,508 @@
|
|||
;; Time-stamp: <2003-11-27 11:06:57 schinz>
|
||||
|
||||
;; TODO
|
||||
;; - copy symbolic links as such, do not duplicate contents,
|
||||
;; - add function to copy a directory contents,
|
||||
;; - add support for image creation,
|
||||
;; - add support to maintain a documentation index,
|
||||
;; - add "--mode" option to specify permissions for files/directories.
|
||||
;; - add "--verbose" to show whats being done.
|
||||
;; - add "--log" option to specify a log file.
|
||||
;; - decide what to do when target files already exist
|
||||
;; - find out how to perform installation for several architectures
|
||||
|
||||
;;
|
||||
;; Utilities
|
||||
;;
|
||||
|
||||
(define default-perms #o755)
|
||||
|
||||
(define (parent-directory fname)
|
||||
(file-name-directory (directory-as-file-name fname)))
|
||||
|
||||
(define (create-directory&parents fname . rest)
|
||||
(let-optionals rest ((perms default-perms))
|
||||
(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)))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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))))))
|
||||
|
||||
(define (copy-file src target perms)
|
||||
(run (cp ,src ,target))
|
||||
(set-file-mode target perms))
|
||||
|
||||
(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"))))
|
||||
|
||||
;; 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))))))
|
||||
|
||||
;;
|
||||
;; Support for dry runs.
|
||||
;;
|
||||
|
||||
(define *dry-run* (make-fluid #f))
|
||||
|
||||
(define (wrap-for-dry-run real-fn dry-fn)
|
||||
(lambda args
|
||||
(apply (if (fluid *dry-run*) dry-fn real-fn) args)))
|
||||
|
||||
(define (dry-run-print msg . args)
|
||||
(apply format #t msg args) (newline))
|
||||
|
||||
(define -create-directory
|
||||
(wrap-for-dry-run
|
||||
create-directory
|
||||
(lambda (fname . rest)
|
||||
(let-optionals rest ((perms default-perms))
|
||||
(dry-run-print "creating directory ~a with permissions ~a"
|
||||
fname
|
||||
(permissions->string perms))))))
|
||||
|
||||
(define -create-symlink
|
||||
(wrap-for-dry-run
|
||||
create-symlink
|
||||
(lambda (old-name new-name)
|
||||
(dry-run-print "creating symbolic link ~a pointing to ~a"
|
||||
new-name
|
||||
old-name))))
|
||||
|
||||
(define -copy-file
|
||||
(wrap-for-dry-run
|
||||
copy-file
|
||||
(lambda (source target perms)
|
||||
(dry-run-print "copying file ~a to ~a with permissions ~a"
|
||||
source
|
||||
target
|
||||
(permissions->string perms)))))
|
||||
|
||||
(define -delete-file
|
||||
(wrap-for-dry-run delete-file
|
||||
(lambda (fname) (dry-run-print "deleting file ~a" fname))))
|
||||
|
||||
;;
|
||||
;; Regular expressions to match package names
|
||||
;;
|
||||
|
||||
(define number-rx (rx (+ digit)))
|
||||
(define version-rx (rx ,number-rx (* "." ,number-rx)))
|
||||
(define package-name-rx (rx (+ (| alphanum ("_")))))
|
||||
(define package-full-name-rx (rx (submatch ,package-name-rx)
|
||||
"-"
|
||||
(submatch ,version-rx)))
|
||||
|
||||
;;
|
||||
;; Versions
|
||||
;;
|
||||
;; Versions are represented as lists of integers, the most significant
|
||||
;; being at the head.
|
||||
|
||||
(define (version->string version)
|
||||
(string-join (map number->string version) "."))
|
||||
|
||||
(define string->version
|
||||
(let ((split-version (infix-splitter ".")))
|
||||
(lambda (version-string)
|
||||
(map string->number (split-version version-string)))))
|
||||
|
||||
(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))
|
||||
|
||||
;;
|
||||
;; 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))
|
||||
|
||||
;; List of all defined packages
|
||||
(define packages '())
|
||||
|
||||
;; Add a package to the above list
|
||||
(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)
|
||||
(quote extensions)
|
||||
(lambda () body ...))))))
|
||||
|
||||
;;
|
||||
;; Names of various directories/links
|
||||
;;
|
||||
|
||||
;; Directory in which active versions of packages are "remembered".
|
||||
(define (active-directory root)
|
||||
(absolute-file-name "active" root))
|
||||
|
||||
;; Directory in which packages are installed.
|
||||
(define (installed-directory root)
|
||||
(absolute-file-name "installed" root))
|
||||
|
||||
(define (package-dir-name root pkg)
|
||||
(absolute-file-name (package:name pkg) (installed-directory root)))
|
||||
|
||||
(define (package-version-dir-name root pkg)
|
||||
(absolute-file-name (version->string (package:version pkg))
|
||||
(package-dir-name root pkg)))
|
||||
|
||||
(define (active-link-name root pkg)
|
||||
(absolute-file-name (package:name pkg) (active-directory root)))
|
||||
|
||||
;;
|
||||
;; Queries
|
||||
;;
|
||||
|
||||
(define (packages-of dir)
|
||||
(with-cwd dir (filter file-directory? (directory-files))))
|
||||
|
||||
;; Get the name of all installed packages (without versions) as a list
|
||||
;; of strings.
|
||||
(define (installed-packages root)
|
||||
(packages-of (installed-directory root)))
|
||||
|
||||
;; Get the name of all active packages (without versions) as a list of
|
||||
;; strings.
|
||||
(define (active-packages root)
|
||||
(packages-of (active-directory root)))
|
||||
|
||||
;; Return the list of all installed packages and their version(s), as
|
||||
;; a list of pairs. The CAR of each pair contains the name of the
|
||||
;; package, the CDR contains the list of all available versions.
|
||||
(define (installed-packages&versions root)
|
||||
(with-cwd (installed-directory root)
|
||||
(map (lambda (pkg-dir)
|
||||
(cons pkg-dir
|
||||
(map string->version (directory-files pkg-dir))))
|
||||
(directory-files))))
|
||||
|
||||
(define (read-version pkg-link)
|
||||
(string->version (file-name-nondirectory (read-symlink pkg-link))))
|
||||
|
||||
;; Return the list of all active packages and their version, as a list
|
||||
;; of pairs. The CAR of each pair contains the name of the package,
|
||||
;; and the CDR contains the active version.
|
||||
(define (active-packages&versions root)
|
||||
(with-cwd (active-directory root)
|
||||
(map (lambda (pkg-dir)
|
||||
(cons pkg-dir (read-version pkg-dir)))
|
||||
(directory-files))))
|
||||
|
||||
;; Return the active version of package NAME.
|
||||
(define (active-version root name)
|
||||
(read-version (absolute-file-name name (active-directory root))))
|
||||
|
||||
;;
|
||||
;; 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 root pkg)
|
||||
(let ((lnk-name (active-link-name root pkg)))
|
||||
(if (and (file-exists? lnk-name) (file-symlink? lnk-name))
|
||||
(-delete-file lnk-name))
|
||||
(-create-symlink (relative-file-name (package-version-dir-name root pkg)
|
||||
(file-name-directory lnk-name))
|
||||
lnk-name)))
|
||||
|
||||
(define (target-absolute-dir root pkg dir)
|
||||
(absolute-file-name (directory-as-file-name dir)
|
||||
(package-version-dir-name root pkg)))
|
||||
|
||||
(define (re-root-file file dir)
|
||||
(absolute-file-name (file-name-nondirectory (directory-as-file-name file))
|
||||
dir))
|
||||
|
||||
;; Copy the list of FILES to the TARGET-DIR and set their permission
|
||||
;; to PERMS. The TARGET-DIR (default ".") is relative to the package
|
||||
;; directory given by ROOT, NAME and VERSION.
|
||||
(define (install-files% root pkg files . rest)
|
||||
(let-optionals rest ((target-dir ".") (perms default-perms))
|
||||
(let* ((target-abs-dir (target-absolute-dir root pkg target-dir)))
|
||||
(create-directory&parents target-abs-dir perms)
|
||||
(for-each (lambda (file)
|
||||
(-copy-file file (re-root-file file target-abs-dir) perms))
|
||||
files))))
|
||||
|
||||
;; Copy SRC-DIR and all its contents in TARGET-DIR, and set the
|
||||
;; permission for everything to PERMS. The TARGET-DIR (default ".") is
|
||||
;; relative to the package directory given by ROOT, NAME and VERSION.
|
||||
(define (install-directory% root pkg src-dir . rest)
|
||||
(let-optionals rest ((target-dir ".") (perms default-perms))
|
||||
(let* ((src-dir-name (file-name-nondirectory
|
||||
(directory-as-file-name src-dir)))
|
||||
(full-target-dir (absolute-file-name src-dir-name target-dir))
|
||||
(target-abs-dir (target-absolute-dir root pkg full-target-dir)))
|
||||
(create-directory&parents target-abs-dir perms)
|
||||
(for-each
|
||||
(lambda (file)
|
||||
(let ((abs-file (absolute-file-name file src-dir)))
|
||||
(cond ((file-regular? abs-file)
|
||||
(-copy-file abs-file
|
||||
(absolute-file-name file target-abs-dir)
|
||||
perms))
|
||||
((file-directory? abs-file)
|
||||
(install-directory% root pkg abs-file full-target-dir perms))
|
||||
(else
|
||||
(display-error-and-exit "don't know what to do with file ~a"
|
||||
abs-file)))))
|
||||
(directory-files src-dir #t)))))
|
||||
|
||||
(define (install-empty-directory% root pkg target-dir . rest)
|
||||
(let-optionals rest ((perms default-perms))
|
||||
(-create-directory (target-absolute-dir root pkg target-dir) perms)))
|
||||
|
||||
(define (install-empty-directory&parents% root pkg target-dir . rest)
|
||||
(let-optionals rest ((perms default-perms))
|
||||
(create-directory&parents (target-absolute-dir root pkg target-dir)
|
||||
perms)))
|
||||
|
||||
(define *root* (make-fluid #f))
|
||||
(define *dest-root* (make-fluid #f))
|
||||
(define *package* (make-fluid #f))
|
||||
|
||||
(define (package-installation-dir)
|
||||
(package-version-dir-name (fluid *root*) (fluid *package*)))
|
||||
(define (package-installation-staging-dir)
|
||||
(package-version-dir-name (fluid *dest-root*) (fluid *package*)))
|
||||
|
||||
(define (forward-args-prepend-fluids target-fn args)
|
||||
(apply target-fn (fluid *dest-root*) (fluid *package*) args))
|
||||
|
||||
(define (install-file file . rest)
|
||||
(apply install-files (list file) rest))
|
||||
|
||||
(define (install-files . args)
|
||||
(forward-args-prepend-fluids install-files% args))
|
||||
|
||||
(define (install-empty-directory . args)
|
||||
(forward-args-prepend-fluids install-empty-directory% args))
|
||||
|
||||
(define (install-empty-directory&parents . args)
|
||||
(forward-args-prepend-fluids install-empty-directory&parents% args))
|
||||
|
||||
(define (install-directory . args)
|
||||
(forward-args-prepend-fluids install-directory% args))
|
||||
|
||||
(define (install-directories src-dirs . rest)
|
||||
(for-each (lambda (src-dir)
|
||||
(apply install-directory src-dir rest))
|
||||
src-dirs))
|
||||
|
||||
(define (install-package root dest-root pkg)
|
||||
(let-fluids *root* root
|
||||
*dest-root* dest-root
|
||||
*package* pkg
|
||||
(package:install-thunk pkg)))
|
||||
|
||||
;;
|
||||
;; Error handling
|
||||
;;
|
||||
|
||||
(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]
|
||||
-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
|
||||
|
||||
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)
|
||||
(for-each (lambda (dir)
|
||||
(if (not (and (file-exists? dir) (file-directory? dir)))
|
||||
(display-error-and-exit
|
||||
(string-append
|
||||
"directory ~a does not exist or is not a directory.\n"
|
||||
"It should be created before installing packages.")
|
||||
dir)))
|
||||
(list root (active-directory root) (installed-directory root))))
|
||||
|
||||
;;
|
||||
;; Command line parsing
|
||||
;;
|
||||
|
||||
(define options
|
||||
(list (option '(#\h "help") #f #f
|
||||
(lambda args
|
||||
(display-usage-and-exit #f)))
|
||||
(option '(#\r "root") #t #f
|
||||
(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? 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? 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? 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)))
|
||||
(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
|
||||
(append options
|
||||
(optional-parts->options (fluid *all-optional-parts*)))
|
||||
(lambda (option name arg . seeds)
|
||||
(display-usage-and-exit "Unknown option ~a" name))
|
||||
(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
|
||||
(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)
|
||||
(install-package root dest-root pkg)
|
||||
(if activate?
|
||||
(activate-package dest-root pkg)))
|
||||
packages)))))))
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#!/bin/sh
|
||||
exec scsh -lm install-lib-module.scm -o install -e install-main -s "$0" "$@"
|
||||
!#
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
(define-package "scx" (0 2 1)
|
||||
((optional-parts (xft "Compile with Xft support" #f)))
|
||||
|
||||
(let* ((prefix (package-installation-staging-dir))
|
||||
(xft? (with-optional-part? 'xft))
|
||||
(configure (quasiquote ("./configure" ,(string-append "--prefix=" prefix)
|
||||
,(if xft? "--with-xft" "--without-xft"))))
|
||||
(make '(make all install)))
|
||||
(if (is-running-dry?)
|
||||
(begin
|
||||
(display configure) (newline)
|
||||
(display make) (newline))
|
||||
(and (zero? (run ,configure))
|
||||
(zero? (run ,make)))))
|
||||
(install-file "load.scm")
|
||||
(install-directory "scheme")
|
||||
)
|
||||
Loading…
Reference in New Issue