;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot>
;;;
;;; This file is part of GNU Guix.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
-(define-module (test-build-utils)
+(define-module (test build-utils)
#:use-module (guix tests)
#:use-module (guix build utils)
#:use-module ((guix utils)
#: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))
;; 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")))
- (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) (append (quote ()) 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)
+ (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)))))
+
+(define (arg-test bash-args)
+ (call-with-temporary-directory
+ (lambda (directory)
+ (let ((script-file-name (string-append directory "/bash-test.sh")))
+ (call-with-output-file script-file-name
+ (lambda (port)
+ (display (string-append "\
+#!" (which "bash") bash-args "
+echo \"$#$0$*${A}\"")
+ port)))
+
+ (display "Unwrapped script contents:\n")
+ (call-with-input-file script-file-name
+ (lambda (port) (display (get-string-all port))))
+ (newline) (newline)
+ (chmod script-file-name #o777)
+ (setenv "A" "A")
+ (let* ((run-script (lambda _
+ (open-pipe*
+ OPEN_READ
+ script-file-name "1" "2" "3 3" "4")))
+ (pipe (run-script))
+ (unwrapped-output (get-string-all pipe)))
+ (close-pipe pipe)
+
+ (wrap-script script-file-name `("A" = ("A\nA")))
+
+ (display "Wrapped script contents:\n")
+ (call-with-input-file script-file-name
+ (lambda (port) (display (get-string-all port))))
+ (newline) (newline)
+
+ (let* ((pipe (run-script))
+ (wrapped-output (get-string-all pipe)))
+ (close-pipe pipe)
+ (display "./bash-test.sh 1 2 3\\ 3 4 # Output:\n")
+ (display unwrapped-output) (newline)
+ (display "./bash-test.sh 1 2 3\\ 3 4 # Output (wrapped):\n")
+ (display wrapped-output) (newline)
+ (string=? (string-append unwrapped-output "A\n")
+ wrapped-output)))))))
+
+(test-assert "wrap-script, argument handling"
+ (arg-test ""))
+
+(test-assert "wrap-script, argument handling, bash --norc"
+ (arg-test " --norc"))
+
+(test-equal "substitute*, text contains a NUL byte, UTF-8"
+ "c\0d"
+ (with-fluids ((%default-port-encoding "UTF-8")
+ (%default-port-conversion-strategy 'error))
+ ;; The GNU libc is locale sensitive. Depending on the value of LANG, the
+ ;; test could fail with "string contains #\\nul character: ~S" or "cannot
+ ;; convert wide string to output locale".
+ (setlocale LC_ALL "en_US.UTF-8")
+ (call-with-temporary-output-file
+ (lambda (file port)
+ (format port "a\0b")
+ (flush-output-port port)
+
+ (substitute* file
+ (("a") "c")
+ (("b") "d"))
+
+ (with-input-from-file file
+ (lambda _
+ (get-string-all (current-input-port))))))))
+
+(test-equal "search-input-file: exception if not found"
+ `((path)
+ (file . "does-not-exist"))
+ (guard (e ((search-error? e)
+ `((path . ,(search-error-path e))
+ (file . ,(search-error-file e)))))
+ (search-input-file '() "does-not-exist")))
+
+(test-equal "search-input-file: can find if existent"
+ (which "guile")
+ (search-input-file
+ `(("guile/bin" . ,(dirname (which "guile"))))
+ "guile"))
+
+(test-equal "search-input-file: can search in multiple directories"
+ (which "guile")
+ (call-with-temporary-directory
+ (lambda (directory)
+ (search-input-file
+ `(("irrelevant" . ,directory)
+ ("guile/bin" . ,(dirname (which "guile"))))
+ "guile"))))
(test-end)