first commit

install-lib-module.scm

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

install-lib.scm

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

install-pkg

@@ -0,0 +1,3 @@
+#!/bin/sh
+exec scsh -lm install-lib-module.scm -o install -e install-main -s "$0" "$@"
+!#

pkg-def.scm

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