diff options
| -rw-r--r-- | guix/build/utils.scm | 44 | ||||
| -rw-r--r-- | tests/build-utils.scm | 57 |
2 files changed, 88 insertions, 13 deletions
diff --git a/guix/build/utils.scm b/guix/build/utils.scm index d169053c7b..7257b30dfd 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -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: diff --git a/tests/build-utils.scm b/tests/build-utils.scm index e94f04b239..a5ea640c47 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -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) |