From c7eae30444b207c975746c060820ddb7342e2c82 Mon Sep 17 00:00:00 2001 From: michel-schinz Date: Sun, 14 Dec 2003 14:45:20 +0000 Subject: [PATCH] - added layouts, which means: - removed query functions, which do not belong to the installation library anyway, and which will have to be redone for layouts, - replaced functions "package-installation-dir" and "package-installation-staging-dir" by "get-directory", - changed "install-file" & friends for layouts, - added "install-directory-contents", - rewrote option parsing code, - slightly adapted David Frese's code. --- scheme/install-lib/install-lib.scm | 610 ++++++++++++++++------------- 1 file changed, 337 insertions(+), 273 deletions(-) diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index f104361..d7ea04a 100755 --- a/scheme/install-lib/install-lib.scm +++ b/scheme/install-lib/install-lib.scm @@ -1,16 +1,14 @@ ;;; Installation library for scsh modules. -;;; $Id: install-lib.scm,v 1.2 2003/12/14 12:33:59 michel-schinz Exp $ +;;; $Id: install-lib.scm,v 1.3 2003/12/14 14:45:20 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 +;; - allow installation of platform-specific files only ;; ;; Utilities @@ -43,16 +41,17 @@ (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")))) +;; 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). +(define (copy-file source target perms) + (if (file-exists? target) + (error "copy-file: target file exists" target)) + (if (file-symlink? source) + (create-symlink (read-symlink source) target) + (begin + (run (cp ,source ,target)) + (set-file-mode target perms)))) ;; Like "load" but without printing anything. (define load-quietly @@ -61,6 +60,13 @@ (call-with-input-file file-name (lambda (port) (port-fold port read eval #f)))))) +(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")))) + ;; ;; Support for dry runs. ;; @@ -104,17 +110,6 @@ (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 ;; @@ -142,6 +137,78 @@ (define (version>? v1 v2) (eq? (version-compare v1 v2) 'greater)) (define (version=? v1 v2) (eq? (version-compare v1 v2) 'equal)) +;; +;; Layouts +;; + +(define parse-layout + (let ((split-defs (infix-splitter ",")) + (split-sides (infix-splitter "="))) + (lambda (str) + (map (lambda (name&value) + (let ((name/value (split-sides name&value))) + (cons (string->symbol (first name/value)) (second name/value)))) + (split-defs str))))) + +;; Combine layouts L1 and L2 by adding to L1 all the additional +;; mappings found in L2. +(define (combine-layouts l1 l2) + (fold (lambda (key/value layout) + (if (assoc (car key/value) layout) layout (cons key/value layout))) + l1 + l2)) + +;; Return an absolute version of LAYOUT by prepending PREFIX to all +;; its components (which must be relative). +(define (absolute-layout layout prefix) + (map (lambda (key/value) + (cons (car key/value) (absolute-file-name (cdr key/value) prefix))) + layout)) + +(define (layout-dir layout dir) + (cond ((assoc dir layout) => cdr) + (else #f))) + +;; Predefined layouts + +(define (scsh-layout platform base) + `((base . ,base) + (misc-shared . ,base) + (scheme . ,(absolute-file-name "scheme" base)) + (lib . ,(absolute-file-name + (path-list->file-name (list "lib" platform)) + base)) + (doc . ,(absolute-file-name "doc" base)))) + +(define (scsh-layout-1 platform pkg) + (combine-layouts '((active . ".")) + (scsh-layout platform (package-full-name pkg)))) + +(define (scsh-layout-2 platform pkg) + (combine-layouts + '((active . "active")) + (scsh-layout platform + (path-list->file-name + (list "installed" + (package-name pkg) + (version->string (package-version pkg))))))) + +(define (fhs-layout platform pkg) + (let ((base (absolute-file-name (package-full-name pkg) + "share/scsh/modules"))) + `((base . ,base) + (misc-shared . ,base) + (scheme . ,(absolute-file-name "scheme" base)) + (lib . ,(absolute-file-name (package-full-name pkg) + "lib/scsh/modules")) + (doc . ,(absolute-file-name (package-full-name pkg) "share/doc")) + (active . "share/scsh/modules")))) + +(define predefined-layouts + `(("scsh" . ,scsh-layout-1) + ("scsh-alt" . ,scsh-layout-2) + ("fhs" . ,fhs-layout))) + ;; ;; Packages ;; @@ -149,10 +216,14 @@ (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)) + (name package-name) + (version package-version) + (extensions package-extensions) + (install-thunk package-install-thunk)) + +(define (package-full-name pkg) + (string-append + (package-name pkg) "-" (version->string (package-version pkg)))) ;; List of all defined packages (define packages '()) @@ -169,174 +240,95 @@ (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))) +(define (activate-package layout pkg) + (let ((lnk-name (absolute-file-name (package-name pkg) + (layout-dir layout 'active)))) (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) + (-create-symlink (relative-file-name (layout-dir layout 'base) (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 (install-thing% layout name-or-pair location target-rel-dir perms) + (let* ((target-dir (absolute-file-name target-rel-dir + (layout-dir layout location))) + (source (if (pair? name-or-pair) (car name-or-pair) name-or-pair)) + (target-name (file-name-nondirectory (if (pair? name-or-pair) + (cdr name-or-pair) + name-or-pair))) + (target (absolute-file-name target-name target-dir))) + (create-directory&parents target-dir perms) + (cond ((or (file-regular? source) (file-symlink? source)) + (-copy-file source target perms)) + ((file-directory? source) + (create-directory target perms) + (install-directory-contents% layout + source + location + (absolute-file-name target-name + target-rel-dir) + perms)) + (else (error "cannot install file-system object" source))))) -(define (re-root-file file dir) - (absolute-file-name (file-name-nondirectory (directory-as-file-name file)) - dir)) +(define (install-directory-contents% layout name location target-rel-dir perms) + (for-each (lambda (thing) + (install-thing% layout thing location target-rel-dir perms)) + (map (lambda (f) (absolute-file-name f name)) + (directory-files name #t)))) -;; 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)))) +(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))) -;; 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-things names-or-pairs . rest) + (for-each (lambda (name-or-pair) + (apply install-thing name-or-pair rest)) + names-or-pairs)) -(define (install-empty-directory% root pkg target-dir . rest) +(define install-file install-thing) +(define install-files install-things) +(define install-directory install-thing) +(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))) + +(define (install-empty-directory% layout name location dir . rest) (let-optionals rest ((perms default-perms)) - (-create-directory (target-absolute-dir root pkg target-dir) perms))) + (-create-directory (absolute-file-name dir (layout-dir layout location)) + perms))) -(define (install-empty-directory&parents% root pkg target-dir . rest) +(define (install-empty-directory&parents% layout name location dir . rest) (let-optionals rest ((perms default-perms)) - (create-directory&parents (target-absolute-dir root pkg target-dir) - perms))) + (create-directory&parents + (absolute-file-name dir (layout-dir layout location)) + perms))) -(define *root* (make-fluid #f)) -(define *dest-root* (make-fluid #f)) -(define *package* (make-fluid #f)) +(define *layout* (make-fluid #f)) +(define *install-layout* (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 (get-directory location install?) + (layout-dir (fluid (if install? *install-layout* *layout*)) location)) -(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))) +(define (install-package layout install-layout pkg) + (let-fluids *layout* layout + *install-layout* install-layout + (package-install-thunk pkg))) ;; ;; Error handling @@ -349,63 +341,62 @@ (define usage #< 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 + +options: + -h, --help display this help message, then exit + --prefix specify directory where files are installed + --layout specify layout of installation directory + (predefined: ~a) + --dry-run don't do anything, print what would have been done + --inactive don't activate package after installing it advanced options: - -d, --dest-root specify staging root directory + --build name of platform for which to build + --layout-from load layout of installation directory from file + --layout-to output layout to given file + --install-prefix specify prefix to used during installation + (to be used only during staged installations) END ) +(define usage-description-column 26) + +(define (complete-usage! optional-parts) + (let ((usage-port (make-string-output-port))) + (write-string usage usage-port) + (write-string "\noptional parts:\n" usage-port) + (for-each + (lambda (part) + (let* ((sname (symbol->string (optional-part:name part))) + (pf (string-append " --with-" sname "=[yes|no]"))) + (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) + (set! usage (string-output-port-output usage-port)))) + (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) + (format #t + usage + (car (command-line)) + (string-join (map car predefined-layouts) ", ")) (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)))) + (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")) @@ -417,7 +408,7 @@ END (if (null? packages) '() (let* ((p (car packages)) - (ext (package:extensions p)) + (ext (package-extensions p)) (op (assq 'optional-parts ext))) (append (if op (cdr op) '()) (get-all-optional-parts (cdr packages)))))) @@ -430,11 +421,9 @@ END (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)))))) + (option (list (string-append "with-" (symbol->string part-name))) + #t #f + (optional-part-processor part-name)))) parts)) (define (optional-parts-defaults parts) @@ -442,27 +431,90 @@ END (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 (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))) (define package-definition-file "pkg-def.scm") @@ -470,40 +522,52 @@ END (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) + (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 . seeds) ; operand + (lambda (operand . rest) (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))))))) + #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)) + + (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)))))))