- initial version (no layouts, no support for optional parts)
This commit is contained in:
michel-schinz
parent
383349a3fa
commit
c133705d62
|
|
@ -0,0 +1,42 @@
|
||||||
|
;;; Installation library for scsh modules.
|
||||||
|
;;; $Id: install-lib-module.scm,v 1.1 2003/12/14 12:23:36 michel-schinz Exp $
|
||||||
|
|
||||||
|
;;; 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
|
||||||
|
|
||||||
|
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,432 @@
|
||||||
|
;;; Installation library for scsh modules.
|
||||||
|
;;; $Id: install-lib.scm,v 1.1 2003/12/14 12:23:36 michel-schinz Exp $
|
||||||
|
|
||||||
|
;; 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 install-thunk)
|
||||||
|
package?
|
||||||
|
(name package:name)
|
||||||
|
(version package:version)
|
||||||
|
(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 body ...)
|
||||||
|
(add-package (make-package name
|
||||||
|
(quote version)
|
||||||
|
(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)))
|
||||||
|
(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?)
|
||||||
|
(values arg dest-root activate? dry-run?)))
|
||||||
|
(option '(#\d "dest-root") #t #f
|
||||||
|
(lambda (option name arg root dest-root activate? dry-run?)
|
||||||
|
(values root arg activate? dry-run?)))
|
||||||
|
(option '(#\n "dry-run") #f #f
|
||||||
|
(lambda (option name arg root dest-root activate? dry-run?)
|
||||||
|
(values root dest-root activate? #t)))
|
||||||
|
(option '(#\i "inactive") #f #f
|
||||||
|
(lambda (option name arg root dest-root activate? dry-run?)
|
||||||
|
(values root dest-root #f dry-run?)))))
|
||||||
|
|
||||||
|
(define package-definition-file "pkg-def.scm")
|
||||||
|
|
||||||
|
(define (install-main cmd-line)
|
||||||
|
(let ((prog (car cmd-line))
|
||||||
|
(args (cdr cmd-line)))
|
||||||
|
(receive (root maybe-dest-root activate? dry-run?)
|
||||||
|
(args-fold args
|
||||||
|
options
|
||||||
|
(lambda (option name arg . seeds)
|
||||||
|
(display-usage-and-exit "Unknown option ~a" name))
|
||||||
|
(lambda (operand root activate?) ; 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)
|
||||||
|
(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?
|
||||||
|
(lambda ()
|
||||||
|
(for-each
|
||||||
|
(lambda (pkg)
|
||||||
|
(install-package root dest-root pkg)
|
||||||
|
(if activate?
|
||||||
|
(activate-package dest-root pkg)))
|
||||||
|
packages)))))))
|
||||||
Loading…
Reference in New Issue