;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2015 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.
;;;
(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)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-64)
#:use-module (rnrs io ports)
#:use-module (ice-9 popen))
-(define %store
- (open-connection-for-tests))
-
\f
(test-begin "build-utils")
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))
+(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.
+ (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)))
- (equal? str "hello world\n")))))
+ (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)
-
-\f
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
HCoop / jackhill / guix / guix.git / blobdiff