diff options
| -rw-r--r-- | guix/build/graft.scm | 22 | ||||
| -rw-r--r-- | tests/grafts.scm | 34 |
2 files changed, 46 insertions, 10 deletions
diff --git a/guix/build/graft.scm b/guix/build/graft.scm index 16df169ec7..3dce486adf 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -164,15 +164,19 @@ bytevectors to the same value." ;; not to unget bytes that have already been written, because ;; that would cause them to be written again from the next ;; buffer. In practice, this case occurs when a replacement is - ;; made near the end of the buffer. - (let* ((unwritten (- end written)) - (unget-size (if (= end request-size) - (min hash-length unwritten) - 0)) - (write-size (- unwritten unget-size))) - (put-bytevector output buffer written write-size) - (unget-bytevector input buffer (+ written write-size) - unget-size) + ;; made near or beyond the end of the buffer. When REPLACEMENT + ;; went beyond END, we consume the extra bytes from INPUT. + (begin + (if (> written end) + (get-bytevector-n! input buffer 0 (- written end)) + (let* ((unwritten (- end written)) + (unget-size (if (= end request-size) + (min hash-length unwritten) + 0)) + (write-size (- unwritten unget-size))) + (put-bytevector output buffer written write-size) + (unget-bytevector input buffer (+ written write-size) + unget-size))) (loop))))))))) (define (rename-matching-files directory mapping) diff --git a/tests/grafts.scm b/tests/grafts.scm index 08f05c0f75..abb074d628 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -28,7 +28,9 @@ #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) - #:use-module (rnrs io ports)) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 vlist)) (define %store (open-connection-for-tests)) @@ -442,4 +444,34 @@ (and (file-exists? (string-append out "/p2/replacement")) (file-exists? (string-append out "/p2/p1/replacement"))))))) +(define buffer-size + ;; Must be equal to REQUEST-SIZE in 'replace-store-references'. + (expt 2 20)) + +(test-equal "replace-store-references, <http://bugs.gnu.org/28212>" + (string-append (make-string (- buffer-size 47) #\a) + "/gnu/store/" (make-string 32 #\8) + "-SoMeTHiNG" + (list->string (map integer->char (iota 77 33)))) + + ;; Create input data where the right-hand-size of the dash ("-something" + ;; here) goes beyond the end of the internal buffer of + ;; 'replace-store-references'. + (let* ((content (string-append (make-string (- buffer-size 47) #\a) + "/gnu/store/" (make-string 32 #\7) + "-something" + (list->string + (map integer->char (iota 77 33))))) + (replacement (alist->vhash + `((,(make-string 32 #\7) + . ,(string->utf8 (string-append + (make-string 32 #\8) + "-SoMeTHiNG"))))))) + (call-with-output-string + (lambda (output) + ((@@ (guix build graft) replace-store-references) + (open-input-string content) output + replacement + "/gnu/store"))))) + (test-end) |