diff options
| -rw-r--r-- | doc/guix.texi | 8 | ||||
| -rw-r--r-- | guix/build/graft.scm | 43 | ||||
| -rw-r--r-- | tests/grafts.scm | 19 |
3 files changed, 49 insertions, 21 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index 73570277f6..9bd8b43582 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11782,10 +11782,10 @@ minute for an ``average'' package on a recent machine. Grafting is recursive: when an indirect dependency requires grafting, then grafting ``propagates'' up to the package that the user is installing. -Currently, the graft and the package it replaces (@var{bash-fixed} and -@var{bash} in the example above) must have the exact same @code{name} -and @code{version} fields. This restriction mostly comes from the fact -that grafting works by patching files, including binary files, directly. +Currently, the length of the name and version of the graft and that of +the package it replaces (@var{bash-fixed} and @var{bash} in the example +above) must be equal. This restriction mostly comes from the fact that +grafting works by patching files, including binary files, directly. Other restrictions may apply: for instance, when adding a graft to a package providing a shared library, the original shared library and its replacement must have the same @code{SONAME} and be binary-compatible. diff --git a/guix/build/graft.scm b/guix/build/graft.scm index f85d485554..b08b65b7cf 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -20,7 +20,6 @@ (define-module (guix build graft) #:use-module (guix build utils) #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (ice-9 threads) @@ -58,7 +57,9 @@ #:optional (store (%store-directory))) "Read data from INPUT, replacing store references according to REPLACEMENT-TABLE, and writing the result to OUTPUT. REPLACEMENT-TABLE is a -vhash that maps strings (original hashes) to bytevectors (replacement hashes). +vhash that maps strings (original hashes) to bytevectors (replacement strings +comprising the replacement hash, a dash, and a string). + Note: We use string keys to work around the fact that guile-2.0 hashes all bytevectors to the same value." @@ -130,16 +131,18 @@ bytevectors to the same value." ;; that have not yet been written. (put-bytevector output buffer written (- i hash-length written)) - ;; Now write the replacement hash. + ;; Now write the replacement string. (put-bytevector output replacement) ;; Since the byte at position 'i' is a dash, ;; which is not a nix-base32 char, the earliest ;; position where the next hash might start is ;; i+1, and the earliest position where the ;; following dash might start is (+ i 1 - ;; hash-length). Also, we have now written up to - ;; position 'i' in the buffer. - (scan-from (+ i 1 hash-length) i))) + ;; hash-length). Also, increase the write + ;; position to account for REPLACEMENT. + (let ((len (bytevector-length replacement))) + (scan-from (+ i 1 len) + (+ i (- len hash-length)))))) ;; If the byte at position 'i' is a nix-base32 char, ;; then the dash we're looking for might be as early as ;; the following byte, so we can only advance by 1. @@ -213,26 +216,32 @@ an exception is caught." file name pairs." (define hash-mapping + ;; List of hash/replacement pairs, where the hash is a nix-base32 string + ;; and the replacement is a string that includes the replacement's name, + ;; like "r837zajjc1q8z9hph4b6860a9c05blyy-openssl-1.0.2j". (let* ((prefix (string-append store "/")) (start (string-length prefix)) (end (+ start hash-length))) (define (valid-hash? h) (every nix-base32-char? (string->list h))) - (define (valid-suffix? s) - (string-prefix? "-" s)) - (define (hash+suffix s) + (define (hash+rest s) (and (< end (string-length s)) - (let ((hash (substring s start end)) - (suffix (substring s end))) + (let ((hash (substring s start end)) + (all (substring s start))) (and (string-prefix? prefix s) - (valid-hash? hash) - (valid-suffix? suffix) - (list hash suffix))))) + (valid-hash? hash) + (eqv? #\- (string-ref s end)) + (list hash all))))) + (map (match-lambda - (((= hash+suffix (origin-hash suffix)) + (((= hash+rest (origin-hash origin-string)) . - (= hash+suffix (replacement-hash suffix))) - (cons origin-hash (string->utf8 replacement-hash))) + (= hash+rest (replacement-hash replacement-string))) + (unless (= (string-length origin-string) + (string-length replacement-string)) + (error "replacement length differs from the original length" + origin-string replacement-string)) + (cons origin-hash (string->utf8 replacement-string))) ((origin . replacement) (error "invalid replacement" origin replacement))) mapping))) diff --git a/tests/grafts.scm b/tests/grafts.scm index 13c56750ed..f2ff839fd8 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -80,6 +80,25 @@ (string=? (readlink (string-append grafted "/self")) grafted)))))) +(test-assert "graft-derivation, grafted item uses a different name" + (let* ((build `(begin + (mkdir %output) + (chdir %output) + (symlink %output "self") + (symlink ,%bash "sh"))) + (orig (build-expression->derivation %store "grafted" build + #:inputs `(("a" ,%bash)))) + (repl (add-text-to-store %store "BaSH" "fake bash")) + (grafted (graft-derivation %store orig + (list (graft + (origin %bash) + (replacement repl)))))) + (and (build-derivations %store (list grafted)) + (let ((grafted (derivation->output-path grafted))) + (and (string=? (readlink (string-append grafted "/sh")) repl) + (string=? (readlink (string-append grafted "/self")) + grafted)))))) + ;; Make sure 'derivation-file-name' always gets to see an absolute file name. (fluid-set! %file-port-name-canonicalization 'absolute) |