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
idate appstream file" test fails #:phases (modify-phases %standard-phases (add-after 'wrap 'wrap-libs (lambda* (#:key outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (gi-typelib-path (getenv "GI_TYPELIB_PATH")) (gst-plugin-path (getenv "GST_PLUGIN_SYSTEM_PATH")) (python-path (getenv "GUIX_PYTHONPATH"))) (wrap-program (string-append out "/bin/blanket") `("GI_TYPELIB_PATH" ":" prefix (,gi-typelib-path)) `("GST_PLUGIN_SYSTEM_PATH" ":" prefix (,gst-plugin-path)) `("GUIX_PYTHONPATH" ":" prefix (,python-path))))))))) (native-inputs (list desktop-file-utils gettext-minimal `(,glib "bin") gobject-introspection `(,gtk+ "bin") pkg-config)) (inputs (list appstream-glib bash-minimal gsettings-desktop-schemas gst-plugins-bad gst-plugins-good ;for ScaleTempo plugin gtk+ libhandy python python-gst python-pygobject)) (home-page "https://github.com/rafaelmardojai/blanket") (synopsis "Ambient sound and noise player") (description "Blanket provides different ambient sounds and types of noise to listen to with the goal of improving your focus and enhancing your productivity. You can also use it to fall asleep in a noisy environment.") (license license:gpl3+))) (define-public feathernotes (package (name "feathernotes") (version "0.10.0") (home-page "https://github.com/tsujan/FeatherNotes") (source (origin (method git-fetch) (uri (git-reference (url home-page) (commit (string-append "V" version)))) (file-name (git-file-name name version)) (sha256 (base32 "122pbbxvi0mmhbz8m8far71vm72090r5cafss4hvrsjmq52a0y4k")))) (build-system qt-build-system) (arguments (list #:tests? #f)) ; no upstream tests (native-inputs (list pkg-config qttools-5)) ; for lrelease (inputs (list hunspell qtsvg-5 qtx11extras qtbase-5)) (synopsis "GUI hierarchical notes-manager") (description "FeatherNotes is a GUI hierarchical notes-manager for Linux. It is independent of any desktop environment and has rich text formatting, image embedding and inserting editable tables, spell checking, searchable tags, drag and drop support, tray icon, node icons, hyperlinks, pdf and html export, password protection and auto-saving.") (license license:gpl3+))) (define-public wtime (package (name "wtime") (version "0.2") (source (origin (method url-fetch) (uri (string-append "mirror://sourceforge/wtime/wtime/" version "/wtime_" (string-replace-substring version "." "_") ".tar.gz")) (sha256 (base32 "1rp1sxas9wjc84fvr6x94ryl3r9w7jd0x5j1hbi9q7yrgfclp830")))) (build-system gnu-build-system) (arguments `(#:make-flags ,#~(list (string-append "CC=" #$(cc-for-target)) (string-append "PREFIX=" #$output)) #:phases (modify-phases %standard-phases (delete 'configure) (add-after 'unpack 'fix-man-path (lambda _ (substitute* "Makefile" (("/man1") "/share/man/man1"))))) #:tests? #f)) ; No "check" target. (home-page "https://wtime.sourceforge.net") (synopsis "Command-line utility for tracking time spent on arbitrary tasks") (description "@code{wtime} is a command-line utility for tracking time spent working on arbitrary tasks. All the time data is saved in files residing in the @code{.wtimed} directory in the user's home directory.") (license license:x11))) (define-public todoman (package (name "todoman") (version "4.4.0") (source (origin (method url-fetch) (uri (pypi-uri "todoman" version)) (sha256 (base32 "1dlxmw919jvjxycf315vzs4f5q64gdjrp3988y8jkyivqywfwyqb")))) (build-system pyproject-build-system) (arguments (list #:phases #~(modify-phases %standard-phases (replace 'check (lambda* (#:key tests? #:allow-other-keys) (when tests? (invoke "pytest" "--hypothesis-profile=ci" "-vv" "tests" "-k" (string-append ;; Test expects wrong output string. "not test_bad_start_date " ;; Unknown failure "and not test_default_command_args")))))))) (native-inputs (list python-freezegun python-hypothesis python-pytest python-pytest-cov python-pytest-runner python-pytz python-setuptools python-wheel)) (propagated-inputs (list python-atomicwrites python-click python-click-log python-dateutil python-humanize python-icalendar python-parsedatetime python-pyxdg python-urwid)) (home-page "https://todoman.readthedocs.io/") (synopsis "CalDav-based todo manager") (description "Todoman is a simple, standards-based, cli todo (aka: task) manager. Todos are stored into icalendar files, which means you can sync them via CalDAV using, for example, @code{vdirsyncer}.") (license license:isc))) (define-public watson (package (name "watson") (version "2.1.0") (source (origin (method git-fetch) (uri (git-reference (url "https://github.com/tailordev/watson") (commit version))) (file-name (git-file-name name version)) (sha256 (base32 "0j0gqnxf0smjs0sy7ipryj1sk0s59wrh4qwr7h55zdr4wdhi407w")))) (build-system pyproject-build-system) (native-inputs (list python-mock python-pytest python-pytest-datafiles python-pytest-mock python-setuptools python-wheel)) (propagated-inputs (list python-arrow python-click python-click-didyoumean python-colorama python-requests)) (home-page "https://tailordev.github.io/Watson/") (synopsis "Command-line time tracker") (description "Watson is command-line interface to manage your time. It supports projects, tagging and reports.") (license license:expat)))
generated by cgit