utils: Allow wrap-program to be called multiple times.
* guix/build/utils.scm (wrap-program): Multiple invocations of wrap-program for the same file create successive wrappers. Adjust docstring. * tests/build-utils.scm: Test new wrap-program behavior. (%store): New variable.
This commit is contained in:
Eric Bavier
parent
9fac9e3be3
commit
de61113857
@ -687,8 +687,7 @@ known as `nuke-refs' in Nixpkgs."
|
||||
result))))))
|
||||
|
||||
(define* (wrap-program prog #:rest vars)
|
||||
"Rename PROG to .PROG-real and make PROG a wrapper. VARS should look like
|
||||
this:
|
||||
"Make a wrapper for PROG. VARS should look like this:
|
||||
|
||||
'(VARIABLE DELIMITER POSITION LIST-OF-DIRECTORIES)
|
||||
|
||||
@ -697,23 +696,44 @@ where DELIMITER is optional. ':' will be used if DELIMITER is not given.
|
||||
For example, this command:
|
||||
|
||||
(wrap-program \"foo\"
|
||||
'(\"PATH\" \":\" = (\"/nix/.../bar/bin\"))
|
||||
'(\"CERT_PATH\" suffix (\"/nix/.../baz/certs\"
|
||||
'(\"PATH\" \":\" = (\"/gnu/.../bar/bin\"))
|
||||
'(\"CERT_PATH\" suffix (\"/gnu/.../baz/certs\"
|
||||
\"/qux/certs\")))
|
||||
|
||||
will copy 'foo' to '.foo-real' and create the file 'foo' with the following
|
||||
contents:
|
||||
|
||||
#!location/of/bin/bash
|
||||
export PATH=\"/nix/.../bar/bin\"
|
||||
export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/nix/.../baz/certs:/qux/certs\"
|
||||
export PATH=\"/gnu/.../bar/bin\"
|
||||
export CERT_PATH=\"$CERT_PATH${CERT_PATH:+:}/gnu/.../baz/certs:/qux/certs\"
|
||||
exec location/of/.foo-real
|
||||
|
||||
This is useful for scripts that expect particular programs to be in $PATH, for
|
||||
programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or
|
||||
modules in $GUILE_LOAD_PATH, etc."
|
||||
(let ((prog-real (string-append (dirname prog) "/." (basename prog) "-real"))
|
||||
(prog-tmp (string-append (dirname prog) "/." (basename prog) "-tmp")))
|
||||
modules in $GUILE_LOAD_PATH, etc.
|
||||
|
||||
If PROG has previously been wrapped by wrap-program the wrapper will point to
|
||||
the previous wrapper."
|
||||
(define (wrapper-file-name number)
|
||||
(format #f "~a/.~a-wrap-~2'0d" (dirname prog) (basename prog) number))
|
||||
(define (next-wrapper-number)
|
||||
(let ((wrappers
|
||||
(find-files (dirname prog)
|
||||
(string-append "\\." (basename prog) "-wrap-.*"))))
|
||||
(if (null? wrappers)
|
||||
0
|
||||
(string->number (string-take-right (last wrappers) 2)))))
|
||||
(define (wrapper-target number)
|
||||
(if (zero? number)
|
||||
(let ((prog-real (string-append (dirname prog) "/."
|
||||
(basename prog) "-real")))
|
||||
(copy-file prog prog-real)
|
||||
prog-real)
|
||||
(wrapper-file-name number)))
|
||||
(let* ((number (next-wrapper-number))
|
||||
(target (wrapper-target number))
|
||||
(wrapper (wrapper-file-name (1+ number)))
|
||||
(prog-tmp (string-append target "-tmp")))
|
||||
(define (export-variable lst)
|
||||
;; Return a string that exports an environment variable.
|
||||
(match lst
|
||||
@ -736,8 +756,6 @@ modules in $GUILE_LOAD_PATH, etc."
|
||||
(format #f "export ~a=\"$~a${~a:+:}~a\""
|
||||
var var var (string-join rest ":")))))
|
||||
|
||||
(copy-file prog prog-real)
|
||||
|
||||
(with-output-to-file prog-tmp
|
||||
(lambda ()
|
||||
(format #t
|
||||
@ -745,9 +763,11 @@ modules in $GUILE_LOAD_PATH, etc."
|
||||
(which "bash")
|
||||
(string-join (map export-variable vars)
|
||||
"\n")
|
||||
(canonicalize-path prog-real))))
|
||||
(canonicalize-path target))))
|
||||
|
||||
(chmod prog-tmp #o755)
|
||||
(rename-file prog-tmp wrapper)
|
||||
(symlink wrapper prog-tmp)
|
||||
(rename-file prog-tmp prog)))
|
||||
|
||||
;;; Local Variables:
|
||||
|
||||
@ -18,9 +18,24 @@
|
||||
|
||||
|
||||
(define-module (test-build-utils)
|
||||
#:use-module (guix tests)
|
||||
#:use-module (guix store)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix build utils)
|
||||
#:use-module (srfi srfi-64))
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix build-system)
|
||||
#:use-module (guix build-system trivial)
|
||||
#:use-module (gnu packages)
|
||||
#:use-module (gnu packages bootstrap)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (ice-9 popen))
|
||||
|
||||
(define %store
|
||||
(open-connection-for-tests))
|
||||
|
||||
|
||||
(test-begin "build-utils")
|
||||
|
||||
(test-equal "alist-cons-before"
|
||||
@ -80,6 +95,46 @@
|
||||
port
|
||||
cons)))))
|
||||
|
||||
(test-assert "wrap-program, one input, multiple calls"
|
||||
(let* ((p (package
|
||||
(name "test-wrap-program") (version "0") (source #f)
|
||||
(synopsis #f) (description #f) (license #f) (home-page #f)
|
||||
(build-system trivial-build-system)
|
||||
(arguments
|
||||
`(#:guile ,%bootstrap-guile
|
||||
#:modules ((guix build utils))
|
||||
#:builder
|
||||
(let* ((out (assoc-ref %outputs "out"))
|
||||
(bash (assoc-ref %build-inputs "bash"))
|
||||
(foo (string-append out "/foo")))
|
||||
(begin
|
||||
(use-modules (guix build utils))
|
||||
(mkdir out)
|
||||
(call-with-output-file foo
|
||||
(lambda (p)
|
||||
(format p
|
||||
"#!~a~%echo \"${GUIX_FOO} ${GUIX_BAR}\"~%"
|
||||
bash)))
|
||||
(chmod foo #o777)
|
||||
;; wrap-program uses `which' to find bash for the wrapper
|
||||
;; shebang, but it can't know about the bootstrap bash in
|
||||
;; the store, since it's not named "bash". Help it out a
|
||||
;; bit by providing a symlink it this package's output.
|
||||
(symlink bash (string-append out "/bash"))
|
||||
(setenv "PATH" out)
|
||||
(wrap-program foo `("GUIX_FOO" prefix ("hello")))
|
||||
(wrap-program foo `("GUIX_BAR" prefix ("world")))
|
||||
#t))))
|
||||
(inputs `(("bash" ,(search-bootstrap-binary "bash"
|
||||
(%current-system)))))))
|
||||
(d (package-derivation %store p)))
|
||||
(and (build-derivations %store (pk 'drv d (list d)))
|
||||
(let* ((p (derivation->output-path d))
|
||||
(foo (string-append p "/foo"))
|
||||
(pipe (open-input-pipe foo))
|
||||
(str (get-string-all pipe)))
|
||||
(equal? str "hello world\n")))))
|
||||
|
||||
(test-end)
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user