summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/gem.scm108
-rw-r--r--tests/gexp.scm87
-rw-r--r--tests/guix-pack.sh5
-rw-r--r--tests/guix-package.sh12
-rw-r--r--tests/hackage.scm71
-rw-r--r--tests/hash.scm4
-rw-r--r--tests/inferior.scm69
-rw-r--r--tests/nar.scm62
-rw-r--r--tests/opam.scm118
-rw-r--r--tests/pypi.scm6
-rw-r--r--tests/store-database.scm7
-rw-r--r--tests/store-deduplication.scm4
-rw-r--r--tests/store.scm46
-rw-r--r--tests/syscalls.scm13
14 files changed, 558 insertions, 54 deletions
diff --git a/tests/gem.scm b/tests/gem.scm
index a39e8ba514..4220170ff0 100644
--- a/tests/gem.scm
+++ b/tests/gem.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,10 +24,11 @@
#:use-module (guix hash)
#:use-module (guix tests)
#:use-module ((guix build utils) #:select (delete-file-recursively))
+ #:use-module (srfi srfi-41)
#:use-module (srfi srfi-64)
#:use-module (ice-9 match))
-(define test-json
+(define test-foo-json
"{
\"name\": \"foo\",
\"version\": \"1.0.0\",
@@ -42,6 +44,34 @@
\"licenses\": [\"MIT\", \"Apache 2.0\"]
}")
+(define test-bar-json
+ "{
+ \"name\": \"bar\",
+ \"version\": \"1.0.0\",
+ \"sha\": \"f3676eafca9987cb5fe263df1edf2538bf6dafc712b30e17be3543a9680547a8\",
+ \"info\": \"Another cool gem\",
+ \"homepage_uri\": \"https://example.com\",
+ \"dependencies\": {
+ \"runtime\": [
+ { \"name\": \"bundler\" },
+ ]
+ },
+ \"licenses\": [\"MIT\", \"Apache 2.0\"]
+}")
+
+(define test-bundler-json
+ "{
+ \"name\": \"bundler\",
+ \"version\": \"1.14.2\",
+ \"sha\": \"3bb53e03db0a8008161eb4c816ccd317120d3c415ba6fee6f90bbc7f7eec8690\",
+ \"info\": \"Ruby gem bundler\",
+ \"homepage_uri\": \"https://bundler.io/\",
+ \"dependencies\": {
+ \"runtime\": []
+ },
+ \"licenses\": [\"MIT\"]
+}")
+
(test-begin "gem")
(test-assert "gem->guix-package"
@@ -50,8 +80,8 @@
(lambda (url . rest)
(match url
("https://rubygems.org/api/v1/gems/foo.json"
- (values (open-input-string test-json)
- (string-length test-json)))
+ (values (open-input-string test-foo-json)
+ (string-length test-foo-json)))
(_ (error "Unexpected URL: " url)))))
(match (gem->guix-package "foo")
(('package
@@ -76,4 +106,76 @@
(x
(pk 'fail x #f)))))
+(test-assert "gem-recursive-import"
+ ;; Replace network resources with sample data.
+ (mock ((guix http-client) http-fetch
+ (lambda (url . rest)
+ (match url
+ ("https://rubygems.org/api/v1/gems/foo.json"
+ (values (open-input-string test-foo-json)
+ (string-length test-foo-json)))
+ ("https://rubygems.org/api/v1/gems/bar.json"
+ (values (open-input-string test-bar-json)
+ (string-length test-bar-json)))
+ ("https://rubygems.org/api/v1/gems/bundler.json"
+ (values (open-input-string test-bundler-json)
+ (string-length test-bundler-json)))
+ (_ (error "Unexpected URL: " url)))))
+ (match (stream->list (gem-recursive-import "foo"))
+ ((('package
+ ('name "ruby-foo")
+ ('version "1.0.0")
+ ('source
+ ('origin
+ ('method 'url-fetch)
+ ('uri ('rubygems-uri "foo" 'version))
+ ('sha256
+ ('base32
+ "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
+ ('build-system 'ruby-build-system)
+ ('propagated-inputs
+ ('quasiquote
+ (("bundler" ('unquote 'bundler))
+ ("ruby-bar" ('unquote 'ruby-bar)))))
+ ('synopsis "A cool gem")
+ ('description "This package provides a cool gem")
+ ('home-page "https://example.com")
+ ('license ('list 'license:expat 'license:asl2.0)))
+ ('package
+ ('name "ruby-bundler")
+ ('version "1.14.2")
+ ('source
+ ('origin
+ ('method 'url-fetch)
+ ('uri ('rubygems-uri "bundler" 'version))
+ ('sha256
+ ('base32
+ "1446xiz7zg0bz7kgx9jv84y0s4hpsg61dj5l3qb0i00avc1kxd9v"))))
+ ('build-system 'ruby-build-system)
+ ('synopsis "Ruby gem bundler")
+ ('description "Ruby gem bundler")
+ ('home-page "https://bundler.io/")
+ ('license 'license:expat))
+ ('package
+ ('name "ruby-bar")
+ ('version "1.0.0")
+ ('source
+ ('origin
+ ('method 'url-fetch)
+ ('uri ('rubygems-uri "bar" 'version))
+ ('sha256
+ ('base32
+ "1a270mlajhrmpqbhxcqjqypnvgrq4pgixpv3w9gwp1wrrapnwrzk"))))
+ ('build-system 'ruby-build-system)
+ ('propagated-inputs
+ ('quasiquote
+ (('"bundler" ('unquote 'bundler)))))
+ ('synopsis "Another cool gem")
+ ('description "Another cool gem")
+ ('home-page "https://example.com")
+ ('license ('list 'license:expat 'license:asl2.0))))
+ #t)
+ (x
+ (pk 'fail x #f)))))
+
(test-end "gem")
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 83fe811546..b22e635805 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -635,18 +635,16 @@
"guix/derivations.scm"))
("p/q" . ,(search-path %load-path "guix.scm"))
("p/z" . ,(search-path %load-path "guix/store.scm"))))
- (drv (imported-files files)))
+ (dir (imported-files files)))
(mbegin %store-monad
- (built-derivations (list drv))
- (let ((dir (derivation->output-path drv)))
- (return
- (every (match-lambda
- ((path . source)
- (equal? (call-with-input-file (string-append dir "/" path)
- get-bytevector-all)
- (call-with-input-file source
- get-bytevector-all))))
- files))))))
+ (return
+ (every (match-lambda
+ ((path . source)
+ (equal? (call-with-input-file (string-append dir "/" path)
+ get-bytevector-all)
+ (call-with-input-file source
+ get-bytevector-all))))
+ files)))))
(test-assertm "imported-files with file-like objects"
(mlet* %store-monad ((plain -> (plain-file "foo" "bar!"))
@@ -654,16 +652,19 @@
(files -> `(("a/b/c" . ,q-scm)
("p/q" . ,plain)))
(drv (imported-files files)))
+ (define (file=? file1 file2)
+ ;; Assume deduplication is in place.
+ (= (stat:ino (lstat file1))
+ (stat:ino (lstat file2))))
+
(mbegin %store-monad
(built-derivations (list drv))
(mlet %store-monad ((dir -> (derivation->output-path drv))
(plain* (text-file "foo" "bar!"))
(q-scm* (interned-file q-scm "c")))
(return
- (and (string=? (readlink (string-append dir "/a/b/c"))
- q-scm*)
- (string=? (readlink (string-append dir "/p/q"))
- plain*)))))))
+ (and (file=? (string-append dir "/a/b/c") q-scm*)
+ (file=? (string-append dir "/p/q") plain*)))))))
(test-equal "gexp-modules & ungexp"
'((bar) (foo))
@@ -948,7 +949,7 @@
(return (and (zero? (close-pipe pipe))
(= (expt n 2) (string->number str)))))))
-(test-assertm "gexp->script #:module-path"
+(test-assert "gexp->script #:module-path"
(call-with-temporary-directory
(lambda (directory)
(define str
@@ -961,23 +962,24 @@
(define-public %fake! ,str))
port)))
- (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32))
- (gexp (begin
- (use-modules (guix base32))
- (write (list %load-path
- %fake!))))))
- (drv (gexp->script "guile-thing" exp
- #:guile %bootstrap-guile
- #:module-path (list directory)))
- (out -> (derivation->output-path drv))
- (done (built-derivations (list drv))))
- (let* ((pipe (open-input-pipe out))
- (data (read pipe)))
- (return (and (zero? (close-pipe pipe))
- (match data
- ((load-path str*)
- (and (string=? str* str)
- (not (member directory load-path))))))))))))
+ (run-with-store %store
+ (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32))
+ (gexp (begin
+ (use-modules (guix base32))
+ (write (list %load-path
+ %fake!))))))
+ (drv (gexp->script "guile-thing" exp
+ #:guile %bootstrap-guile
+ #:module-path (list directory)))
+ (out -> (derivation->output-path drv))
+ (done (built-derivations (list drv))))
+ (let* ((pipe (open-input-pipe out))
+ (data (read pipe)))
+ (return (and (zero? (close-pipe pipe))
+ (match data
+ ((load-path str*)
+ (and (string=? str* str)
+ (not (member directory load-path)))))))))))))
(test-assertm "program-file"
(let* ((n (random (expt 2 50)))
@@ -996,7 +998,7 @@
(return (and (zero? (close-pipe pipe))
(= n (string->number str)))))))))
-(test-assertm "program-file #:module-path"
+(test-assert "program-file #:module-path"
(call-with-temporary-directory
(lambda (directory)
(define text (random-text))
@@ -1014,14 +1016,15 @@
(file (program-file "program" exp
#:guile %bootstrap-guile
#:module-path (list directory))))
- (mlet* %store-monad ((drv (lower-object file))
- (out -> (derivation->output-path drv)))
- (mbegin %store-monad
- (built-derivations (list drv))
- (let* ((pipe (open-input-pipe out))
- (str (get-string-all pipe)))
- (return (and (zero? (close-pipe pipe))
- (string=? text str))))))))))
+ (run-with-store %store
+ (mlet* %store-monad ((drv (lower-object file))
+ (out -> (derivation->output-path drv)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (let* ((pipe (open-input-pipe out))
+ (str (get-string-all pipe)))
+ (return (and (zero? (close-pipe pipe))
+ (string=? text str)))))))))))
(test-assertm "program-file & with-extensions"
(let* ((exp (with-extensions (list %extension-package)
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
index 917d52451c..bf367fa429 100644
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@@ -28,6 +28,11 @@ fi
guix pack --version
+# FIXME: Starting from commit 66e9944e078cbb9e0d618377dd6df6e639640efa,
+# '--bootstrap' is mostly ineffective since 'guix pack' produces derivations
+# that refer to guile-sqlite3 and libgcrypt. For now we just skip the test.
+exit 77
+
# Use --no-substitutes because we need to verify we can do this ourselves.
GUIX_BUILD_OPTIONS="--no-substitutes"
export GUIX_BUILD_OPTIONS
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 3b3fa35cd8..cef3b3452e 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -185,6 +185,16 @@ grep -E 'emacs[[:blank:]]+42\.5\.9rc7[[:blank:]]+.*-emacs-42.5.9rc7' \
rm "$emacs_tarball" "$tmpfile"
rmdir "$module_dir"
+# Profiles with a relative file name. Make sure we don't create dangling
+# symlinks--see bug report at
+# <https://lists.gnu.org/archive/html/guix-devel/2018-07/msg00036.html>.
+mkdir -p "$module_dir/foo"
+( cd "$module_dir" ; \
+ guix package --bootstrap -i guile-bootstrap -p foo/prof )
+test -f "$module_dir/foo/prof/bin/guile"
+rm "$module_dir/foo"/*
+rmdir "$module_dir/foo"
+rmdir "$module_dir"
#
# Try with the default profile.
@@ -215,7 +225,7 @@ do
guix package --bootstrap --roll-back
! test -f "$HOME/.guix-profile/bin"
! test -f "$HOME/.guix-profile/lib"
- test "`readlink "$default_profile"`" = "$default_profile-0-link"
+ test "`readlink "$default_profile"`" = "`basename $default_profile-0-link`"
done
# Check whether '-p ~/.guix-profile' makes any difference.
diff --git a/tests/hackage.scm b/tests/hackage.scm
index a4de8be91e..e17851a213 100644
--- a/tests/hackage.scm
+++ b/tests/hackage.scm
@@ -69,6 +69,65 @@ library
mtl >= 2.0 && < 3
")
+;; Check "-any", "-none" when name is different.
+(define test-cabal-4
+ "name: foo
+version: 1.0.0
+homepage: http://test.org
+synopsis: synopsis
+description: description
+license: BSD3
+library
+ if impl(ghcjs -any)
+ Build-depends: ghc-a
+ if impl(ghc>=7.2&&<7.6)
+ Build-depends: ghc-b
+ if impl(ghc == 7.8)
+ Build-depends:
+ HTTP >= 4000.2.5 && < 4000.3,
+ mtl >= 2.0 && < 3
+")
+
+;; Check "-any", "-none".
+(define test-cabal-5
+ "name: foo
+version: 1.0.0
+homepage: http://test.org
+synopsis: synopsis
+description: description
+license: BSD3
+library
+ if impl(ghc == 7.8)
+ Build-depends:
+ HTTP >= 4000.2.5 && < 4000.3,
+ if impl(ghc -any)
+ Build-depends: mtl >= 2.0 && < 3
+ if impl(ghc>=7.2&&<7.6)
+ Build-depends: ghc-b
+")
+
+;; Check "custom-setup".
+(define test-cabal-6
+ "name: foo
+build-type: Custom
+version: 1.0.0
+homepage: http://test.org
+synopsis: synopsis
+description: description
+license: BSD3
+custom-setup
+ setup-depends: base >= 4.7 && < 5,
+ Cabal >= 1.24,
+ haskell-gi == 0.21.*
+library
+ if impl(ghc>=7.2&&<7.6)
+ Build-depends: ghc-b
+ if impl(ghc == 7.8)
+ Build-depends:
+ HTTP >= 4000.2.5 && < 4000.3,
+ mtl >= 2.0 && < 3
+")
+
;; A fragment of a real Cabal file with minor modification to check precedence
;; of 'and' over 'or', missing final newline, spaces between keywords and
;; parentheses and between key and column.
@@ -139,6 +198,18 @@ library
(eval-test-with-cabal test-cabal-3
#:cabal-environment '(("impl" . "ghc-7.8"))))
+(test-assert "hackage->guix-package test 4"
+ (eval-test-with-cabal test-cabal-4
+ #:cabal-environment '(("impl" . "ghc-7.8"))))
+
+(test-assert "hackage->guix-package test 5"
+ (eval-test-with-cabal test-cabal-5
+ #:cabal-environment '(("impl" . "ghc-7.8"))))
+
+(test-assert "hackage->guix-package test 6"
+ (eval-test-with-cabal test-cabal-6
+ #:cabal-environment '(("impl" . "ghc-7.8"))))
+
(test-assert "read-cabal test 1"
(match (call-with-input-string test-read-cabal-1 read-cabal)
((("name" ("test-me"))
diff --git a/tests/hash.scm b/tests/hash.scm
index da87616eec..47dff3915b 100644
--- a/tests/hash.scm
+++ b/tests/hash.scm
@@ -64,12 +64,12 @@
(get)))
(test-equal "open-sha256-port, hello"
- %hello-sha256
+ (list %hello-sha256 (string-length "hello world"))
(let-values (((port get)
(open-sha256-port)))
(put-bytevector port (string->utf8 "hello world"))
(force-output port)
- (get)))
+ (list (get) (port-position port))))
(test-assert "port-sha256"
(let* ((file (search-path %load-path "ice-9/psyntax.scm"))
diff --git a/tests/inferior.scm b/tests/inferior.scm
new file mode 100644
index 0000000000..5e0f8ae66e
--- /dev/null
+++ b/tests/inferior.scm
@@ -0,0 +1,69 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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-inferior)
+ #:use-module (guix inferior)
+ #:use-module (guix packages)
+ #:use-module (gnu packages)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-64))
+
+(define %top-srcdir
+ (dirname (search-path %load-path "guix.scm")))
+
+(define %top-builddir
+ (dirname (search-path %load-compiled-path "guix.go")))
+
+
+(test-begin "inferior")
+
+(test-equal "open-inferior"
+ '(42 #t)
+ (let ((inferior (open-inferior %top-builddir
+ #:command "scripts/guix")))
+ (and (inferior? inferior)
+ (let ((a (inferior-eval '(apply * '(6 7)) inferior))
+ (b (inferior-eval '(@ (gnu packages base) coreutils)
+ inferior)))
+ (close-inferior inferior)
+ (list a (inferior-object? b))))))
+
+(test-equal "inferior-packages"
+ (take (sort (fold-packages (lambda (package lst)
+ (alist-cons (package-name package)
+ (package-version package)
+ lst))
+ '())
+ (lambda (x y)
+ (string<? (car x) (car y))))
+ 10)
+ (let* ((inferior (open-inferior %top-builddir
+ #:command "scripts/guix"))
+ (packages (inferior-packages inferior)))
+ (and (every string? (map inferior-package-synopsis packages))
+ (begin
+ (close-inferior inferior)
+ (take (sort (map (lambda (package)
+ (cons (inferior-package-name package)
+ (inferior-package-version package)))
+ packages)
+ (lambda (x y)
+ (string<? (car x) (car y))))
+ 10)))))
+
+(test-end "inferior")
diff --git a/tests/nar.scm b/tests/nar.scm
index 61646db964..9b5fb984b4 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -152,6 +152,66 @@
(test-begin "nar")
+(test-assert "write-file-tree + restore-file"
+ (let* ((file1 (search-path %load-path "guix.scm"))
+ (file2 (search-path %load-path "guix/base32.scm"))
+ (file3 "#!/bin/something")
+ (output (string-append %test-dir "/output")))
+ (dynamic-wind
+ (lambda () #t)
+ (lambda ()
+ (define-values (port get-bytevector)
+ (open-bytevector-output-port))
+ (write-file-tree "root" port
+ #:file-type+size
+ (match-lambda
+ ("root"
+ (values 'directory 0))
+ ("root/foo"
+ (values 'regular (stat:size (stat file1))))
+ ("root/lnk"
+ (values 'symlink 0))
+ ("root/dir"
+ (values 'directory 0))
+ ("root/dir/bar"
+ (values 'regular (stat:size (stat file2))))
+ ("root/dir/exe"
+ (values 'executable (string-length file3))))
+ #:file-port
+ (match-lambda
+ ("root/foo" (open-input-file file1))
+ ("root/dir/bar" (open-input-file file2))
+ ("root/dir/exe" (open-input-string file3)))
+ #:symlink-target
+ (match-lambda
+ ("root/lnk" "foo"))
+ #:directory-entries
+ (match-lambda
+ ("root" '("foo" "dir" "lnk"))
+ ("root/dir" '("bar" "exe"))))
+ (close-port port)
+
+ (rm-rf %test-dir)
+ (mkdir %test-dir)
+ (restore-file (open-bytevector-input-port (get-bytevector))
+ output)
+ (and (file=? (string-append output "/foo") file1)
+ (string=? (readlink (string-append output "/lnk"))
+ "foo")
+ (file=? (string-append output "/dir/bar") file2)
+ (string=? (call-with-input-file (string-append output "/dir/exe")
+ get-string-all)
+ file3)
+ (> (logand (stat:mode (lstat (string-append output "/dir/exe")))
+ #o100)
+ 0)
+ (equal? '("." ".." "bar" "exe")
+ (scandir (string-append output "/dir")))
+ (equal? '("." ".." "dir" "foo" "lnk")
+ (scandir output))))
+ (lambda ()
+ (false-if-exception (rm-rf %test-dir))))))
+
(test-assert "write-file supports non-file output ports"
(let ((input (string-append (dirname (search-path %load-path "guix.scm"))
"/guix"))
diff --git a/tests/opam.scm b/tests/opam.scm
new file mode 100644
index 0000000000..26832174a8
--- /dev/null
+++ b/tests/opam.scm
@@ -0,0 +1,118 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
+;;;
+;;; 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-opam)
+ #:use-module (guix import opam)
+ #:use-module (guix base32)
+ #:use-module (guix hash)
+ #:use-module (guix tests)
+ #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which))
+ #:use-module (srfi srfi-64)
+ #:use-module (web uri)
+ #:use-module (ice-9 match))
+
+(define test-url-file
+ "http: \"https://example.org/foo-1.0.0.tar.gz\"
+checksum: \"ac8920f39a8100b94820659bc2c20817\"")
+
+(define test-source-hash
+ "")
+
+(define test-urls
+ "repo ac8920f39a8100b94820659bc2c20817 0o644
+packages/foo/foo.1.0.0/url ac8920f39a8100b94820659bc2c20817 0o644
+packages/foo/foo.1.0.0/opam ac8920f39a8100b94820659bc2c20817 0o644
+packages/foo/foo.1.0.0/descr ac8920f39a8100b94820659bc2c20817 0o644")
+
+(define test-opam-file
+"opam-version: 1.2
+maintainer: \"Alice Doe\"
+authors: \"Alice Doe, John Doe\"
+homepage: \"https://example.org/\"
+bug-reports: \"https://example.org/bugs\"
+license: \"MIT\"
+dev-repo: \"https://example.org/git\"
+build: [
+ \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\"
+]
+build-test: [
+ \"ocaml\" \"pkg/pkg.ml\" \"build\" \"--pinned\" \"%{pinned}%\" \"--tests\" \"true\"
+]
+depends: [
+ \"alcotest\" {test & >= \"0.7.2\"}
+ \"ocamlbuild\" {build & >= \"0.9.2\"}
+]")
+
+(test-begin "opam")
+
+(test-assert "opam->guix-package"
+ ;; Replace network resources with sample data.
+ (mock ((guix import utils) url-fetch
+ (lambda (url file-name)
+ (match url
+ ("https://example.org/foo-1.0.0.tar.gz"
+ (begin
+ (mkdir-p "foo-1.0.0")
+ (system* "tar" "czvf" file-name "foo-1.0.0/")
+ (delete-file-recursively "foo-1.0.0")
+ (set! test-source-hash
+ (call-with-input-file file-name port-sha256))))
+ (_ (error "Unexpected URL: " url)))))
+ (mock ((guix http-client) http-fetch/cached
+ (lambda (url . rest)
+ (match (uri->string url)
+ ("https://opam.ocaml.org/urls.txt"
+ (values (open-input-string test-urls)
+ (string-length test-urls)))
+ (_ (error "Unexpected URL: " url)))))
+ (mock ((guix http-client) http-fetch
+ (lambda (url . rest)
+ (match url
+ ("https://opam.ocaml.org/packages/foo/foo.1.0.0/url"
+ (values (open-input-string test-url-file)
+ (string-length test-url-file)))
+ ("https://opam.ocaml.org/packages/foo/foo.1.0.0/opam"
+ (values (open-input-string test-opam-file)
+ (string-length test-opam-file)))
+ (_ (error "Unexpected URL: " url)))))
+ (match (opam->guix-package "foo")
+ (('package
+ ('name "ocaml-foo")
+ ('version "1.0.0")
+ ('source ('origin
+ ('method 'url-fetch)
+ ('uri "https://example.org/foo-1.0.0.tar.gz")
+ ('sha256
+ ('base32
+ (? string? hash)))))
+ ('build-system 'ocaml-build-system)
+ ('inputs
+ ('quasiquote
+ (("ocamlbuild" ('unquote 'ocamlbuild))
+ ("ocaml-alcotest" ('unquote 'ocaml-alcotest)))))
+ ('home-page "https://example.org/")
+ ('synopsis "")
+ ('description "")
+ ('license 'license:expat))
+ (string=? (bytevector->nix-base32-string
+ test-source-hash)
+ hash))
+ (x
+ (pk 'fail x #f)))))))
+
+(test-end "opam")
diff --git a/tests/pypi.scm b/tests/pypi.scm
index 74f13e9662..310c6c8f29 100644
--- a/tests/pypi.scm
+++ b/tests/pypi.scm
@@ -89,7 +89,7 @@ baz > 13.37")
(dummy-package "foo"
(source (dummy-origin
(uri
- "https://pypi.python.org/packages/a2/3b/4756e6a0ceb14e084042a2a65c615d68d25621c6fd446d0fc10d14c4ce7d/certbot-0.8.1.tar.gz"))))))
+ "https://pypi.org/packages/a2/3b/4756e6a0ceb14e084042a2a65c615d68d25621c6fd446d0fc10d14c4ce7d/certbot-0.8.1.tar.gz"))))))
(test-equal "guix-package->pypi-name, several URLs"
"cram"
@@ -120,7 +120,7 @@ baz > 13.37")
(mock ((guix http-client) http-fetch
(lambda (url . rest)
(match url
- ("https://pypi.python.org/pypi/foo/json"
+ ("https://pypi.org/pypi/foo/json"
(values (open-input-string test-json)
(string-length test-json)))
("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
@@ -182,7 +182,7 @@ baz > 13.37")
(mock ((guix http-client) http-fetch
(lambda (url . rest)
(match url
- ("https://pypi.python.org/pypi/foo/json"
+ ("https://pypi.org/pypi/foo/json"
(values (open-input-string test-json)
(string-length test-json)))
("https://example.com/foo-1.0.0-py2.py3-none-any.whl" #f)
diff --git a/tests/store-database.scm b/tests/store-database.scm
index fcae66e2de..4d91884250 100644
--- a/tests/store-database.scm
+++ b/tests/store-database.scm
@@ -32,7 +32,8 @@
(test-begin "store-database")
-(test-assert "register-path"
+(test-equal "register-path"
+ '(1 1)
(let ((file (string-append (%store-prefix) "/" (make-string 32 #\f)
"-fake")))
(when (valid-path? %store file)
@@ -50,7 +51,9 @@
(and (valid-path? %store file)
(equal? (references %store file) (list ref))
(null? (valid-derivers %store file))
- (null? (referrers %store file))))))
+ (null? (referrers %store file))
+ (list (stat:mtime (lstat file))
+ (stat:mtime (lstat ref)))))))
(test-equal "new database"
(list 1 2)
diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm
index 2361723199..4ca2ec0f61 100644
--- a/tests/store-deduplication.scm
+++ b/tests/store-deduplication.scm
@@ -47,6 +47,10 @@
(lambda (port)
(put-bytevector port data))))
identical)
+ ;; Make the parent of IDENTICAL read-only. This should not prevent
+ ;; deduplication for inserting its hard link.
+ (chmod (dirname (second identical)) #o544)
+
(call-with-output-file unique
(lambda (port)
(put-bytevector port (string->utf8 "This is unique."))))
diff --git a/tests/store.scm b/tests/store.scm
index afecec940a..47fab0df18 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -210,6 +210,52 @@
(valid-path? store path)
(file-exists? path)))))
+(test-equal "add-file-tree-to-store"
+ `(42
+ ("." directory #t)
+ ("./bar" directory #t)
+ ("./foo" directory #t)
+ ("./foo/a" regular "file a")
+ ("./foo/b" symlink "a")
+ ("./foo/c" directory #t)
+ ("./foo/c/p" regular "file p")
+ ("./foo/c/q" directory #t)
+ ("./foo/c/q/x" regular "#!/bin/sh\nexit 42")
+ ("./foo/c/q/y" symlink "..")
+ ("./foo/c/q/z" directory #t))
+ (let* ((tree `("file-tree" directory
+ ("foo" directory
+ ("a" regular (data "file a"))
+ ("b" symlink "a")
+ ("c" directory
+ ("p" regular (data ,(string->utf8 "file p")))
+ ("q" directory
+ ("x" executable
+ (data "#!/bin/sh\nexit 42"))
+ ("y" symlink "..")
+ ("z" directory))))
+ ("bar" directory)))
+ (result (add-file-tree-to-store %store tree)))
+ (cons (status:exit-val (system* (string-append result "/foo/c/q/x")))
+ (with-directory-excursion result
+ (map (lambda (file)
+ (let ((type (stat:type (lstat file))))
+ `(,file ,type
+ ,(match type
+ ((or 'regular 'executable)
+ (call-with-input-file file
+ get-string-all))
+ ('symlink (readlink file))
+ ('directory #t)))))
+ (find-files "." #:directories? #t))))))
+
+(test-equal "add-file-tree-to-store, flat"
+ "Hello, world!"
+ (let* ((tree `("flat-file" regular (data "Hello, world!")))
+ (result (add-file-tree-to-store %store tree)))
+ (and (file-exists? result)
+ (call-with-input-file result get-string-all))))
+
(test-assert "references"
(let* ((t1 (add-text-to-store %store "random1"
(random-text)))
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 0d07280b99..3e267c9f01 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -60,6 +60,19 @@
(any (cute member <> (mount-points))
'("/" "/proc" "/sys" "/dev")))
+(false-if-exception (delete-file temp-file))
+(test-equal "utime with AT_SYMLINK_NOFOLLOW"
+ '(0 0)
+ (begin
+ ;; Test libguile's utime with AT_SYMLINK_NOFOLLOW, which libguile does not
+ ;; define as of Guile 2.2.4.
+ (symlink "/nowhere" temp-file)
+ (utime temp-file 0 0 0 0 AT_SYMLINK_NOFOLLOW)
+ (let ((st (lstat temp-file)))
+ (delete-file temp-file)
+ ;; Note: 'utimensat' does not change 'ctime'.
+ (list (stat:mtime st) (stat:atime st)))))
+
(test-assert "swapon, ENOENT/EPERM"
(catch 'system-error
(lambda ()
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-06 05:52:45 +0000