diff options
| -rw-r--r-- | .dir-locals.el | 2 | ||||
| -rw-r--r-- | guix/utils.scm | 37 | ||||
| -rw-r--r-- | tests/utils.scm | 27 |
3 files changed, 48 insertions, 18 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 03d9a4ec8d..22ade9f8a5 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -22,6 +22,8 @@ (eval . (put 'with-error-handling 'scheme-indent-function 0)) (eval . (put 'with-mutex 'scheme-indent-function 1)) (eval . (put 'with-atomic-file-output 'scheme-indent-function 1)) + (eval . (put 'call-with-compressed-output-port 'scheme-indent-function 2)) + (eval . (put 'call-with-decompressed-port 'scheme-indent-function 2)) (eval . (put 'syntax-parameterize 'scheme-indent-function 1)) (eval . (put 'with-monad 'scheme-indent-function 1)) diff --git a/guix/utils.scm b/guix/utils.scm index 44060c46b5..7306c6011d 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -21,6 +21,7 @@ #:use-module (guix config) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-39) #:use-module (srfi srfi-60) @@ -74,7 +75,9 @@ filtered-port compressed-port decompressed-port - compressed-output-port)) + call-with-decompressed-port + compressed-output-port + call-with-compressed-output-port)) ;;; @@ -224,6 +227,22 @@ a symbol such as 'xz." ('gzip (filtered-port `(,%gzip "-c") input)) (else (error "unsupported compression scheme" compression)))) +(define (call-with-decompressed-port compression port proc) + "Call PROC with a wrapper around PORT, a file port, that decompresses data +read from PORT according to COMPRESSION, a symbol such as 'xz. PORT is closed +as soon as PROC's dynamic extent is entered." + (let-values (((decompressed pids) + (decompressed-port compression port))) + (dynamic-wind + (const #f) + (lambda () + (close-port port) + (proc decompressed)) + (lambda () + (close-port decompressed) + (unless (every (compose zero? cdr waitpid) pids) + (error "decompressed-port failure" pids)))))) + (define (filtered-output-port command output) "Return an output port. Data written to that port is filtered through COMMAND and written to OUTPUT, an output file port. In addition, return a @@ -265,6 +284,22 @@ of PIDs to wait for." ('gzip (filtered-output-port `(,%gzip "-c") output)) (else (error "unsupported compression scheme" compression)))) +(define (call-with-compressed-output-port compression port proc) + "Call PROC with a wrapper around PORT, a file port, that compresses data +that goes to PORT according to COMPRESSION, a symbol such as 'xz. PORT is +closed as soon as PROC's dynamic extent is entered." + (let-values (((compressed pids) + (compressed-output-port compression port))) + (dynamic-wind + (const #f) + (lambda () + (close-port port) + (proc compressed)) + (lambda () + (close-port compressed) + (unless (every (compose zero? cdr waitpid) pids) + (error "compressed-output-port failure" pids)))))) + ;;; ;;; Nixpkgs. diff --git a/tests/utils.scm b/tests/utils.scm index adbfdf55ba..1da847689c 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -162,23 +162,16 @@ (equal? (get-bytevector-all decompressed) data))))) (false-if-exception (delete-file temp-file)) -(test-equal "compressed-output-port + decompressed-port" - '((0) "Hello, compressed port!") - (let ((text "Hello, compressed port!") - (output (open-file temp-file "w0b"))) - (let-values (((compressed pids) - (compressed-output-port 'xz output))) - (display text compressed) - (close-port compressed) - (close-port output) - (and (every (compose zero? cdr waitpid) pids) - (let*-values (((input) - (open-file temp-file "r0b")) - ((decompressed pids) - (decompressed-port 'xz input))) - (let ((str (get-string-all decompressed))) - (list (map (compose cdr waitpid) pids) - str))))))) +(test-assert "compressed-output-port + decompressed-port" + (let* ((file (search-path %load-path "guix/derivations.scm")) + (data (call-with-input-file file get-bytevector-all))) + (call-with-compressed-output-port 'xz (open-file temp-file "w0b") + (lambda (compressed) + (put-bytevector compressed data))) + + (bytevector=? data + (call-with-decompressed-port 'xz (open-file temp-file "r0b") + get-bytevector-all)))) (false-if-exception (delete-file temp-file)) (test-equal "fcntl-flock wait" |