diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index 40931ea..5001399 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.18 2004/05/22 10:43:08 michel-schinz Exp $ +;;; $Id: install-lib.scm,v 1.19 2004/06/13 17:56:13 michel-schinz Exp $ ;; TODO ;; - think about --build: does it make sense? @@ -98,15 +98,6 @@ (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)))) - ;; Similar to path-list->file-name, but take all arguments as ;; components of the path. (define (paths->file-name . paths) @@ -302,13 +293,14 @@ (lambda (str) (call-with-current-continuation (lambda (return) - (map (lambda (name&value) - (let ((name/value (split-sides name&value))) - (if (= 2 (length name/value)) - (cons (string->symbol (first name/value)) - (second name/value)) - (return #f)))) - (split-defs str))))))) + (lambda (pkg) + (map (lambda (name&value) + (let ((name/value (split-sides name&value))) + (if (= 2 (length name/value)) + (cons (string->symbol (first name/value)) + (second name/value)) + (return #f)))) + (split-defs str)))))))) ;; Return an absolute version of LAYOUT by prepending PREFIX to all ;; its components (which must be relative). @@ -384,12 +376,14 @@ ("fhs" . ,fhs-layout) ("fhs-program" . ,fhs-program-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))) +;; If LAYOUT-SPEC is a procedure, return it as-is. If it's a string +;; and refers to a predefined layout, this layout is returned. If it's +;; a string and a valid layout definition, parse and return it. +;; Otherwise, return false. +(define (resolve-layout layout-spec) + (or (and (procedure? layout-spec) layout-spec) + (alist-get layout-spec predefined-layouts #f) + (parse-layout layout-spec))) ;; ;; Packages @@ -700,7 +694,7 @@ (define (install-packages packages options-values) (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))) + (dest-prefix (and prefix (string-append dest-dir prefix))) (layout-fn (resolve-layout (alist-get 'layout options-values))) (layout-to (alist-get 'layout-to options-values)) (build (alist-get 'build options-values)) @@ -1006,7 +1000,7 @@ END (define options-defaults `((prefix . #f) - (dest-dir . "/") + (dest-dir . "") (layout . "scsh") (layout-to . #f) (build . ,(host)) @@ -1019,7 +1013,7 @@ END (define program-options-defaults `((prefix . "/usr/local") - (dest-dir . "/") + (dest-dir . "") (layout . "fhs-program") (layout-to . #f) (build . ,(host))