X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/075be8dbe0c40ae2f285da8d2035683937e1377d..3159fcf14519f02c79ad84b441985982cb1efeb9:/tests/build-utils.scm

diff --git a/tests/build-utils.scm b/tests/build-utils.scm
index cc59b2eff7..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, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,6 +26,7 @@
   #: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))
@@ -107,20 +109,136 @@
        ;; 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))))))
+       (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))
+
+(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)