X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/233e76769ae3a438bff7117c68f2c88739a28db0..3159fcf14519f02c79ad84b441985982cb1efeb9:/tests/build-utils.scm diff --git a/tests/build-utils.scm b/tests/build-utils.scm index 0df4cd2737..47a57a984b 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Ludovic Courtès +;;; Copyright © 2012, 2015, 2016, 2019 Ludovic Courtès +;;; Copyright © 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,9 +19,19 @@ (define-module (test-build-utils) + #:use-module (guix tests) #:use-module (guix build utils) - #:use-module (srfi srfi-64)) + #: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) + #:use-module (srfi srfi-35) + #:use-module (srfi srfi-64) + #:use-module (rnrs io ports) + #:use-module (ice-9 popen)) + (test-begin "build-utils") (test-equal "alist-cons-before" @@ -80,13 +91,154 @@ port cons))))) -(test-end) +(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"))) - -(exit (= (test-runner-fail-count (test-runner-current)) 0)) + (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. + (with-environment-variable "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"))) + (and (zero? (close-pipe pipe)) + str))))))) + +(test-assert "invoke/quiet, success" + (begin + (invoke/quiet "true") + #t)) + +(test-assert "invoke/quiet, failure" + (guard (c ((message-condition? c) + (string-contains (condition-message c) "This is an error."))) + (invoke/quiet "sh" "-c" "echo This is an error. ; false") + #f)) + +(test-assert "invoke/quiet, failure, message on stderr" + (guard (c ((message-condition? c) + (string-contains (condition-message c) + "This is another error."))) + (invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false") + #f)) -;;; Local Variables: -;;; eval: (put 'test-assert 'scheme-indent-function 1) -;;; eval: (put 'test-equal 'scheme-indent-function 1) -;;; eval: (put 'call-with-input-string 'scheme-indent-function 1) -;;; End: +(let ((script-contents "\ +#!/anything/cabbage-bash-1.2.3/bin/sh + +echo hello world")) + + (test-equal "wrap-script, simple case" + (string-append + (format #f "\ +#!~a --no-auto-compile +#!#; Guix wrapper +#\\-~s +#\\-~s +" + (which "guile") + '(begin (let ((current (getenv "GUIX_FOO"))) + (setenv "GUIX_FOO" + (if current + (string-append "/some/path:/some/other/path" + ":" current) + "/some/path:/some/other/path")))) + '(let ((cl (command-line))) + (apply execl "/anything/cabbage-bash-1.2.3/bin/sh" + (car cl) + (cons (car cl) + (append '("") cl))))) + script-contents) + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port script-contents))) + (chmod script-file-name #o777) + (wrap-script script-file-name + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path"))) + (let ((str (call-with-input-file script-file-name get-string-all))) + (with-directory-excursion directory + (delete-file "foo")) + str)))))) + +(let ((script-contents "\ +#!/anything/cabbage-bash-1.2.3/bin/python3 -and -args +# vim:fileencoding=utf-8 +print('hello world')")) + + (test-equal "wrap-script, with encoding declaration" + (string-append + (format #f "\ +#!MYGUILE --no-auto-compile +#!#; # vim:fileencoding=utf-8 +#\\-~s +#\\-~s +" + '(begin (let ((current (getenv "GUIX_FOO"))) + (setenv "GUIX_FOO" + (if current + (string-append "/some/path:/some/other/path" + ":" current) + "/some/path:/some/other/path")))) + `(let ((cl (command-line))) + (apply execl "/anything/cabbage-bash-1.2.3/bin/python3" + (car cl) + (cons (car cl) + (append '("" "-and" "-args") cl))))) + script-contents) + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port script-contents))) + (chmod script-file-name #o777) + + (wrap-script script-file-name + #:guile "MYGUILE" + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path"))) + (let ((str (call-with-input-file script-file-name get-string-all))) + (with-directory-excursion directory + (delete-file "foo")) + str)))))) + +(test-assert "wrap-script, raises condition" + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port "This is not a script"))) + (chmod script-file-name #o777) + (guard (c ((wrap-error? c) #t)) + (wrap-script script-file-name + #:guile "MYGUILE" + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path"))) + #f))))) + +(test-end)