diff --git a/install-lib-module.scm b/install-lib-module.scm index 6b8ae62..41a2686 100644 --- a/install-lib-module.scm +++ b/install-lib-module.scm @@ -1,5 +1,5 @@ ;;; Installation library for scsh modules. -;;; $Id: install-lib-module.scm,v 1.2 2003/12/16 16:44:40 frese Exp $ +;;; $Id: install-lib-module.scm,v 1.3 2004/01/04 14:34:32 frese Exp $ ;;; Interfaces @@ -19,10 +19,12 @@ install-directories install-directory-contents - get-directory + identity + parse-boolean + show-boolean - with-optional-part? - is-running-dry? + get-directory + get-option-value install-main)) diff --git a/install-lib.scm b/install-lib.scm index 60d2f12..9387b8f 100644 --- a/install-lib.scm +++ b/install-lib.scm @@ -1,14 +1,12 @@ ;;; Installation library for scsh modules. -;;; $Id: install-lib.scm,v 1.2 2003/12/16 16:44:40 frese Exp $ +;;; $Id: install-lib.scm,v 1.3 2004/01/04 14:34:32 frese Exp $ ;; TODO ;; - 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 -;; - allow installation of platform-specific files only ;; ;; Utilities @@ -16,9 +14,11 @@ (define default-perms #o755) +;; Return the name of the parent directory of FNAME. (define (parent-directory fname) (file-name-directory (directory-as-file-name fname))) +;; Create directory FNAME and all its parents, as needed. (define (create-directory&parents fname . rest) (let-optionals rest ((perms default-perms)) (let ((parent (parent-directory fname))) @@ -27,12 +27,16 @@ (if (not (file-exists? fname)) (-create-directory fname perms))))) +;; Return the length of the longest prefix common to lists L1 and L2, +;; by comparing elements using PRED (defaults to EQUAL?). (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))))) +;; Return the name of file NAME relative to DIR (defaults to current +;; directory). (define (relative-file-name name . rest) (let-optionals rest ((dir (cwd))) (let* ((abs-pl (split-file-name (absolute-file-name name))) @@ -41,6 +45,15 @@ (path-list->file-name (append (make-list (- (length dir-pl) cp-len) "..") (drop abs-pl cp-len)))))) +;; Return the name of FNAME, which must be absolute, with NEW-ROOT as +;; root. +(define (re-root-file-name fname new-root) + (let ((fname-pl (split-file-name fname)) + (new-root-pl (split-file-name new-root))) + (if (string=? (first fname-pl) "") + (path-list->file-name (append new-root-pl (cdr fname-pl))) + (error "no root to replace in relative file name" fname)))) + ;; Copy file/symlink SOURCE to TARGET and set the permisions of TARGET ;; to PERMS. TARGET must be the name of a non-existing file (i.e. it ;; cannot be the name of a directory). @@ -67,15 +80,27 @@ (decode #o040 "r") (decode #o020 "w") (decode #o010 "x") (decode #o004 "r") (decode #o002 "w") (decode #o001 "x")))) +;; Replace all bindings of KEY in ALIST with one binding KEY to DATUM. +(define (alist-replace key datum alist) + (alist-cons key datum (alist-delete key alist))) + +;; Return the value associated with KEY in ALIST. If none exists, +;; return DEFAULT, or signal an error if no DEFAULT was given. +(define (alist-get key alist . rest) + (cond ((assoc key alist) => cdr) + ((not (null? rest)) (first rest)) + (else (error "internal error: cannot find key in alist" key alist)))) + +;; Return a string of max(M,N) white spaces. +(define (spaces m n) (make-string (max m n) #\space)) + ;; ;; 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))) + (apply (if (get-option-value 'dry-run) dry-fn real-fn) args))) (define (dry-run-print msg . args) (apply format #t msg args) (newline)) @@ -116,14 +141,20 @@ ;; Versions are represented as lists of integers, the most significant ;; being at the head. +;; Return the printed representation of VERSION. (define (version->string version) (string-join (map number->string version) ".")) +;; Convert the printed representation of a version found in +;; VERSION-STRING to the version it represents. (define string->version (let ((split-version (infix-splitter "."))) (lambda (version-string) (map string->number (split-version version-string))))) +;; Compare two versions lexicographically and return the symbol +;; 'smaller if the first is strictly smaller than the second, 'equal +;; if both are equal, and 'greater otherwise. (define (version-compare v1 v2) (cond ((and (null? v1) (null? v2)) 'equal) ((null? v1) 'smaller) @@ -141,6 +172,28 @@ ;; Layouts ;; +;; Names of all shared locations (i.e. the ones which do not depend on +;; the platform). +(define shared-locations + '(active base misc-shared scheme doc)) + +;; Names of all non-shared (i.e. platform-dependent) locations. +(define non-shared-locations + '(lib)) + +;; All locations defined for a layout. +(define all-locations (append shared-locations non-shared-locations)) + +;; Return true iff the given location is "active", that is if files +;; should be installed in it. +(define (active-location? location) + (member location (if (get-option-value 'non-shared-only) + non-shared-locations + all-locations))) + +;; Parse a layout given as a string of comma-separated bindings. A +;; binding consists of the name of a location, followed by an equal +;; sign and the name of the directory to associate to the location. (define parse-layout (let ((split-defs (infix-splitter ",")) (split-sides (infix-splitter "="))) @@ -165,9 +218,9 @@ (cons (car key/value) (absolute-file-name (cdr key/value) prefix))) layout)) -(define (layout-dir layout dir) - (cond ((assoc dir layout) => cdr) - (else #f))) +;; Return the directory associated with the LOCATION in LAYOUT. +(define (layout-dir layout location) + (alist-get location layout #f)) ;; Predefined layouts @@ -175,9 +228,7 @@ `((base . ,base) (misc-shared . ,base) (scheme . ,(absolute-file-name "scheme" base)) - (lib . ,(absolute-file-name - (path-list->file-name (list "lib" platform)) - base)) + (lib . ,(absolute-file-name "lib" base)) (doc . ,(absolute-file-name "doc" base)))) (define (scsh-layout-1 platform pkg) @@ -221,14 +272,20 @@ (extensions package-extensions) (install-thunk package-install-thunk)) +;; Return the full name of PKG. (define (package-full-name pkg) (string-append (package-name pkg) "-" (version->string (package-version pkg)))) +;; Return the value of extension called EXT for PKG. If such an +;; extension doesn't exist, return #f. +(define (package-extension pkg ext) + (alist-get ext (package-extensions pkg) #f)) + ;; List of all defined packages (define packages '()) -;; Add a package to the above list +;; Add PKG to the above list of all defined packages. (define (add-package pkg) (set! packages (cons pkg packages))) @@ -237,9 +294,80 @@ ((define-package name version extensions body ...) (add-package (make-package name (quote version) - (quote extensions) + (quasiquote extensions) (lambda () body ...)))))) +;; +;; Package options +;; + +(define-record-type pkg-opt + (really-make-pkg-opt key + help + arg-help + required-arg? + optional-arg? + default + parse + show + transform) + pkg-opt? + (key pkg-opt-key) + (help pkg-opt-help) + (arg-help pkg-opt-arg-help) + (required-arg? pkg-opt-required-arg?) + (optional-arg? pkg-opt-optional-arg?) + (default pkg-opt-default) + (parse pkg-opt-parse) + (show pkg-opt-show) + (transform pkg-opt-transform)) + +(define (make-pkg-opt key help arg-help req-arg? opt-arg? default . rest) + (let-optionals rest ((parse identity) + (show identity) + (transform (lambda (old new) new))) + (really-make-pkg-opt key + help + arg-help + req-arg? + opt-arg? + default + parse + show + transform))) + +;; Return the name of PKG-OPT +(define (pkg-opt-name pkg-opt) + (symbol->string (pkg-opt-key pkg-opt))) + +;; Convert PKG-OPT into an SRFI-37 option. +(define (pkg-opt->option pkg-opt) + (let ((key (pkg-opt-key pkg-opt)) + (transform (pkg-opt-transform pkg-opt)) + (parse (pkg-opt-parse pkg-opt))) + (option (list (pkg-opt-name pkg-opt)) + (pkg-opt-required-arg? pkg-opt) + (pkg-opt-optional-arg? pkg-opt) + (lambda (opt name arg alist) + (alist-replace key + (transform (alist-get key alist) (parse arg)) + alist))))) + +;; Return a pair (key, default) which associates the default value of +;; PKG-OPT to its key. +(define (pkg-opt-key&default pkg-opt) + (cons (pkg-opt-key pkg-opt) (pkg-opt-default pkg-opt))) + +;; Return the list of all package options of the PACKAGES. +(define (all-package-options packages) + (append-map + (lambda (pkg) + (cond ((package-extension pkg 'options) + => (lambda (opts) + (map (lambda (args) (apply make-pkg-opt args)) opts))) + (else '()))) + packages)) + ;; ;; Actions ;; @@ -267,7 +395,7 @@ (cond ((or (file-regular? source) (file-symlink? source)) (-copy-file source target perms)) ((file-directory? source) - (create-directory target perms) + (-create-directory target perms) (install-directory-contents% layout source location @@ -283,12 +411,13 @@ (directory-files name #t)))) (define (install-thing name-or-pair location . rest) - (let-optionals rest ((target-rel-dir ".") (perms default-perms)) - (install-thing% (fluid *install-layout*) - name-or-pair - location - target-rel-dir - perms))) + (if (active-location? location) + (let-optionals rest ((target-rel-dir ".") (perms default-perms)) + (install-thing% (fluid *install-layout*) + name-or-pair + location + target-rel-dir + perms)))) (define (install-things names-or-pairs . rest) (for-each (lambda (name-or-pair) @@ -301,12 +430,13 @@ (define install-directories install-things) (define (install-directory-contents name location . rest) - (let-optionals rest ((target-rel-dir ".") (perms default-perms)) - (install-directory-contents% (fluid *install-layout*) - name - location - target-rel-dir - perms))) + (if (active-location? location) + (let-optionals rest ((target-rel-dir ".") (perms default-perms)) + (install-directory-contents% (fluid *install-layout*) + name + location + target-rel-dir + perms)))) (define (install-empty-directory% layout name location dir . rest) (let-optionals rest ((perms default-perms)) @@ -322,9 +452,17 @@ (define *layout* (make-fluid #f)) (define *install-layout* (make-fluid #f)) +;; Return the directory identified by LOCATION in the current layout. +;; If INSTALL? is true, return the directory valid during the +;; installation of the package, otherwise return the directory valid +;; after installation (i.e. during package use). (define (get-directory location install?) (layout-dir (fluid (if install? *install-layout* *layout*)) location)) +;; Perform all actions to install PKG in INSTALL-LAYOUT. If LAYOUT is +;; not the same as INSTALL-LAYOUT, assume that some external tool will +;; move the installed files so that they are laid out according to +;; LAYOUT. (define (install-package layout install-layout pkg) (let-fluids *layout* layout *install-layout* install-layout @@ -334,6 +472,8 @@ ;; Error handling ;; +;; Display MSG (a format string with ARGS as arguments) on the error +;; port, then exit with an error code of 1. (define (display-error-and-exit msg . args) (apply format (current-error-port) (string-append "Error: " msg) args) (newline) @@ -349,6 +489,7 @@ options: (predefined: ~a) --dry-run don't do anything, print what would have been done --inactive don't activate package after installing it + --non-shared-only only install platform-dependent files, if any advanced options: --build name of platform for which to build @@ -360,214 +501,150 @@ advanced options: END ) -(define usage-description-column 26) +(define usage-descr-col 26) -(define (complete-usage! optional-parts) +;; Complete the above USAGE string to include information about the +;; package options PKG-OPTS. +(define (complete-usage! pkg-opts) (let ((usage-port (make-string-output-port))) (write-string usage usage-port) - (write-string "\noptional parts:\n" usage-port) + (write-string "\npackage-specific options:\n" usage-port) (for-each - (lambda (part) - (let* ((sname (symbol->string (optional-part:name part))) - (pf (string-append " --with-" sname "=[yes|no]"))) + (lambda (pkg-opt) + (let ((option/arg (format #f "--~a ~a" + (pkg-opt-name pkg-opt) + (pkg-opt-arg-help pkg-opt)))) (format usage-port - "~a~a~a [~a]\n" - pf - (spaces 2 (- usage-description-column - (string-length pf))) - (optional-part:description part) - (unbooleanize (optional-part:default part))))) - optional-parts) + " ~a~a~a [~a]\n" + option/arg + (spaces 2 (- usage-descr-col (string-length option/arg))) + (pkg-opt-help pkg-opt) + ((pkg-opt-show pkg-opt) (pkg-opt-default pkg-opt))))) + pkg-opts) (set! usage (string-output-port-output usage-port)))) +;; Display the usage string, then MSG (a format string with ARGS as +;; arguments) on the standard output port, then exit with an error +;; code of 1. (define (display-usage-and-exit msg . args) - (if msg (begin (apply format #t msg args) (newline))) (format #t usage (car (command-line)) (string-join (map car predefined-layouts) ", ")) + (if msg (begin (apply format #t msg args) (newline))) (exit 1)) ;; ;; Command line parsing ;; -(define (booleanize s) +;; Predefined parsers/unparsers +(define (parse-boolean 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) +(define (show-boolean b) (if b "yes" "no")) -(define (spaces min n) - (make-string (if (< n min) min n) #\space)) +;; The identity function, sometimes useful for parsers/unparsers. +(define (identity x) x) -(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 - (optional-part-processor part-name)))) - parts)) - -(define (optional-parts-defaults parts) - (map (lambda (part) - (cons (optional-part:name part) (optional-part:default part))) - parts)) - -(define *optional-parts-alist* (make-fluid '())) - -(define (with-optional-part? name) - (cdr (assq name (fluid *optional-parts-alist*)))) - -(define (process-option opt - name - arg - prefix - i-prefix - layout - layout-file - build - activate? - dry-run? - opt-parts) - (case (cdr (assoc opt options/keys)) - ((prefix) - (values arg i-prefix layout layout-file build activate? dry-run? opt-parts)) - ((i-prefix) - (values prefix arg layout layout-file build activate? dry-run? opt-parts)) - ((layout) - (values prefix - i-prefix - (cond ((assoc arg predefined-layouts) => cdr) - (else (parse-layout arg))) - layout-file - build - activate? - dry-run? - opt-parts)) - ((layout-from) - (values prefix - i-prefix - (let ((layout (call-with-input-file arg read))) - (lambda args layout)) - layout-file - build - activate? - dry-run? - opt-parts)) - ((layout-to) - (values prefix i-prefix layout arg build activate? dry-run? opt-parts)) - ((build) - (values prefix i-prefix layout layout-file arg activate? dry-run? opt-parts)) - ((inactive) - (values prefix i-prefix layout layout-file build #f dry-run? opt-parts)) - ((dry-run) - (values prefix i-prefix layout layout-file build activate? #t opt-parts)) - ((help) - (display-usage-and-exit #f)))) - -(define (optional-part-processor part-name) - (lambda (opt - name - arg - prefix - i-prefix - layout - layout-file - build - activate? - dry-run? - opt-parts) - (values prefix - i-prefix - layout - layout-file - build - activate? - dry-run? - (alist-cons part-name (booleanize arg) opt-parts)))) - -(define options/keys - (list - (cons (option '(#\h "help") #f #f process-option) 'help) - (cons (option '("prefix") #t #f process-option) 'prefix) - (cons (option '("install-prefix") #t #f process-option) 'i-prefix) - (cons (option '("layout") #t #f process-option) 'layout) - (cons (option '("layout-from") #t #f process-option) 'layout-from) - (cons (option '("layout-to") #t #f process-option) 'layout-to) - (cons (option '("build") #t #f process-option) 'build) - (cons (option '("inactive") #f #f process-option) 'inactive) - (cons (option '("dry-run") #f #f process-option) 'dry-run))) +;; Fluid containing the value of all options. +(define *options-values* (make-fluid #f)) (define package-definition-file "pkg-def.scm") -(define (is-running-dry?) - (fluid *dry-run*)) +(define (get-option-value key) + (alist-get key (fluid *options-values*))) + +(define options + (let ((alist-arg-updater (lambda (key) + (lambda (opt name arg alist) + (alist-replace key arg alist)))) + (alist-boolean-updater (lambda (key) + (lambda (opt name arg alist) + (alist-replace key #t alist))))) + (list + (option '(#\h "help") #f #f + (lambda args (display-usage-and-exit #f))) + (option '("prefix") #t #f (alist-arg-updater 'prefix)) + (option '("dest-dir") #t #f (alist-arg-updater 'dest-dir)) + (option '("layout") #t #f + (lambda (opt name arg alist) + (alist-replace 'layout + (cond ((assoc arg predefined-layouts) => cdr) + (else (parse-layout arg))) + alist))) + (option '("layout-from") #t #f + (lambda (opt name arg alist) + (alist-replace 'layout + (let ((layout (call-with-input-file arg read))) + (lambda args layout)) + alist))) + (option '("layout-to") #t #f (alist-arg-updater 'layout-to)) + (option '("build") #t #f (alist-arg-updater 'build)) + (option '("non-shared-only") #f #f + (alist-boolean-updater 'non-shared-only)) + (option '("inactive") #f #f (alist-boolean-updater 'inactive)) + (option '("dry-run") #f #f (alist-boolean-updater 'dry-run))))) + +(define options-defaults + `((prefix . #f) + (dest-dir . "/") + (layout . ,scsh-layout-1) + (layout-to . #f) + (build . ,(host)) + (non-shared-only . #f) + (inactive . #f) + (dry-run . #f))) + +(define (parse-options args options defaults) + (args-fold args + options + (lambda (option name . rest) + (display-usage-and-exit "Unknown option ~a" name)) + (lambda (operand . rest) + (display-usage-and-exit "Don't know what to do with ~a" + operand)) + defaults)) (define (install-main 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) - (let ((all-optional-parts (get-all-optional-parts packages))) - (if (not (null? all-optional-parts)) - (complete-usage! all-optional-parts)) - (receive (prefix maybe-i-prefix layout-fn layout-to build activate? dry-run? opt-parts) - (args-fold (cdr cmd-line) - (append (map car options/keys) - (optional-parts->options all-optional-parts)) - (lambda (option name . rest) - (display-usage-and-exit "Unknown option ~a" name)) - (lambda (operand . rest) - (display-usage-and-exit - "Don't know what to do with ~a" - operand)) - #f ; default prefix - #f ; default install-prefix - scsh-layout-1 ; default layout-fn - #f ; default layout-to - (host) ; default build platform - #t ; default activation - #f ; default dry run - (optional-parts-defaults all-optional-parts)) - + (let ((all-pkg-opts (all-package-options packages))) + (if (not (null? all-pkg-opts)) + (complete-usage! all-pkg-opts)) + (let* ((all-opts (append options (map pkg-opt->option all-pkg-opts))) + (all-dfts (append options-defaults + (map pkg-opt-key&default all-pkg-opts))) + (options-values (parse-options (cdr cmd-line) all-opts all-dfts)) + (prefix (alist-get 'prefix options-values)) + (dest-dir (alist-get 'dest-dir options-values)) + (dest-prefix (and prefix (re-root-file-name prefix dest-dir))) + (layout-fn (alist-get 'layout options-values)) + (layout-to (alist-get 'layout-to options-values)) + (build (alist-get 'build options-values)) + (non-shared-only? (alist-get 'non-shared-only options-values)) + (activate? (not (alist-get 'inactive options-values)))) (if (not prefix) (display-error-and-exit "no prefix specified (use --prefix option)")) - (let ((i-prefix (or maybe-i-prefix prefix))) - (if (not (and (file-exists? i-prefix) (file-directory? i-prefix))) - (display-error-and-exit "install prefix directory ~a doesn't exist" - i-prefix)) - (let-fluids *dry-run* dry-run? - *optional-parts-alist* opt-parts - (lambda () - (for-each - (lambda (pkg) - (let* ((rel-layout (layout-fn build pkg)) - (layout (absolute-layout rel-layout prefix)) - (i-layout (absolute-layout rel-layout i-prefix))) - (if layout-to - (call-with-output-file - (string-append layout-to "_" - (package-full-name pkg)) - (lambda (port) - (write rel-layout port) (newline port)))) - (install-package layout i-layout pkg) - (if activate? (activate-package i-layout pkg)))) - packages))))))) + (let-fluids *options-values* options-values + (lambda () + (for-each + (lambda (pkg) + (let* ((rel-layout (layout-fn build pkg)) + (layout (absolute-layout rel-layout prefix)) + (i-layout (absolute-layout rel-layout dest-prefix))) + (if layout-to + (call-with-output-file + (string-append layout-to "_" (package-full-name pkg)) + (lambda (port) + (write rel-layout port) (newline port)))) + (install-package layout i-layout pkg) + (if (and activate? (not non-shared-only?)) + (activate-package i-layout pkg)))) + packages))))))