#:use-module (guix monads)
#:use-module (guix grafts)
#:use-module ((guix gexp) #:select (local-file local-file-file))
- #:use-module ((guix utils)
+ #:use-module (guix utils)
+ #:use-module ((guix diagnostics)
;; Rename the 'location' binding to allow proper syntax
;; matching when setting the 'location' field of a package.
#:renamer (lambda (name)
(cond ((eq? name 'location) 'make-location)
(else name))))
- #:use-module ((gcrypt hash) #:hide (sha256))
+ #:use-module ((gcrypt hash) #:prefix gcrypt:)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix grafts)
(uri "unused://")
(file-name "origin-sha512")
(hash (content-hash
- (bytevector-hash (string->utf8 "hello")
- (hash-algorithm sha512))
+ (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)))
+(test-equal "package-source-derivation, origin, sha3-512"
+ "hello, sha3"
+ (let* ((bash (search-bootstrap-binary "bash" (%current-system)))
+ (builder (add-text-to-store %store "my-fixed-builder.sh"
+ "echo -n hello, sha3 > $out" '()))
+ (method (lambda* (url hash-algo hash #:optional name
+ #:rest rest)
+ (and (eq? hash-algo 'sha3-512)
+ (raw-derivation name bash (list builder)
+ #:sources (list builder)
+ #:hash hash
+ #:hash-algo hash-algo))))
+ (source (origin
+ (method method)
+ (uri "unused://")
+ (file-name "origin-sha3")
+ (hash (content-hash
+ (gcrypt:bytevector-hash (string->utf8 "hello, sha3")
+ (gcrypt:lookup-hash-algorithm
+ 'sha3-512))
+ sha3-512))))
+ (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"
(string=? (derivation->output-path drv)
(package-output %store package "out")))))
-(test-assert "patch not found yields a run-time error"
- (guard (c ((condition-has-type? c &message)
- (and (string-contains (condition-message c)
- "does-not-exist.patch")
- (string-contains (condition-message c)
- "not found"))))
+(test-equal "patch not found yields a run-time error"
+ '("~a: patch not found\n" "does-not-exist.patch")
+ (guard (c ((formatted-message? c)
+ (cons (formatted-message-string c)
+ (formatted-message-arguments c))))
(let ((p (package
(inherit (dummy-package "p"))
(source (origin
(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:
(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))
(("dep" package)
(eq? package dep)))))
+(test-assert "package->bag, sensitivity to %current-system"
+ (let* ((dep (dummy-package "dep"
+ (propagated-inputs (if (string=? (%current-system)
+ "i586-gnu")
+ `(("libxml2" ,libxml2))
+ '()))))
+ (pkg (dummy-package "foo"
+ (native-inputs `(("dep" ,dep)))))
+ (bag (package->bag pkg (%current-system) "i586-gnu")))
+ (equal? (parameterize ((%current-system "x86_64-linux"))
+ (bag-transitive-inputs bag))
+ (parameterize ((%current-system "i586-gnu"))
+ (bag-transitive-inputs bag)))))
+
(test-assert "package->bag, sensitivity to %current-target-system"
(let* ((dep (dummy-package "dep"
(propagated-inputs (if (%current-target-system)
result))
'()))))))
+ (define (find-duplicates l)
+ (match l
+ (() '())
+ ((head . tail)
+ (if (member head tail)
+ (cons head (find-duplicates tail))
+ (find-duplicates tail)))))
+
+ (pk (find-duplicates from-cache))
(and (equal? (delete-duplicates from-cache) from-cache)
(lset= equal? no-cache from-cache))))