diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index 84c67d8..679fc33 100755 --- a/scheme/install-lib/install-lib.scm +++ b/scheme/install-lib/install-lib.scm @@ -1,5 +1,5 @@ ;;; Installation library for scsh modules. -;;; $Id: install-lib.scm,v 1.11 2004/02/20 08:22:07 michel-schinz Exp $ +;;; $Id: install-lib.scm,v 1.12 2004/02/23 20:11:40 michel-schinz Exp $ ;; TODO ;; - add a "--debug" option @@ -128,6 +128,14 @@ (define (alist-replace key datum alist) (alist-cons key datum (alist-delete key alist))) +;; Add all mappings from ALIST-2 to ALIST-1. If a key is mapped in +;; both lists, the mapping in the first list takes precedence. +(define (alist-combine alist-1 alist-2) + (fold (lambda (key/value result) + (if (assoc (car key/value) result) result (cons key/value result))) + alist-1 + alist-2)) + ;; 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) @@ -251,14 +259,6 @@ (return #f)))) (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) @@ -280,11 +280,11 @@ (doc . ,(absolute-file-name "doc" base)))) (define (scsh-layout-1 platform pkg) - (combine-layouts '((active . ".")) - (scsh-layout platform (package-full-name pkg)))) + (alist-combine '((active . ".")) + (scsh-layout platform (package-full-name pkg)))) (define (scsh-layout-2 platform pkg) - (combine-layouts + (alist-combine '((active . "active")) (scsh-layout platform (path-list->file-name @@ -308,6 +308,13 @@ ("scsh-alt" . ,scsh-layout-2) ("fhs" . ,fhs-layout))) +;; If NAME-OR-LAYOUT refers to a predefined layout, return it. +;; Otherwise, if NAME-OR-LAYOUT is a valid layout definition, parse +;; and return it. Otherwise, return false. +(define (resolve-layout name-or-layout) + (or (alist-get name-or-layout predefined-layouts #f) + (parse-layout name-or-layout))) + ;; ;; Packages ;; @@ -481,18 +488,21 @@ (cdr name-or-pair) name-or-pair))) (target (absolute-file-name target-name target-dir))) - (create-directory&parents target-dir perms-fn) - (cond ((or (file-regular? source) (file-symlink? source)) - (-copy-file source target)) - ((file-directory? source) - (-create-directory target (file-mode source)) - (install-directory-contents% layout - source - location - (absolute-file-name target-name - target-rel-dir) - perms-fn)) - (else (error "cannot install file-system object" source))))) + (if (not ((get-option-value 'exclude) source)) + (begin + (create-directory&parents target-dir perms-fn) + (cond ((or (file-regular? source) (file-symlink? source)) + (-copy-file source target)) + ((file-directory? source) + (-create-directory target (file-mode source)) + (install-directory-contents% layout + source + location + (absolute-file-name + target-name + target-rel-dir) + perms-fn)) + (else (error "cannot install file-system object" source))))))) (define (install-directory-contents% layout name @@ -575,7 +585,7 @@ (let* ((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-fn (resolve-layout (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)) @@ -616,10 +626,10 @@ ;; 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) +;; Display all the MSGS on the error port, then exit with an error +;; code of 1. +(define (display-error-and-exit . msgs) + (for-each display (cons "Error: " msgs)) (newline) (exit 1)) @@ -669,15 +679,15 @@ END 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) +;; Display the usage string, then all MSGS on the standard output +;; port, then exit with an error code of 1. +(define (display-usage-and-exit . msgs) (format #t usage (car (command-line)) (string-join (map car predefined-layouts) ", ")) - (if msg (begin (apply format #t msg args) (newline))) + (for-each display msgs) + (newline) (exit 1)) ;; @@ -689,7 +699,7 @@ END (cond ((string=? s "yes") #t) ((string=? s "no") #f) (else (display-error-and-exit - "unknown boolean value '~a'. Use 'yes' or 'no'." s)))) + "unknown boolean value '"s"'. Use 'yes' or 'no'.")))) (define (show-boolean b) (if b "yes" "no")) @@ -714,17 +724,10 @@ END (alist-replace key #t alist))))) (list (option '(#\h "help") #f #f - (lambda args (display-usage-and-exit #f))) + (lambda args (display-usage-and-exit))) (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) - ((parse-layout arg) => identity) - (else (display-error-and-exit - "invalid layout ~a" arg))) - alist))) + (option '("layout") #t #f (alist-arg-updater 'layout)) (option '("layout-from") #t #f (lambda (opt name arg alist) (alist-replace 'layout @@ -740,43 +743,70 @@ END (option '("verbose") #f #f (alist-boolean-updater 'verbose)) (option '("force") #f #f (alist-boolean-updater 'force))))) +(define no-user-defaults-option "--no-user-defaults") + +(define (parse-options args options defaults) + (args-fold args + options + (lambda (option name . rest) + (display-usage-and-exit "Unknown option "name)) + (lambda (operand . rest) + (display-usage-and-exit "Don't know what to do with " operand)) + defaults)) + +;; Return user-specific defaults. +(define (read-user-defaults) + (let ((file (expand-file-name "~/.scsh-pkg-defaults.scm"))) + (if (file-exists? file) + (call-with-input-file file + (lambda (port) + (let ((defaults (read port))) + (if (or (eof-object? defaults)) + (display-error-and-exit "no valid defaults found in "file)) + (if (not (eof-object? (read port))) + (display-error-and-exit + "more than one expression found in "file)) + (eval (list 'quasiquote defaults) (interaction-environment))))) + '()))) + (define options-defaults `((prefix . #f) (dest-dir . "/") - (layout . ,scsh-layout-1) + (layout . "scsh") (layout-to . #f) (build . ,(host)) (non-shared-only . #f) (inactive . #f) (dry-run . #f) (verbose . #f) - (force . #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)) + (force . #f) + (exclude . ,(lambda args #f)))) (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)) + (display-error-and-exit "cannot find package definition file" + "("package-definition-file")")) (let* ((packages (load-packages)) (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 + (all-dfts (append (alist-combine + (if (member no-user-defaults-option cmd-line) + '() + (read-user-defaults)) + 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))) + (options-values (parse-options (delete no-user-defaults-option + (cdr cmd-line)) + all-opts + all-dfts)) + (prefix (alist-get 'prefix options-values)) + (layout (alist-get 'layout options-values))) (if (not prefix) (display-error-and-exit "no prefix specified (use --prefix option)")) (if (not (file-name-absolute? prefix)) (display-error-and-exit "prefix must be an absolute path")) + (if (not (resolve-layout layout)) + (display-error-and-exit "invalid layout "layout)) (install-packages packages options-values))))