tests/build-utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20
  21 (define-module (test-build-utils)
  22   #:use-module (guix tests)
  23   #:use-module (guix build utils)
  24   #:use-module ((guix utils)
  25                 #:select (%current-system call-with-temporary-directory))
  26   #:use-module (gnu packages)
  27   #:use-module (gnu packages bootstrap)
  28   #:use-module (srfi srfi-34)
  29   #:use-module (srfi srfi-64)
  30   #:use-module (rnrs io ports)
  31   #:use-module (ice-9 popen))
  32
  33 \f
  34 (test-begin "build-utils")
  35
  36 (test-equal "alist-cons-before"
  37   '((a . 1) (x . 42) (b . 2) (c . 3))
  38   (alist-cons-before 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
  39
  40 (test-equal "alist-cons-before, reference not found"
  41   '((a . 1) (b . 2) (c . 3) (x . 42))
  42   (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
  43
  44 (test-equal "alist-cons-after"
  45   '((a . 1) (b . 2) (x . 42) (c . 3))
  46   (alist-cons-after 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
  47
  48 (test-equal "alist-cons-after, reference not found"
  49   '((a . 1) (b . 2) (c . 3) (x . 42))
  50   (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
  51
  52 (test-equal "alist-replace"
  53   '((a . 1) (b . 77) (c . 3))
  54   (alist-replace 'b 77 '((a . 1) (b . 2) (c . 3))))
  55
  56 (test-assert "alist-replace, key not found"
  57   (not (false-if-exception
  58         (alist-replace 'z 77 '((a . 1) (b . 2) (c . 3))))))
  59
  60 (test-equal "fold-port-matches"
  61   (make-list 3 "Guix")
  62   (call-with-input-string "Guix is cool, Guix rocks, and it uses Guile, Guix!"
  63     (lambda (port)
  64       (fold-port-matches cons '() "Guix" port))))
  65
  66 (test-equal "fold-port-matches, trickier"
  67   (reverse '("Guix" "guix" "Guix" "guiX" "Guix"))
  68   (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
  69     (lambda (port)
  70       (fold-port-matches cons '()
  71                          (list (char-set #\G #\g)
  72                                (char-set #\u)
  73                                (char-set #\i)
  74                                (char-set #\x #\X))
  75                          port))))
  76
  77 (test-equal "fold-port-matches, with unmatched chars"
  78   '("Guix" #\, #\space
  79     "guix" #\, #\space
  80     #\G #\u #\i "Guix" "guiX" #\, #\space
  81     "Guix")
  82   (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
  83     (lambda (port)
  84       (reverse
  85        (fold-port-matches cons '()
  86                           (list (char-set #\G #\g)
  87                                 (char-set #\u)
  88                                 (char-set #\i)
  89                                 (char-set #\x #\X))
  90                           port
  91                           cons)))))
  92
  93 (test-equal "wrap-program, one input, multiple calls"
  94   "hello world\n"
  95   (call-with-temporary-directory
  96    (lambda (directory)
  97      (let ((bash (search-bootstrap-binary "bash" (%current-system)))
  98            (foo  (string-append directory "/foo")))
  99
 100        (call-with-output-file foo
 101          (lambda (p)
 102            (format p
 103                    "#!~a~%echo \"${GUIX_FOO} ${GUIX_BAR}\"~%"
 104                    bash)))
 105        (chmod foo #o777)
 106
 107        ;; wrap-program uses `which' to find bash for the wrapper shebang, but
 108        ;; it can't know about the bootstrap bash in the store, since it's not
 109        ;; named "bash".  Help it out a bit by providing a symlink it this
 110        ;; package's output.
 111        (setenv "PATH" (dirname bash))
 112        (wrap-program foo `("GUIX_FOO" prefix ("hello")))
 113        (wrap-program foo `("GUIX_BAR" prefix ("world")))
 114
 115        ;; The bootstrap Bash is linked against an old libc and would abort with
 116        ;; an assertion failure when trying to load incompatible locale data.
 117        (unsetenv "LOCPATH")
 118
 119        (let* ((pipe (open-input-pipe foo))
 120               (str  (get-string-all pipe)))
 121          (with-directory-excursion directory
 122            (for-each delete-file '("foo" ".foo-real")))
 123          (and (zero? (close-pipe pipe))
 124               str))))))
 125
 126 (let ((script-contents "\
 127 #!/anything/cabbage-bash-1.2.3/bin/sh
 128
 129 echo hello world"))
 130
 131   (test-equal "wrap-script, simple case"
 132     (string-append
 133      (format #f "\
 134 #!GUILE --no-auto-compile
 135 #!#; Guix wrapper
 136 #\\-~s
 137 #\\-~s
 138 "
 139              '(begin (let ((current (getenv "GUIX_FOO")))
 140                        (setenv "GUIX_FOO"
 141                                (if current
 142                                    (string-append "/some/path:/some/other/path"
 143                                                   ":" current)
 144                                    "/some/path:/some/other/path"))))
 145              '(let ((cl (command-line)))
 146                 (apply execl "/anything/cabbage-bash-1.2.3/bin/sh"
 147                        (car cl)
 148                        (cons (car cl)
 149                              (append '("") cl)))))
 150      script-contents)
 151     (call-with-temporary-directory
 152      (lambda (directory)
 153        (let ((script-file-name (string-append directory "/foo")))
 154          (call-with-output-file script-file-name
 155            (lambda (port)
 156              (format port script-contents)))
 157          (chmod script-file-name #o777)
 158
 159          (mock ((guix build utils) which (const "GUILE"))
 160                (wrap-script script-file-name
 161                             `("GUIX_FOO" prefix ("/some/path"
 162                                                  "/some/other/path"))))
 163          (let ((str (call-with-input-file script-file-name get-string-all)))
 164            (with-directory-excursion directory
 165              (delete-file "foo"))
 166            str))))))
 167
 168 (let ((script-contents "\
 169 #!/anything/cabbage-bash-1.2.3/bin/python3 -and -args
 170 # vim:fileencoding=utf-8
 171 print('hello world')"))
 172
 173   (test-equal "wrap-script, with encoding declaration"
 174     (string-append
 175      (format #f "\
 176 #!MYGUILE --no-auto-compile
 177 #!#; # vim:fileencoding=utf-8
 178 #\\-~s
 179 #\\-~s
 180 "
 181              '(begin (let ((current (getenv "GUIX_FOO")))
 182                        (setenv "GUIX_FOO"
 183                                (if current
 184                                    (string-append "/some/path:/some/other/path"
 185                                                   ":" current)
 186                                    "/some/path:/some/other/path"))))
 187              `(let ((cl (command-line)))
 188                 (apply execl "/anything/cabbage-bash-1.2.3/bin/python3"
 189                        (car cl)
 190                        (cons (car cl)
 191                              (append '("" "-and" "-args") cl)))))
 192      script-contents)
 193     (call-with-temporary-directory
 194      (lambda (directory)
 195        (let ((script-file-name (string-append directory "/foo")))
 196          (call-with-output-file script-file-name
 197            (lambda (port)
 198              (format port script-contents)))
 199          (chmod script-file-name #o777)
 200
 201          (wrap-script script-file-name
 202                       #:guile "MYGUILE"
 203                       `("GUIX_FOO" prefix ("/some/path"
 204                                            "/some/other/path")))
 205          (let ((str (call-with-input-file script-file-name get-string-all)))
 206            (with-directory-excursion directory
 207              (delete-file "foo"))
 208            str))))))
 209
 210 (test-assert "wrap-script, raises condition"
 211   (call-with-temporary-directory
 212    (lambda (directory)
 213      (let ((script-file-name (string-append directory "/foo")))
 214        (call-with-output-file script-file-name
 215          (lambda (port)
 216            (format port "This is not a script")))
 217        (chmod script-file-name #o777)
 218        (catch 'srfi-34
 219          (lambda ()
 220            (wrap-script script-file-name
 221                         #:guile "MYGUILE"
 222                         `("GUIX_FOO" prefix ("/some/path"
 223                                              "/some/other/path"))))
 224          (lambda (type obj)
 225            (wrap-error? obj)))))))
 226
 227 (test-end)