- initial version (no layouts, no support for optional parts)

scheme/install-lib/install-lib-module.scm

@@ -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))

scheme/install-lib/install-lib.scm

@@ -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)))))))