From 7370c021483e428a9da15cdf8693d42fe75ecc62 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 2 Sep 2016 10:22:13 +0200 Subject: tests: Test 'wrap-program' without building a package. * tests/build-utils.scm (%store): Remove. ("wrap-program, one input, multiple calls"): Rewrite without resorting to packages and derivations. --- tests/build-utils.scm | 89 +++++++++++++++++++++------------------------------ 1 file changed, 36 insertions(+), 53 deletions(-) (limited to 'tests') diff --git a/tests/build-utils.scm b/tests/build-utils.scm index cc96738e36..cc59b2eff7 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2015 Ludovic Courtès +;;; Copyright © 2012, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,12 +19,9 @@ (define-module (test-build-utils) #:use-module (guix tests) - #:use-module (guix store) - #:use-module (guix derivations) #:use-module (guix build utils) - #:use-module (guix packages) - #:use-module (guix build-system) - #:use-module (guix build-system trivial) + #:use-module ((guix utils) + #:select (%current-system call-with-temporary-directory)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-34) @@ -32,9 +29,6 @@ #:use-module (rnrs io ports) #:use-module (ice-9 popen)) -(define %store - (open-connection-for-tests)) - (test-begin "build-utils") @@ -95,49 +89,38 @@ 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))) - - ;; The bootstrap Bash is linked against an old libc and would abort with - ;; an assertion failure when trying to load incompatible locale data. - (unsetenv "LOCPATH") - - (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-equal "wrap-program, one input, multiple calls" + "hello world\n" + (call-with-temporary-directory + (lambda (directory) + (let ((bash (search-bootstrap-binary "bash" (%current-system))) + (foo (string-append directory "/foo"))) + + (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. + (setenv "PATH" (dirname bash)) + (wrap-program foo `("GUIX_FOO" prefix ("hello"))) + (wrap-program foo `("GUIX_BAR" prefix ("world"))) + + ;; The bootstrap Bash is linked against an old libc and would abort with + ;; an assertion failure when trying to load incompatible locale data. + (unsetenv "LOCPATH") + + (let* ((pipe (open-input-pipe foo)) + (str (get-string-all pipe))) + (with-directory-excursion directory + (for-each delete-file + '("foo" ".foo-real" ".foo-wrap-01" ".foo-wrap-02"))) + (and (zero? (close-pipe pipe)) + str)))))) (test-end) -- cgit v1.2.3 From b14a8385095f6672960fb8378c6578acf1ebbf8a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 7 Sep 2016 23:59:02 +0200 Subject: utils: 'wrap-program' produces only one wrapper file. * guix/build/utils.scm (wrap-program)[wrapper-file-name] [next-wrapper-number, wrapper-target]: Remove. [wrapped-file, already-wrapped?]: New variables. [last-line]: New procedure. Use it to append to PROG when a wrapper already exists. * tests/build-utils.scm ("wrap-program, one input, multiple calls"): Adjust the list of files to delete. --- guix/build/utils.scm | 130 +++++++++++++++++++++++++++----------------------- tests/build-utils.scm | 3 +- 2 files changed, 72 insertions(+), 61 deletions(-) (limited to 'tests') diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 6e706b378e..bc6f114152 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2013 Andreas Enge ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2015 Mark H Weaver @@ -944,64 +944,76 @@ 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. -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"))) - (rename-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 - ((var sep '= rest) - (format #f "export ~a=\"~a\"" - var (string-join rest sep))) - ((var sep 'prefix rest) - (format #f "export ~a=\"~a${~a~a+~a}$~a\"" - var (string-join rest sep) var sep sep var)) - ((var sep 'suffix rest) - (format #f "export ~a=\"$~a${~a~a+~a}~a\"" - var var var sep sep (string-join rest sep))) - ((var '= rest) - (format #f "export ~a=\"~a\"" - var (string-join rest ":"))) - ((var 'prefix rest) - (format #f "export ~a=\"~a${~a:+:}$~a\"" - var (string-join rest ":") var var)) - ((var 'suffix rest) - (format #f "export ~a=\"$~a${~a:+:}~a\"" - var var var (string-join rest ":"))))) - - (with-output-to-file prog-tmp - (lambda () - (format #t - "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%" - (which "bash") - (string-join (map export-variable vars) - "\n") - (canonicalize-path target)))) - - (chmod prog-tmp #o755) - (rename-file prog-tmp wrapper) - (symlink wrapper prog-tmp) - (rename-file prog-tmp prog))) +If PROG has previously been wrapped by 'wrap-program', the wrapper is extended +with definitions for VARS." + (define wrapped-file + (string-append (dirname prog) "/." (basename prog) "-real")) + + (define already-wrapped? + (file-exists? wrapped-file)) + + (define (last-line port) + ;; Return the last line read from PORT and leave PORT's cursor right + ;; before it. + (let loop ((previous-line-offset 0) + (previous-line "") + (position (seek port 0 SEEK_CUR))) + (match (read-line port 'concat) + ((? eof-object?) + (seek port previous-line-offset SEEK_SET) + previous-line) + ((? string? line) + (loop position line (+ (string-length line) position)))))) + + (define (export-variable lst) + ;; Return a string that exports an environment variable. + (match lst + ((var sep '= rest) + (format #f "export ~a=\"~a\"" + var (string-join rest sep))) + ((var sep 'prefix rest) + (format #f "export ~a=\"~a${~a~a+~a}$~a\"" + var (string-join rest sep) var sep sep var)) + ((var sep 'suffix rest) + (format #f "export ~a=\"$~a${~a~a+~a}~a\"" + var var var sep sep (string-join rest sep))) + ((var '= rest) + (format #f "export ~a=\"~a\"" + var (string-join rest ":"))) + ((var 'prefix rest) + (format #f "export ~a=\"~a${~a:+:}$~a\"" + var (string-join rest ":") var var)) + ((var 'suffix rest) + (format #f "export ~a=\"$~a${~a:+:}~a\"" + var var var (string-join rest ":"))))) + + (if already-wrapped? + + ;; PROG is already a wrapper: add the new "export VAR=VALUE" lines just + ;; before the last line. + (let* ((port (open-file prog "r+")) + (last (last-line port))) + (for-each (lambda (var) + (display (export-variable var) port) + (newline port)) + vars) + (display last port) + (close-port port)) + + ;; PROG is not wrapped yet: create a shell script that sets VARS. + (let ((prog-tmp (string-append wrapped-file "-tmp"))) + (link prog wrapped-file) + + (call-with-output-file prog-tmp + (lambda (port) + (format port + "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%" + (which "bash") + (string-join (map export-variable vars) "\n") + (canonicalize-path wrapped-file)))) + + (chmod prog-tmp #o755) + (rename-file prog-tmp prog)))) ;;; diff --git a/tests/build-utils.scm b/tests/build-utils.scm index cc59b2eff7..7d49446f66 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -118,8 +118,7 @@ (let* ((pipe (open-input-pipe foo)) (str (get-string-all pipe))) (with-directory-excursion directory - (for-each delete-file - '("foo" ".foo-real" ".foo-wrap-01" ".foo-wrap-02"))) + (for-each delete-file '("foo" ".foo-real"))) (and (zero? (close-pipe pipe)) str)))))) -- cgit v1.2.3 From b66d6d52ccaef0ffc660df9077500ca52e3ab35f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 8 Nov 2016 23:31:36 +0100 Subject: tests: Fix 'fold-packages' for hidden packages. * tests/packages.scm ("fold-packages, hidden package"): Expect GUILE-2.0, not GUILE-2.0/FIXED. This is a followup to c62a31ca802c2b225279c4b0360a4cfc2723ad28. --- tests/packages.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'tests') diff --git a/tests/packages.scm b/tests/packages.scm index 5f5fb5de87..47e76b53e9 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -909,7 +909,7 @@ (test-assert "fold-packages, hidden package" ;; There are two public variables providing "guile@2.0" ('guile-final' in - ;; commencement.scm and 'guile-2.0/fixed' in guile.scm), but only the latter + ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter ;; should show up. (match (fold-packages (lambda (p r) (if (and (string=? (package-name p) "guile") @@ -919,7 +919,7 @@ r)) '()) ((one) - (eq? one guile-2.0/fixed)))) + (eq? one guile-2.0)))) (test-assert "find-packages-by-name" (match (find-packages-by-name "hello") -- cgit v1.2.3