tests/build-utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2015, 2016, 2019 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 ((gnu build bootloader)
  25                 #:select (invoke/quiet))
  26   #:use-module ((guix utils)
  27                 #:select (%current-system call-with-temporary-directory))
  28   #:use-module (gnu packages)
  29   #:use-module (gnu packages bootstrap)
  30   #:use-module (srfi srfi-34)
  31   #:use-module (srfi srfi-35)
  32   #:use-module (srfi srfi-64)
  33   #:use-module (rnrs io ports)
  34   #:use-module (ice-9 popen))
  35
  36 \f
  37 (test-begin "build-utils")
  38
  39 (test-equal "alist-cons-before"
  40   '((a . 1) (x . 42) (b . 2) (c . 3))
  41   (alist-cons-before 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
  42
  43 (test-equal "alist-cons-before, reference not found"
  44   '((a . 1) (b . 2) (c . 3) (x . 42))
  45   (alist-cons-before 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
  46
  47 (test-equal "alist-cons-after"
  48   '((a . 1) (b . 2) (x . 42) (c . 3))
  49   (alist-cons-after 'b 'x 42 '((a . 1) (b . 2) (c . 3))))
  50
  51 (test-equal "alist-cons-after, reference not found"
  52   '((a . 1) (b . 2) (c . 3) (x . 42))
  53   (alist-cons-after 'z 'x 42 '((a . 1) (b . 2) (c . 3))))
  54
  55 (test-equal "alist-replace"
  56   '((a . 1) (b . 77) (c . 3))
  57   (alist-replace 'b 77 '((a . 1) (b . 2) (c . 3))))
  58
  59 (test-assert "alist-replace, key not found"
  60   (not (false-if-exception
  61         (alist-replace 'z 77 '((a . 1) (b . 2) (c . 3))))))
  62
  63 (test-equal "fold-port-matches"
  64   (make-list 3 "Guix")
  65   (call-with-input-string "Guix is cool, Guix rocks, and it uses Guile, Guix!"
  66     (lambda (port)
  67       (fold-port-matches cons '() "Guix" port))))
  68
  69 (test-equal "fold-port-matches, trickier"
  70   (reverse '("Guix" "guix" "Guix" "guiX" "Guix"))
  71   (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
  72     (lambda (port)
  73       (fold-port-matches cons '()
  74                          (list (char-set #\G #\g)
  75                                (char-set #\u)
  76                                (char-set #\i)
  77                                (char-set #\x #\X))
  78                          port))))
  79
  80 (test-equal "fold-port-matches, with unmatched chars"
  81   '("Guix" #\, #\space
  82     "guix" #\, #\space
  83     #\G #\u #\i "Guix" "guiX" #\, #\space
  84     "Guix")
  85   (call-with-input-string "Guix, guix, GuiGuixguiX, Guix"
  86     (lambda (port)
  87       (reverse
  88        (fold-port-matches cons '()
  89                           (list (char-set #\G #\g)
  90                                 (char-set #\u)
  91                                 (char-set #\i)
  92                                 (char-set #\x #\X))
  93                           port
  94                           cons)))))
  95
  96 (test-equal "wrap-program, one input, multiple calls"
  97   "hello world\n"
  98   (call-with-temporary-directory
  99    (lambda (directory)
 100      (let ((bash (search-bootstrap-binary "bash" (%current-system)))
 101            (foo  (string-append directory "/foo")))
 102
 103        (call-with-output-file foo
 104          (lambda (p)
 105            (format p
 106                    "#!~a~%echo \"${GUIX_FOO} ${GUIX_BAR}\"~%"
 107                    bash)))
 108        (chmod foo #o777)
 109
 110        ;; wrap-program uses `which' to find bash for the wrapper shebang, but
 111        ;; it can't know about the bootstrap bash in the store, since it's not
 112        ;; named "bash".  Help it out a bit by providing a symlink it this
 113        ;; package's output.
 114        (with-environment-variable "PATH" (dirname bash)
 115          (wrap-program foo `("GUIX_FOO" prefix ("hello")))
 116          (wrap-program foo `("GUIX_BAR" prefix ("world")))
 117
 118          ;; The bootstrap Bash is linked against an old libc and would abort
 119          ;; with an assertion failure when trying to load incompatible locale
 120          ;; data.
 121          (unsetenv "LOCPATH")
 122
 123          (let* ((pipe (open-input-pipe foo))
 124                 (str  (get-string-all pipe)))
 125            (with-directory-excursion directory
 126              (for-each delete-file '("foo" ".foo-real")))
 127            (and (zero? (close-pipe pipe))
 128                 str)))))))
 129
 130 (test-assert "invoke/quiet, success"
 131   (begin
 132     (invoke/quiet "true")
 133     #t))
 134
 135 (test-assert "invoke/quiet, failure"
 136   (guard (c ((message-condition? c)
 137              (string-contains (condition-message c) "This is an error.")))
 138     (invoke/quiet "sh" "-c" "echo This is an error. ; false")
 139     #f))
 140
 141 (test-assert "invoke/quiet, failure, message on stderr"
 142   (guard (c ((message-condition? c)
 143              (string-contains (condition-message c)
 144                               "This is another error.")))
 145     (invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false")
 146     #f))
 147
 148 (let ((script-contents "\
 149 #!/anything/cabbage-bash-1.2.3/bin/sh
 150
 151 echo hello world"))
 152
 153   (test-equal "wrap-script, simple case"
 154     (string-append
 155      (format #f "\
 156 #!GUILE --no-auto-compile
 157 #!#; Guix wrapper
 158 #\\-~s
 159 #\\-~s
 160 "
 161              '(begin (let ((current (getenv "GUIX_FOO")))
 162                        (setenv "GUIX_FOO"
 163                                (if current
 164                                    (string-append "/some/path:/some/other/path"
 165                                                   ":" current)
 166                                    "/some/path:/some/other/path"))))
 167              '(let ((cl (command-line)))
 168                 (apply execl "/anything/cabbage-bash-1.2.3/bin/sh"
 169                        (car cl)
 170                        (cons (car cl)
 171                              (append '("") cl)))))
 172      script-contents)
 173     (call-with-temporary-directory
 174      (lambda (directory)
 175        (let ((script-file-name (string-append directory "/foo")))
 176          (call-with-output-file script-file-name
 177            (lambda (port)
 178              (format port script-contents)))
 179          (chmod script-file-name #o777)
 180
 181          (mock ((guix build utils) which (const "GUILE"))
 182                (wrap-script script-file-name
 183                             `("GUIX_FOO" prefix ("/some/path"
 184                                                  "/some/other/path"))))
 185          (let ((str (call-with-input-file script-file-name get-string-all)))
 186            (with-directory-excursion directory
 187              (delete-file "foo"))
 188            str))))))
 189
 190 (let ((script-contents "\
 191 #!/anything/cabbage-bash-1.2.3/bin/python3 -and -args
 192 # vim:fileencoding=utf-8
 193 print('hello world')"))
 194
 195   (test-equal "wrap-script, with encoding declaration"
 196     (string-append
 197      (format #f "\
 198 #!MYGUILE --no-auto-compile
 199 #!#; # vim:fileencoding=utf-8
 200 #\\-~s
 201 #\\-~s
 202 "
 203              '(begin (let ((current (getenv "GUIX_FOO")))
 204                        (setenv "GUIX_FOO"
 205                                (if current
 206                                    (string-append "/some/path:/some/other/path"
 207                                                   ":" current)
 208                                    "/some/path:/some/other/path"))))
 209              `(let ((cl (command-line)))
 210                 (apply execl "/anything/cabbage-bash-1.2.3/bin/python3"
 211                        (car cl)
 212                        (cons (car cl)
 213                              (append '("" "-and" "-args") cl)))))
 214      script-contents)
 215     (call-with-temporary-directory
 216      (lambda (directory)
 217        (let ((script-file-name (string-append directory "/foo")))
 218          (call-with-output-file script-file-name
 219            (lambda (port)
 220              (format port script-contents)))
 221          (chmod script-file-name #o777)
 222
 223          (wrap-script script-file-name
 224                       #:guile "MYGUILE"
 225                       `("GUIX_FOO" prefix ("/some/path"
 226                                            "/some/other/path")))
 227          (let ((str (call-with-input-file script-file-name get-string-all)))
 228            (with-directory-excursion directory
 229              (delete-file "foo"))
 230            str))))))
 231
 232 (test-assert "wrap-script, raises condition"
 233   (call-with-temporary-directory
 234    (lambda (directory)
 235      (let ((script-file-name (string-append directory "/foo")))
 236        (call-with-output-file script-file-name
 237          (lambda (port)
 238            (format port "This is not a script")))
 239        (chmod script-file-name #o777)
 240        (catch 'srfi-34
 241          (lambda ()
 242            (wrap-script script-file-name
 243                         #:guile "MYGUILE"
 244                         `("GUIX_FOO" prefix ("/some/path"
 245                                              "/some/other/path"))))
 246          (lambda (type obj)
 247            (wrap-error? obj)))))))
 248
 249 (test-end)