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

Implemented suggestions by Anthony Carrico: 

- display an error message when an unknown layout is given,
- the version number in "define-package" is now quasi-quoted,
- added "install-string" to install an arbitrary string in a file,
- forbid relative prefixes.
This commit is contained in:
michel-schinz 2004-02-08 09:50:14 +00:00
parent dc75e91598
commit cfef23f1b3
1 changed files with 35 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,5 +1,5 @@
;;; Installation library for scsh modules.
;;; $Id: install-lib.scm,v 1.7 2004/02/01 23:14:39 frese Exp $
;;; $Id: install-lib.scm,v 1.8 2004/02/08 09:50:14 michel-schinz Exp $
;; TODO
;; - add support for communication between configure and pkg-def.scm
@ -230,14 +230,20 @@
;; 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.
;; Return #f if parsing fails.
(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)))))
(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)))))))
;; Combine layouts L1 and L2 by adding to L1 all the additional
;; mappings found in L2.
@ -329,8 +335,8 @@
(syntax-rules ()
((define-package name version extensions body ...)
(add-package (make-package name
(quote version)
(quasiquote extensions)
(quasiquote version)
(quasiquote extensions)
(lambda () body ...))))))
;;
@ -415,7 +421,7 @@
(let ((dir (get-directory 'base #t)))
(create-directory&parents dir)
(if (not (or (get-option-value 'dry-run)
(get-option-value 'non-shared-only)))
(get-option-value 'non-shared-only)))
(with-output-to-file (absolute-file-name "load.scm" dir)
thunk))))
@ -504,6 +510,22 @@
target-rel-dir
perms-fn))))
(define (install-string% layout str target-name location target-rel-dir)
(let ((target-dir (absolute-file-name target-rel-dir
(layout-dir layout location))))
(create-directory&parents target-dir)
(call-with-output-file (absolute-file-name target-name target-dir)
(lambda (port) (write-string str port)))))
(define (install-string str target-name location . rest)
(let-optionals rest ((target-rel-dir "."))
(if (active-location? location)
(install-string% (fluid *install-layout*)
str
target-name
location
target-rel-dir))))
(define *layout* (make-fluid #f))
(define *install-layout* (make-fluid #f))
@ -631,7 +653,9 @@ END
(lambda (opt name arg alist)
(alist-replace 'layout
(cond ((assoc arg predefined-layouts) => cdr)
(else (parse-layout arg)))
((parse-layout arg) => identity)
(else (display-error-and-exit
"invalid layout ~a" arg)))
alist)))
(option '("layout-from") #t #f
(lambda (opt name arg alist)
@ -690,6 +714,8 @@ END
(activate? (not (alist-get 'inactive 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"))
(let-fluids *options-values* options-values
(lambda ()
(for-each