aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012-2021, 2024 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;; Copyright © 2023 Foundation Devices, Inc. <hello@foundationdevices.com>
;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-utils)
  #:use-module ((guix config) #:select (%gzip))
  #:use-module (guix utils)
  #:use-module ((guix build utils) #:select (call-with-temporary-output-file))
  #:use-module ((guix store) #:select (%store-prefix store-path-package-name))
  #:use-module ((guix search-paths) #:select (string-tokenize*))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist))

(define temp-file
  (string-append "t-utils-" (number->string (getpid))))

(test-begin "utils")

(test-assert "gnu-triplet->nix-system"
  (let ((samples '(("i586-gnu0.3" "i686-gnu")
                   ("x86_64-unknown-linux-gnu" "x86_64-linux")
                   ("i386-pc-linux-gnu" "i686-linux")
                   ("x86_64-unknown-freebsd8.2" "x86_64-freebsd")
                   ("x86_64-apple-darwin10.8.0" "x86_64-darwin")
                   ("i686-pc-cygwin" "i686-cygwin"))))
    (let-values (((gnu nix) (unzip2 samples)))
      (every (lambda (gnu nix)
               (equal? nix (gnu-triplet->nix-system gnu)))
             gnu nix))))

(test-assert "package-name->name+version"
  (every (match-lambda
          ((name version)
           (let*-values (((full-name)
                          (if version
                              (string-append name "@" version)
                              name))
                         ((name* version*)
                          (package-name->name+version full-name)))
             (and (equal? name* name)
                  (equal? version* version)))))
         '(("foo" "0.9.1b")
           ("foo-14-bar" "320")
           ("foo-bar2" #f)
           ("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen'
           ("nixpkgs" "1.0pre22125_a28fe19")
           ("gtk2" "2.38.0"))))

(test-assert "guile-version>? 1.8"
  (guile-version>? "1.8"))

(test-assert "guile-version>? 10.5"
  (not (guile-version>? "10.5")))

(test-assert "version-prefix?"
  (and (version-prefix? "4.1" "4.1.2")
       (version-prefix? "4.1" "4.1")
       (not (version-prefix? "4.1" "4.16.2"))
       (not (version-prefix? "4.1" "4"))))

(test-equal "version-unique-prefix"
  '("2" "2.2" "")
  (list (version-unique-prefix "2.0" '("3.0" "2.0"))
        (version-unique-prefix "2.2" '("3.0.5" "2.0.9" "2.2.7"))
        (version-unique-prefix "27.1" '("27.1"))))

(test-equal "string-tokenize*"
  '(("foo")
    ("foo" "bar" "baz")
    ("foo" "bar" "")
    ("foo" "bar" "baz"))
  (list (string-tokenize* "foo" ":")
        (string-tokenize* "foo;bar;baz" ";")
        (string-tokenize* "foo!bar!" "!")
        (string-tokenize* "foo+-+bar+-+baz" "+-+")))

(test-equal "string-replace-substring"
  '("foo BAR! baz"
    "/gnu/store/chbouib"
    "")
  (list (string-replace-substring "foo bar baz" "bar" "BAR!")
        (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/")
        (string-replace-substring "" "foo" "bar")))

(test-equal "strip-keyword-arguments"
  '(a #:b b #:c c)
  (strip-keyword-arguments '(#:foo #:bar #:baz)
                           '(a #:foo 42 #:b b #:baz 3
                               #:c c #:bar 4)))

(test-equal "ensure-keyword-arguments"
  '((#:foo 2)
    (#:foo 2 #:bar 3)
    (#:foo 42 #:bar 3))
  (list (ensure-keyword-arguments '(#:foo 2) '(#:foo 2))
        (ensure-keyword-arguments '(#:foo 2) '(#:bar 3))
        (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42))))

(test-equal "default-keyword-arguments"
  '((#:foo 2)
    (#:foo 2)
    (#:foo 2 #:bar 3)
    (#:foo 2 #:bar 3)
    (#:foo 2 #:bar 3))
  (list (default-keyword-arguments '() '(#:foo 2))
        (default-keyword-arguments '(#:foo 2) '(#:foo 4))
        (default-keyword-arguments '() '(#:bar 3 #:foo 2))
        (default-keyword-arguments '(#:bar 3) '(#:foo 2))
        (default-keyword-arguments '(#:foo 2 #:bar 3) '(#:bar 6))))

(test-equal "substitute-keyword-arguments"
  '((#:foo 3)
    (#:foo 3)
    (#:foo 3 #:bar (1 2))
    (#:bar (1 2) #:foo 3)
    (#:foo 3))
  (list (substitute-keyword-arguments '(#:foo 2)
          ((#:foo f) (1+ f)))
        (substitute-keyword-arguments '()
          ((#:foo f 2) (1+ f)))
        (substitute-keyword-arguments '(#:foo 2 #:bar (2))
          ((#:foo f) (1+ f))
          ((#:bar b) (cons 1 b)))
        (substitute-keyword-arguments '(#:foo 2)
          ((#:foo _) 3)
          ((#:bar b '(2)) (cons 1 b)))
        (substitute-keyword-arguments '(#:foo 2)
          ((#:foo f 1) (1+ f))
          ((#:bar b) (cons 42 b)))))

(test-assert "filtered-port, file"
  (let* ((file  (search-path %load-path "guix.scm"))
         (input (open-file file "r0b")))
    (let*-values (((compressed pids1)
                   (filtered-port `(,%gzip "-c" "--fast") input))
                  ((decompressed pids2)
                   (filtered-port `(,%gzip "-d") compressed)))
      (and (every (compose zero? cdr waitpid)
                  (append pids1 pids2))
           (equal? (get-bytevector-all decompressed)
                   (call-with-input-file file get-bytevector-all))))))

(test-assert "filtered-port, non-file"
  (let ((data (call-with-input-file (search-path %load-path "guix.scm")
                get-bytevector-all)))
    (let*-values (((compressed pids1)
                   (filtered-port `(,%gzip "-c" "--fast")
                                  (open-bytevector-input-port data)))
                  ((decompressed pids2)
                   (filtered-port `(,%gzip "-d") compressed)))
      (and (pk (every (compose zero? cdr waitpid)
                   (append pids1 pids2)))
           (equal? (get-bytevector-all decompressed) data)))))

(test-assert "filtered-port, does not exist"
  (let* ((file  (search-path %load-path "guix.scm"))
         (input (open-file file "r0b")))
    (let-values (((port pids)
                  (filtered-port '("/does/not/exist") input)))
      (any (compose (negate zero?) cdr waitpid)
           pids))))

(define (test-compression/decompression method run?)
  "Test METHOD, a symbol such as 'gzip.  Call RUN? to determine whether to
skip these tests."
  (unless (run?) (test-skip 1))
  (test-assert (format #f "compressed-port, decompressed-port, non-file [~a]"
                       method)
    (let ((data (call-with-input-file (search-path %load-path "guix.scm")
                  get-bytevector-all)))
      (call-with-temporary-output-file
       (lambda (output port)
         (close-port port)
         (let*-values (((compressed pids)
                        ;; Note: 'compressed-output-port' only supports file
                        ;; ports.
                        (compressed-output-port method
                                                (open-file output "w0"))))
           (put-bytevector compressed data)
           (close-port compressed)
           (and (every (compose zero? cdr waitpid)
                       (pk 'pids method pids))
                (let*-values (((decompressed pids)
                               (decompressed-port method
                                                  (open-bytevector-input-port
                                                   (call-with-input-file output
                                                     get-bytevector-all))))
                              ((result)
                               (get-bytevector-all decompressed)))
                  (close-port decompressed)
                  (pk 'len method
                      (if (bytevector? result)
                          (bytevector-length result)
                          result)
                      (bytevector-length data))
                  (and (every (compose zero? cdr waitpid)
                              (pk 'pids method pids))
                       (equal? result data)))))))))

  (false-if-exception (delete-file temp-file))
  (unless (run?) (test-skip 1))
  (test-assert (format #f "compressed-output-port + decompressed-port [~a]"
                       method)
    (let* ((file (search-path %load-path "guix/derivations.scm"))
           (data (call-with-input-file file get-bytevector-all))
           (port (open-file temp-file "w0b")))
      (call-with-compressed-output-port method port
        (lambda (compressed)
          (put-bytevector compressed data)))
      (close-port port)

      (bytevector=? data
                    (call-with-decompressed-port method (open-file temp-file "r0b")
                      get-bytevector-all)))))

(for-each test-compression/decompression
          `(gzip xz lzip zstd)
          (list (const #t) (const #t) (const #t)
                (lambda ()
                  (resolve-module '(zstd) #t #f #:ensure #f))))

;; This is actually in (guix store).
(test-equal "store-path-package-name"
  "bash-4.2-p24"
  (store-path-package-name
   (string-append (%store-prefix)
                  "/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24")))

(test-equal "canonical-newline-port"
  "This is a journey\nInto the sound\nA journey ...\n"
  (let ((port (open-string-input-port
               "This is a journey\r\nInto the sound\r\nA journey ...\n")))
    (get-string-all (canonical-newline-port port))))

(test-equal "canonical-newline-port-1024"
  (string-concatenate (make-list 100 "0123456789abcde\n"))
  (let ((port (open-string-input-port
               (string-concatenate
                (make-list 100 "0123456789abcde\r\n")))))
    (get-string-all (canonical-newline-port port))))

(test-equal "edit-expression"
  "(display \"GNU Guix\")\n(newline)\n"
  (begin
    (call-with-output-file temp-file
      (lambda (port)
        (display "(display \"xiuG UNG\")\n(newline)\n" port)))
    (edit-expression `((filename . ,temp-file)
                       (line     . 0)
                       (column   . 9))
                     string-reverse)
    (call-with-input-file temp-file get-string-all)))

(test-equal "insert-expression"
  "(define-public package-1\n  'package)\n
(define-public package-2\n  'package)\n"
  (begin
    (call-with-output-file temp-file
      (lambda (port)
        (display "(define-public package-2\n  'package)\n" port)))
    (insert-expression `((filename . ,temp-file)
                         (line     . 0)
                         (column   . 0))
                       `(define-public package-1 'package))
    (call-with-input-file temp-file get-string-all)))

(test-equal "find-definition-insertion-location"
  (list `((filename . ,temp-file) (line . 0) (column . 0))
        `((filename . ,temp-file) (line . 5) (column . 0))
        #f)
  (begin
    (call-with-output-file temp-file
      (lambda (port)
        (display "(define-public package-1\n  'foo)\n\n" port)
        (display "(define foo 'bar)\n\n" port)
        (display "(define-public package-2\n  'baz)\n" port)))
    (map (lambda (term)
           (find-definition-insertion-location temp-file term))
         (list 'package 'package-1 'package-2))))

(test-equal "string-distance"
  '(0 1 1 5 5)
  (list
   (string-distance "hello" "hello")
   (string-distance "hello" "helo")
   (string-distance "helo" "hello")
   (string-distance "" "hello")
   (string-distance "hello" "")))

(test-equal "string-closest"
  '("hello" "hello" "helo" #f)
  (list
   (string-closest "hello" '("hello"))
   (string-closest "hello" '("helo" "hello" "halo"))
   (string-closest "hello" '("kikoo" "helo" "hihihi" "halo"))
   (string-closest "hello" '("aaaaa" "12345" "hellohello" "h"))))

(test-equal "target-linux?"
  '(#t #f #f #t)
  (map target-linux?
       '("i686-linux-gnu" "i686-w64-mingw32"
         ;; Checking that "gnu" is present is not sufficient,
         ;; as GNU/Hurd exists.
         "i686-pc-gnu"
         ;; Some targets have a suffix.
         "arm-linux-gnueabihf")))

(test-equal "target-mingw?"
  '(#f #f #t)
  (map target-mingw?
       '("i686-linux-gnu" "i686-pc-gnu"
         "i686-w64-mingw32")))

(test-equal "target-x86-32?"
  '(#f #f #f #t #t #t #t #f)
  ;; These are (according to Wikipedia) two RISC architectures
  ;; by Intel and presumably not compatible with the x86-32 series.
  (map target-x86-32?
       '("i860-gnu" "i960-gnu"
         ;; This is a 16-bit architecture
         "i286-gnu"
         ;; These are part of the x86-32 series.
         "i386-gnu" "i486-gnu" "i586-gnu" "i686-gnu"
         ;; Maybe this one will exist some day, but not yet.
         "i786-gnu")))

(test-equal "target-x86-64?"
  '(#t #f #f #f)
  (map target-x86-64?
       `("x86_64-linux-gnu" "i386-linux-gnu"
         ;; Just because it includes "64" doesn't make it 64-bit.
         "aarch64-linux-gnu"
         ;; Note that (expt 2 109) in decimal notation starts with 64.
         ;; However, it isn't 32-bit.
         ,(format #f "x86_~a-linux-gnu" (expt 2 109)))))

(test-equal "target-avr?"
  '(#t #t #t #f #f)
  (map target-avr?
       '("avr" "avr-unknown-none"
         ;; In addition LLVM also uses this form.
         "avr-unknown-unknown"
         ;; The AVR32 architecture also was made by Atmel/Microchip but it
         ;; does not resemble the AVR family, they aren't compatible in any
         ;; way.
         "avr32" "avr32-unknown-none")))

(test-end)

(false-if-exception (delete-file temp-file))
generated by cgit
class='msg-avail'>...Previously the same package could appear several times if several variables were bound to it, as is notably the case for "python" currently. This, in turn, would lead to obnoxious "ambiguous package specification" messages. * gnu/packages.scm (generate-package-cache)[expand-cache]: Change RESULT to RESULT+SEEN and adjust accordingly. Call 'first' on the result of 'fold-module-public-variables*'. * tests/packages.scm ("fold-available-packages with/without cache"): Check for lack of duplicates in FROM-CACHE. Ludovic Courtès 2019-02-06Merge branch 'master' into core-updatesRicardo Wurmus 2019-01-25packages: Add 'package-closure'....* guix/packages.scm (package-closure): New procedure. * tests/packages.scm ("package-closure"): New test. Ludovic Courtès 2019-01-21store: Rename '&nix-error' to '&store-error'....* guix/store.scm (&nix-error): Rename to... (&store-error): ... this, and adjust users. (&nix-connection-error): Rename to... (&store-connection-error): ... this, and adjust users. (&nix-protocol-error): Rename to... (&store-protocol-error): ... this, adjust users. (&nix-error, &nix-connection-error, &nix-protocol-error): Define these condition types and their getters as deprecrated aliases. * build-aux/run-system-tests.scm, guix/derivations.scm, guix/grafts.scm, guix/scripts/challenge.scm, guix/scripts/graph.scm, guix/scripts/lint.scm, guix/scripts/offload.scm, guix/serialization.scm, guix/ssh.scm, guix/tests.scm, guix/ui.scm, tests/derivations.scm, tests/gexp.scm, tests/guix-daemon.sh, tests/packages.scm, tests/store.scm, doc/guix.texi: Adjust to use the new names. Ludovic Courtès 2019-01-15guix package: '--list-available' can use data from the cache....* gnu/packages.scm (fold-available-packages): New procedure. * guix/scripts/package.scm (process-query): Use it instead of 'fold-packages'. * tests/packages.scm ("fold-available-packages with/without cache"): New test. Ludovic Courtès 2019-01-15edit: Use 'specification->location' to read information from the cache....That way 'guix edit' doesn't need to load any package module. * gnu/packages.scm (find-package-locations, specification->location): New procedures. * guix/scripts/edit.scm (package->location-specification): Rename to... (location->location-specification): ... this. Expect a location object instead of a package. (guix-edit): Use 'specification->location' instead of 'specification->package'. * tests/packages.scm ("find-package-locations") ("find-package-locations with cache") ("specification->location"): New tests. Ludovic Courtès 2019-01-15channels: Compute a package cache and use it....* gnu/packages.scm (cache-is-authoritative?, load-package-cache) (cache-lookup, generate-package-cache): New procedures. (%package-cache-file): New variable. (find-packages-by-name): Rename to... (find-packages-by-name/direct): ... this. (find-packages-by-name): Rewrite to use the package cache when 'cache-is-authoritative?' returns true. * tests/packages.scm ("find-packages-by-name + version, with cache") ("find-packages-by-name with cache"): New tests. * guix/channels.scm (package-cache-file): New procedure. (%channel-profile-hooks): New variable. (channel-instances->derivation): Use it in #:hooks. * guix/scripts/package.scm (build-and-use-profile): Add #:hooks and honor it. * guix/scripts/pull.scm (build-and-install): Pass #:hooks to UPDATE-PROFILE. Ludovic Courtès 2019-01-15guix package: Avoid 'find-newest-available-packages'....* guix/scripts/package.scm (transaction-upgrade-entry): Use 'find-best-packages-by-name' instead of 'find-newest-available-packages'. * tests/packages.scm ("transaction-upgrade-entry, zero upgrades") ("transaction-upgrade-entry, one upgrade") ("transaction-upgrade-entry, superseded package"): Adjust accordingly. Ludovic Courtès 2018-09-23tests: Update package-transitive-supported-systems tests....* tests/packages.scm ("package-transitive-supported-systems, implicit inputs"): Test traditionally-bootstrapped architecture. ("package-transitive-supported-systems: reduced binary seed, implicit inputs"): New test for Reduced Binary Seed bootstrap. Jan Nieuwenhuizen 2018-09-04Switch to Guile-Gcrypt....This removes (guix hash) and (guix pk-crypto), which now live as part of Guile-Gcrypt (version 0.1.0.) * guix/gcrypt.scm, guix/hash.scm, guix/pk-crypto.scm, tests/hash.scm, tests/pk-crypto.scm: Remove. * configure.ac: Test for Guile-Gcrypt. Remove LIBGCRYPT and LIBGCRYPT_LIBDIR assignments. * m4/guix.m4 (GUIX_ASSERT_LIBGCRYPT_USABLE): Remove. * README: Add Guile-Gcrypt to the dependencies; move libgcrypt as "required unless --disable-daemon". * doc/guix.texi (Requirements): Likewise. * gnu/packages/bash.scm, guix/derivations.scm, guix/docker.scm, guix/git.scm, guix/http-client.scm, guix/import/cpan.scm, guix/import/cran.scm, guix/import/crate.scm, guix/import/elpa.scm, guix/import/gnu.scm, guix/import/hackage.scm, guix/import/texlive.scm, guix/import/utils.scm, guix/nar.scm, guix/pki.scm, guix/scripts/archive.scm, guix/scripts/authenticate.scm, guix/scripts/download.scm, guix/scripts/hash.scm, guix/scripts/pack.scm, guix/scripts/publish.scm, guix/scripts/refresh.scm, guix/scripts/substitute.scm, guix/store.scm, guix/store/deduplication.scm, guix/tests.scm, tests/base32.scm, tests/builders.scm, tests/challenge.scm, tests/cpan.scm, tests/crate.scm, tests/derivations.scm, tests/gem.scm, tests/nar.scm, tests/opam.scm, tests/pki.scm, tests/publish.scm, tests/pypi.scm, tests/store-deduplication.scm, tests/store.scm, tests/substitute.scm: Adjust imports. * gnu/system/vm.scm: Likewise. (guile-sqlite3&co): Rename to... (gcrypt-sqlite3&co): ... this. Add GUILE-GCRYPT. (expression->derivation-in-linux-vm)[config]: Remove. (iso9660-image)[config]: Remove. (qemu-image)[config]: Remove. (system-docker-image)[config]: Remove. * guix/scripts/pack.scm: Adjust imports. (guile-sqlite3&co): Rename to... (gcrypt-sqlite3&co): ... this. Add GUILE-GCRYPT. (self-contained-tarball)[build]: Call 'make-config.scm' without #:libgcrypt argument. (squashfs-image)[libgcrypt]: Remove. [build]: Call 'make-config.scm' without #:libgcrypt. (docker-image)[config, json]: Remove. [build]: Add GUILE-GCRYPT to the extensions Remove (guix config) from the imported modules. * guix/self.scm (specification->package): Remove "libgcrypt", add "guile-gcrypt". (compiled-guix): Remove #:libgcrypt. [guile-gcrypt]: New variable. [dependencies]: Add it. [*core-modules*]: Remove #:libgcrypt from 'make-config.scm' call. Add #:extensions. [*config*]: Remove #:libgcrypt from 'make-config.scm' call. (%dependency-variables): Remove %libgcrypt. (make-config.scm): Remove #:libgcrypt. * build-aux/build-self.scm (guile-gcrypt): New variable. (make-config.scm): Remove #:libgcrypt. (build-program)[fake-gcrypt-hash]: New variable. Add (gcrypt hash) to the imported modules. Adjust load path assignments. * gnu/packages/package-management.scm (guix)[propagated-inputs]: Add GUILE-GCRYPT. [arguments]: In 'wrap-program' phase, add GUILE-GCRYPT to the search path. Ludovic Courtès 2018-06-09packages: Add 'package-patched-vulnerabilities'....* guix/packages.scm (patch-file-name): New procedure. (%vulnerability-regexp): New variable. (package-patched-vulnerabilities): New procedure. * guix/scripts/lint.scm (patch-file-name): Remove. (check-vulnerabilities): Adjust to use 'package-patched-vulnerabilities'. * tests/packages.scm ("package-patched-vulnerabilities"): New test. Ludovic Courtès 2018-03-27tests: Use invoke and return #t from all builders....* tests/packages.scm ("package-source-derivation, snippet", "trivial") ("trivial with local file as input", "trivial with source") ("trivial with system-dependent input", "trivial with #:allowed-references") ("--search-paths with pattern", "--search-paths with single-item search path") ("replacement also grafted"): In the builders, raise an exception on errors and otherwise return #t. Use invoke. Mark H Weaver 2018-03-15tests: Do not assume the bootstrap guile tarball is available locally....Fixes <https://bugs.gnu.org/30824>. Reported by Chris Marusich <cmmarusich@gmail.com>. * tests/packages.scm ("package-source-derivation, snippet"): Use 'bootstrap-guile-origin' instead of assuming the bootstrap guile tarball is available locally. Ludovic Courtès