Merge branch 'master' into core-updates

1 files changed, 85 insertions, 1 deletions

diff --git a/tests/packages.scm b/tests/packages.scm
index c528d2080c..c7b6f669b5 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -29,7 +29,7 @@
                 #:renamer (lambda (name)
                             (cond ((eq? name 'location) 'make-location)
                                   (else name))))
-  #:use-module (gcrypt hash)
+  #:use-module ((gcrypt hash) #:prefix gcrypt:)
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix grafts)
@@ -51,6 +51,7 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
+  #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 regex)
@@ -497,6 +498,32 @@
                      (search-path %load-path "guix/base32.scm")
                    get-bytevector-all)))))
 
+(test-equal "package-source-derivation, origin, sha512"
+  "hello"
+  (let* ((bash    (search-bootstrap-binary "bash" (%current-system)))
+         (builder (add-text-to-store %store "my-fixed-builder.sh"
+                                     "echo -n hello > $out" '()))
+         (method  (lambda* (url hash-algo hash #:optional name
+                                #:rest rest)
+                    (and (eq? hash-algo 'sha512)
+                         (raw-derivation name bash (list builder)
+                                         #:sources (list builder)
+                                         #:hash hash
+                                         #:hash-algo hash-algo))))
+         (source  (origin
+                    (method method)
+                    (uri "unused://")
+                    (file-name "origin-sha512")
+                    (hash (content-hash
+                           (gcrypt:bytevector-hash (string->utf8 "hello")
+                                                   (gcrypt:lookup-hash-algorithm
+                                                    'sha512))
+                           sha512))))
+         (drv    (package-source-derivation %store source))
+         (output (derivation->output-path drv)))
+    (build-derivations %store (list drv))
+    (call-with-input-file output get-string-all)))
+
 (unless (network-reachable?) (test-skip 1))
 (test-equal "package-source-derivation, snippet"
   "OK"
@@ -873,6 +900,30 @@
                                                          (replacement #f))))
                     (replacement (package-derivation %store new)))))))
 
+(test-assert "package-grafts, dependency on several outputs"
+  ;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
+  (letrec* ((p0  (dummy-package "p0"
+                   (version "1.0")
+                   (replacement p0*)
+                   (arguments '(#:implicit-inputs? #f))
+                   (outputs '("out" "lib"))))
+            (p0* (package (inherit p0) (version "1.1")))
+            (p1  (dummy-package "p1"
+                   (arguments '(#:implicit-inputs? #f))
+                   (inputs `(("p0" ,p0)
+                             ("p0:lib" ,p0 "lib"))))))
+    (lset= equal? (pk (package-grafts %store p1))
+           (list (graft
+                   (origin (package-derivation %store p0))
+                   (origin-output "out")
+                   (replacement (package-derivation %store p0*))
+                   (replacement-output "out"))
+                 (graft
+                   (origin (package-derivation %store p0))
+                   (origin-output "lib")
+                   (replacement (package-derivation %store p0*))
+                   (replacement-output "lib"))))))
+
 (test-assert "replacement also grafted"
   ;; We build a DAG as below, where dotted arrows represent replacements and
   ;; solid arrows represent dependencies:
@@ -979,6 +1030,39 @@
           (assoc-ref (bag-build-inputs bag) "libc")
           (assoc-ref (bag-build-inputs bag) "coreutils"))))
 
+(test-assert "package->bag, sensitivity to %current-target-system"
+  ;; https://bugs.gnu.org/41713
+  (let* ((lower (lambda* (name #:key system target inputs native-inputs
+                               #:allow-other-keys)
+                  (and (not target)
+                       (bag (name name) (system system) (target target)
+                            (build-inputs native-inputs)
+                            (host-inputs inputs)
+                            (build (lambda* (store name inputs
+                                                   #:key system target
+                                                   #:allow-other-keys)
+                                     (build-expression->derivation
+                                      store "foo" '(mkdir %output))))))))
+         (bs    (build-system
+                  (name 'build-system-without-cross-compilation)
+                  (description "Does not support cross compilation.")
+                  (lower lower)))
+         (dep   (dummy-package "dep" (build-system bs)))
+         (pkg   (dummy-package "example"
+                  (native-inputs `(("dep" ,dep)))))
+         (do-not-build (lambda (continue store lst . _) lst)))
+    (equal? (with-build-handler do-not-build
+              (parameterize ((%current-target-system "powerpc64le-linux-gnu")
+                             (%graft? #t))
+                (package-cross-derivation %store pkg
+                                          (%current-target-system)
+                                          #:graft? #t)))
+            (with-build-handler do-not-build
+              (package-cross-derivation %store
+                                        (package (inherit pkg))
+                                        "powerpc64le-linux-gnu"
+                                        #:graft? #t)))))
+
 (test-equal "package->bag, cross-compilation"
   `(,(%current-system) "foo86-hurd"
     (,(package-source gnu-make))