;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès ;;; Copyright © 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (test-build-utils) #:use-module (guix tests) #:use-module (guix build utils) #:use-module ((guix utils) #:select (%current-system call-with-temporary-directory)) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-mod
aboutsummaryrefslogtreecommitdiff
e 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)) (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) (display script-contents port))) (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)