| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2012, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; |
| 4 | ;;; This file is part of GNU Guix. |
| 5 | ;;; |
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 7 | ;;; under the terms of the GNU General Public License as published by |
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 9 | ;;; your option) any later version. |
| 10 | ;;; |
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 14 | ;;; GNU General Public License for more details. |
| 15 | ;;; |
| 16 | ;;; You should have received a copy of the GNU General Public License |
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 18 | |
| 19 | |
| 20 | (define-module (test-build-utils) |
| 21 | #:use-module (guix tests) |
| 22 | #:use-module (guix build utils) |
| 23 | #:use-module ((gnu build bootloader) |
| 24 | #:select (invoke/quiet)) |
| 25 | #:use-module ((guix utils) |
| 26 | #:select (%current-system call-with-temporary-directory)) |
| 27 | #:use-module (gnu packages) |
| 28 | #:use-module (gnu packages bootstrap) |
| 29 | #:use-module (srfi srfi-34) |
| 30 | #:use-module (srfi srfi-35) |
| 31 | #:use-module (srfi srfi-64) |
| 32 | #:use-module (rnrs io ports) |
| 33 | #:use-module (ice-9 popen)) |
| 34 | |
| 35 | \f |
| 36 | (test-begin "build-utils") |
| 37 | |
| 38 | (test-equal "alist-cons-before" |
| 39 | '((a . 1) (x . 42) (b . 2) (c . 3)) |
| 40 | (alist-cons-before 'b 'x 42 '((a . 1) (b . 2) (c . 3)))) |
| 41 | |
| 42 | (test-equal "alist-cons-before, reference not found" |
| 43 | '((a . 1) (b . 2) (c . 3) (x . 42)) |
| 44 | (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3)))) |
| 45 | |
| 46 | (test-equal "alist-cons-after" |
| 47 | '((a . 1) (b . 2) (x . 42) (c . 3)) |
| 48 | (alist-cons-after 'b 'x 42 '((a . 1) (b . 2) (c . 3)))) |
| 49 | |
| 50 | (test-equal "alist-cons-after, reference not found" |
| 51 | '((a . 1) (b . 2) (c . 3) (x . 42)) |
| 52 | (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3)))) |
| 53 | |
| 54 | (test-equal "alist-replace" |
| 55 | '((a . 1) (b . 77) (c . 3)) |
| 56 | (alist-replace 'b 77 '((a . 1) (b . 2) (c . 3)))) |
| 57 | |
| 58 | (test-assert "alist-replace, key not found" |
| 59 | (not (false-if-exception |
| 60 | (alist-replace 'z 77 '((a . 1) (b . 2) (c . 3)))))) |
| 61 | |
| 62 | (test-equal "fold-port-matches" |
| 63 | (make-list 3 "Guix") |
| 64 | (call-with-input-string "Guix is cool, Guix rocks, and it uses Guile, Guix!" |
| 65 | (lambda (port) |
| 66 | (fold-port-matches cons '() "Guix" port)))) |
| 67 | |
| 68 | (test-equal "fold-port-matches, trickier" |
| 69 | (reverse '("Guix" "guix" "Guix" "guiX" "Guix")) |
| 70 | (call-with-input-string "Guix, guix, GuiGuixguiX, Guix" |
| 71 | (lambda (port) |
| 72 | (fold-port-matches cons '() |
| 73 | (list (char-set #\G #\g) |
| 74 | (char-set #\u) |
| 75 | (char-set #\i) |
| 76 | (char-set #\x #\X)) |
| 77 | port)))) |
| 78 | |
| 79 | (test-equal "fold-port-matches, with unmatched chars" |
| 80 | '("Guix" #\, #\space |
| 81 | "guix" #\, #\space |
| 82 | #\G #\u #\i "Guix" "guiX" #\, #\space |
| 83 | "Guix") |
| 84 | (call-with-input-string "Guix, guix, GuiGuixguiX, Guix" |
| 85 | (lambda (port) |
| 86 | (reverse |
| 87 | (fold-port-matches cons '() |
| 88 | (list (char-set #\G #\g) |
| 89 | (char-set #\u) |
| 90 | (char-set #\i) |
| 91 | (char-set #\x #\X)) |
| 92 | port |
| 93 | cons))))) |
| 94 | |
| 95 | (test-equal "wrap-program, one input, multiple calls" |
| 96 | "hello world\n" |
| 97 | (call-with-temporary-directory |
| 98 | (lambda (directory) |
| 99 | (let ((bash (search-bootstrap-binary "bash" (%current-system))) |
| 100 | (foo (string-append directory "/foo"))) |
| 101 | |
| 102 | (call-with-output-file foo |
| 103 | (lambda (p) |
| 104 | (format p |
| 105 | "#!~a~%echo \"${GUIX_FOO} ${GUIX_BAR}\"~%" |
| 106 | bash))) |
| 107 | (chmod foo #o777) |
| 108 | |
| 109 | ;; wrap-program uses `which' to find bash for the wrapper shebang, but |
| 110 | ;; it can't know about the bootstrap bash in the store, since it's not |
| 111 | ;; named "bash". Help it out a bit by providing a symlink it this |
| 112 | ;; package's output. |
| 113 | (with-environment-variable "PATH" (dirname bash) |
| 114 | (wrap-program foo `("GUIX_FOO" prefix ("hello"))) |
| 115 | (wrap-program foo `("GUIX_BAR" prefix ("world"))) |
| 116 | |
| 117 | ;; The bootstrap Bash is linked against an old libc and would abort |
| 118 | ;; with an assertion failure when trying to load incompatible locale |
| 119 | ;; data. |
| 120 | (unsetenv "LOCPATH") |
| 121 | |
| 122 | (let* ((pipe (open-input-pipe foo)) |
| 123 | (str (get-string-all pipe))) |
| 124 | (with-directory-excursion directory |
| 125 | (for-each delete-file '("foo" ".foo-real"))) |
| 126 | (and (zero? (close-pipe pipe)) |
| 127 | str))))))) |
| 128 | |
| 129 | (test-assert "invoke/quiet, success" |
| 130 | (begin |
| 131 | (invoke/quiet "true") |
| 132 | #t)) |
| 133 | |
| 134 | (test-assert "invoke/quiet, failure" |
| 135 | (guard (c ((message-condition? c) |
| 136 | (string-contains (condition-message c) "This is an error."))) |
| 137 | (invoke/quiet "sh" "-c" "echo This is an error. ; false") |
| 138 | #f)) |
| 139 | |
| 140 | (test-assert "invoke/quiet, failure, message on stderr" |
| 141 | (guard (c ((message-condition? c) |
| 142 | (string-contains (condition-message c) |
| 143 | "This is another error."))) |
| 144 | (invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false") |
| 145 | #f)) |
| 146 | |
| 147 | (test-end) |