tests/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   4 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
   5 ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
   6 ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (test-utils)
  24   #:use-module ((guix config) #:select (%gzip))
  25   #:use-module (guix utils)
  26   #:use-module ((guix store) #:select (%store-prefix store-path-package-name))
  27   #:use-module ((guix search-paths) #:select (string-tokenize*))
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-11)
  30   #:use-module (srfi srfi-64)
  31   #:use-module (rnrs bytevectors)
  32   #:use-module (rnrs io ports)
  33   #:use-module (ice-9 match)
  34   #:use-module (ice-9 vlist))
  35
  36 (define temp-file
  37   (string-append "t-utils-" (number->string (getpid))))
  38
  39 (test-begin "utils")
  40
  41 (test-assert "gnu-triplet->nix-system"
  42   (let ((samples '(("i586-gnu0.3" "i686-gnu")
  43                    ("x86_64-unknown-linux-gnu" "x86_64-linux")
  44                    ("i386-pc-linux-gnu" "i686-linux")
  45                    ("x86_64-unknown-freebsd8.2" "x86_64-freebsd")
  46                    ("x86_64-apple-darwin10.8.0" "x86_64-darwin")
  47                    ("i686-pc-cygwin" "i686-cygwin"))))
  48     (let-values (((gnu nix) (unzip2 samples)))
  49       (every (lambda (gnu nix)
  50                (equal? nix (gnu-triplet->nix-system gnu)))
  51              gnu nix))))
  52
  53 (test-assert "package-name->name+version"
  54   (every (match-lambda
  55           ((name version)
  56            (let*-values (((full-name)
  57                           (if version
  58                               (string-append name "@" version)
  59                               name))
  60                          ((name* version*)
  61                           (package-name->name+version full-name)))
  62              (and (equal? name* name)
  63                   (equal? version* version)))))
  64          '(("foo" "0.9.1b")
  65            ("foo-14-bar" "320")
  66            ("foo-bar2" #f)
  67            ("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen'
  68            ("nixpkgs" "1.0pre22125_a28fe19")
  69            ("gtk2" "2.38.0"))))
  70
  71 (test-assert "guile-version>? 1.8"
  72   (guile-version>? "1.8"))
  73
  74 (test-assert "guile-version>? 10.5"
  75   (not (guile-version>? "10.5")))
  76
  77 (test-assert "version-prefix?"
  78   (and (version-prefix? "4.1" "4.1.2")
  79        (version-prefix? "4.1" "4.1")
  80        (not (version-prefix? "4.1" "4.16.2"))
  81        (not (version-prefix? "4.1" "4"))))
  82
  83 (test-equal "version-unique-prefix"
  84   '("2" "2.2" "")
  85   (list (version-unique-prefix "2.0" '("3.0" "2.0"))
  86         (version-unique-prefix "2.2" '("3.0.5" "2.0.9" "2.2.7"))
  87         (version-unique-prefix "27.1" '("27.1"))))
  88
  89 (test-equal "string-tokenize*"
  90   '(("foo")
  91     ("foo" "bar" "baz")
  92     ("foo" "bar" "")
  93     ("foo" "bar" "baz"))
  94   (list (string-tokenize* "foo" ":")
  95         (string-tokenize* "foo;bar;baz" ";")
  96         (string-tokenize* "foo!bar!" "!")
  97         (string-tokenize* "foo+-+bar+-+baz" "+-+")))
  98
  99 (test-equal "string-replace-substring"
 100   '("foo BAR! baz"
 101     "/gnu/store/chbouib"
 102     "")
 103   (list (string-replace-substring "foo bar baz" "bar" "BAR!")
 104         (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/")
 105         (string-replace-substring "" "foo" "bar")))
 106
 107 (test-equal "strip-keyword-arguments"
 108   '(a #:b b #:c c)
 109   (strip-keyword-arguments '(#:foo #:bar #:baz)
 110                            '(a #:foo 42 #:b b #:baz 3
 111                                #:c c #:bar 4)))
 112
 113 (test-equal "ensure-keyword-arguments"
 114   '((#:foo 2)
 115     (#:foo 2 #:bar 3)
 116     (#:foo 42 #:bar 3))
 117   (list (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
 118         (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
 119         (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))
 120
 121 (test-equal "default-keyword-arguments"
 122   '((#:foo 2)
 123     (#:foo 2)
 124     (#:foo 2 #:bar 3)
 125     (#:foo 2 #:bar 3)
 126     (#:foo 2 #:bar 3))
 127   (list (default-keyword-arguments '() '(#:foo 2))
 128         (default-keyword-arguments '(#:foo 2) '(#:foo 4))
 129         (default-keyword-arguments '() '(#:bar 3 #:foo 2))
 130         (default-keyword-arguments '(#:bar 3) '(#:foo 2))
 131         (default-keyword-arguments '(#:foo 2 #:bar 3) '(#:bar 6))))
 132
 133 (test-equal "substitute-keyword-arguments"
 134   '((#:foo 3)
 135     (#:foo 3)
 136     (#:foo 3 #:bar (1 2))
 137     (#:bar (1 2) #:foo 3)
 138     (#:foo 3))
 139   (list (substitute-keyword-arguments '(#:foo 2)
 140           ((#:foo f) (1+ f)))
 141         (substitute-keyword-arguments '()
 142           ((#:foo f 2) (1+ f)))
 143         (substitute-keyword-arguments '(#:foo 2 #:bar (2))
 144           ((#:foo f) (1+ f))
 145           ((#:bar b) (cons 1 b)))
 146         (substitute-keyword-arguments '(#:foo 2)
 147           ((#:foo _) 3)
 148           ((#:bar b '(2)) (cons 1 b)))
 149         (substitute-keyword-arguments '(#:foo 2)
 150           ((#:foo f 1) (1+ f))
 151           ((#:bar b) (cons 42 b)))))
 152
 153 (test-assert "filtered-port, file"
 154   (let* ((file  (search-path %load-path "guix.scm"))
 155          (input (open-file file "r0b")))
 156     (let*-values (((compressed pids1)
 157                    (filtered-port `(,%gzip "-c" "--fast") input))
 158                   ((decompressed pids2)
 159                    (filtered-port `(,%gzip "-d") compressed)))
 160       (and (every (compose zero? cdr waitpid)
 161                   (append pids1 pids2))
 162            (equal? (get-bytevector-all decompressed)
 163                    (call-with-input-file file get-bytevector-all))))))
 164
 165 (test-assert "filtered-port, non-file"
 166   (let ((data (call-with-input-file (search-path %load-path "guix.scm")
 167                 get-bytevector-all)))
 168     (let*-values (((compressed pids1)
 169                    (filtered-port `(,%gzip "-c" "--fast")
 170                                   (open-bytevector-input-port data)))
 171                   ((decompressed pids2)
 172                    (filtered-port `(,%gzip "-d") compressed)))
 173       (and (pk (every (compose zero? cdr waitpid)
 174                    (append pids1 pids2)))
 175            (equal? (get-bytevector-all decompressed) data)))))
 176
 177 (test-assert "filtered-port, does not exist"
 178   (let* ((file  (search-path %load-path "guix.scm"))
 179          (input (open-file file "r0b")))
 180     (let-values (((port pids)
 181                   (filtered-port '("/does/not/exist") input)))
 182       (any (compose (negate zero?) cdr waitpid)
 183            pids))))
 184
 185 (define (test-compression/decompression method run?)
 186   "Test METHOD, a symbol such as 'gzip.  Call RUN? to determine whether to
 187 skip these tests."
 188   (unless (run?) (test-skip 1))
 189   (test-assert (format #f "compressed-port, decompressed-port, non-file [~a]"
 190                        method)
 191     (let ((data (call-with-input-file (search-path %load-path "guix.scm")
 192                   get-bytevector-all)))
 193       (call-with-temporary-output-file
 194        (lambda (output port)
 195          (close-port port)
 196          (let*-values (((compressed pids)
 197                         ;; Note: 'compressed-output-port' only supports file
 198                         ;; ports.
 199                         (compressed-output-port method
 200                                                 (open-file output "w0"))))
 201            (put-bytevector compressed data)
 202            (close-port compressed)
 203            (and (every (compose zero? cdr waitpid)
 204                        (pk 'pids method pids))
 205                 (let*-values (((decompressed pids)
 206                                (decompressed-port method
 207                                                   (open-bytevector-input-port
 208                                                    (call-with-input-file output
 209                                                      get-bytevector-all))))
 210                               ((result)
 211                                (get-bytevector-all decompressed)))
 212                   (close-port decompressed)
 213                   (pk 'len method
 214                       (if (bytevector? result)
 215                           (bytevector-length result)
 216                           result)
 217                       (bytevector-length data))
 218                   (and (every (compose zero? cdr waitpid)
 219                               (pk 'pids method pids))
 220                        (equal? result data)))))))))
 221
 222   (false-if-exception (delete-file temp-file))
 223   (unless (run?) (test-skip 1))
 224   (test-assert (format #f "compressed-output-port + decompressed-port [~a]"
 225                        method)
 226     (let* ((file (search-path %load-path "guix/derivations.scm"))
 227            (data (call-with-input-file file get-bytevector-all))
 228            (port (open-file temp-file "w0b")))
 229       (call-with-compressed-output-port method port
 230         (lambda (compressed)
 231           (put-bytevector compressed data)))
 232       (close-port port)
 233
 234       (bytevector=? data
 235                     (call-with-decompressed-port method (open-file temp-file "r0b")
 236                       get-bytevector-all)))))
 237
 238 (for-each test-compression/decompression
 239           `(gzip xz lzip zstd)
 240           (list (const #t) (const #t) (const #t)
 241                 (lambda ()
 242                   (resolve-module '(zstd) #t #f #:ensure #f))))
 243
 244 ;; This is actually in (guix store).
 245 (test-equal "store-path-package-name"
 246   "bash-4.2-p24"
 247   (store-path-package-name
 248    (string-append (%store-prefix)
 249                   "/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24")))
 250
 251 (test-equal "canonical-newline-port"
 252   "This is a journey\nInto the sound\nA journey ...\n"
 253   (let ((port (open-string-input-port
 254                "This is a journey\r\nInto the sound\r\nA journey ...\n")))
 255     (get-string-all (canonical-newline-port port))))
 256
 257 (test-equal "canonical-newline-port-1024"
 258   (string-concatenate (make-list 100 "0123456789abcde\n"))
 259   (let ((port (open-string-input-port
 260                (string-concatenate
 261                 (make-list 100 "0123456789abcde\r\n")))))
 262     (get-string-all (canonical-newline-port port))))
 263
 264 (test-equal "edit-expression"
 265   "(display \"GNU Guix\")\n(newline)\n"
 266   (begin
 267     (call-with-output-file temp-file
 268       (lambda (port)
 269         (display "(display \"xiuG UNG\")\n(newline)\n" port)))
 270     (edit-expression `((filename . ,temp-file)
 271                        (line     . 0)
 272                        (column   . 9))
 273                      string-reverse)
 274     (call-with-input-file temp-file get-string-all)))
 275
 276 (test-equal "string-distance"
 277   '(0 1 1 5 5)
 278   (list
 279    (string-distance "hello" "hello")
 280    (string-distance "hello" "helo")
 281    (string-distance "helo" "hello")
 282    (string-distance "" "hello")
 283    (string-distance "hello" "")))
 284
 285 (test-equal "string-closest"
 286   '("hello" "hello" "helo" #f)
 287   (list
 288    (string-closest "hello" '("hello"))
 289    (string-closest "hello" '("helo" "hello" "halo"))
 290    (string-closest "hello" '("kikoo" "helo" "hihihi" "halo"))
 291    (string-closest "hello" '("aaaaa" "12345" "hellohello" "h"))))
 292
 293 (test-equal "target-linux?"
 294   '(#t #f #f #t)
 295   (map target-linux?
 296        '("i686-linux-gnu" "i686-w64-mingw32"
 297          ;; Checking that "gnu" is present is not sufficient,
 298          ;; as GNU/Hurd exists.
 299          "i686-pc-gnu"
 300          ;; Some targets have a suffix.
 301          "arm-linux-gnueabihf")))
 302
 303 (test-equal "target-mingw?"
 304   '(#f #f #t)
 305   (map target-mingw?
 306        '("i686-linux-gnu" "i686-pc-gnu"
 307          "i686-w64-mingw32")))
 308
 309 (test-equal "target-x86-32?"
 310   '(#f #f #f #t #t #t #t #f)
 311   ;; These are (according to Wikipedia) two RISC architectures
 312   ;; by Intel and presumably not compatible with the x86-32 series.
 313   (map target-x86-32?
 314        '("i860-gnu" "i960-gnu"
 315          ;; This is a 16-bit architecture
 316          "i286-gnu"
 317          ;; These are part of the x86-32 series.
 318          "i386-gnu" "i486-gnu" "i586-gnu" "i686-gnu"
 319          ;; Maybe this one will exist some day, but not yet.
 320          "i786-gnu")))
 321
 322 (test-equal "target-x86-64?"
 323   '(#t #f #f #f)
 324   (map target-x86-64?
 325        `("x86_64-linux-gnu" "i386-linux-gnu"
 326          ;; Just because it includes "64" doesn't make it 64-bit.
 327          "aarch64-linux-gnu"
 328          ;; Note that (expt 2 109) in decimal notation starts with 64.
 329          ;; However, it isn't 32-bit.
 330          ,(format #f "x86_~a-linux-gnu" (expt 2 109)))))
 331
 332 (test-end)
 333
 334 (false-if-exception (delete-file temp-file))