scsh-conservatory
/
scsh-install-lib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- --dest-dir is now taken to be a (string) prefix for the files, as 

this seems to be what other tools use; consequently, the default
    is now the empty string instead of "/",
- removed re-root-file-name,
- layouts can now be specified as functions in .scsh-pkg-defaults.scm,
- bug fix: textual layouts on the command line now work.
This commit is contained in:
michel-schinz 2004-06-13 17:56:13 +00:00
parent b0069c3ff0
commit 5a2a547ede
1 changed files with 20 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
scheme/install-lib/install-lib.scm
View File

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