aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-03-22 21:58:23 +0100
committerLudovic Courtès <ludo@gnu.org>2014-03-22 22:57:09 +0100
commit7a8024a33ad862fdbc8ae741f0a6f5338cb5b82b (patch)
treec2ab108d3f49f4ead6f964ae46e1c0c3678df66c
parent443eb4e9506026094f5e0dadc3e11d3cf7a86a24 (diff)
downloadguix-7a8024a33ad862fdbc8ae741f0a6f5338cb5b82b.tar
guix-7a8024a33ad862fdbc8ae741f0a6f5338cb5b82b.tar.gz
utils: Add 'decompressed-port' and 'compressed-port'.
* guix/utils.scm (decompressed-port, compressed-port): New procedures. * guix/scripts/substitute-binary.scm (decompressed-port): Remove. (guix-substitute-binary): Pass a symbol or #f as the first argument to 'decompress-port'. * tests/utils.scm ("compressed-port, decompressed-port, non-file"): New test.
-rwxr-xr-xguix/scripts/substitute-binary.scm13
-rw-r--r--guix/utils.scm25
-rw-r--r--tests/utils.scm11
3 files changed, 37 insertions, 12 deletions
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 7ac12ddef2..4e49b0c3ac 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -400,16 +400,6 @@ indefinitely."
(call-with-output-file expiry-file
(cute write (time-second now) <>))))
-(define (decompressed-port compression input)
- "Return an input port where INPUT is decompressed according to COMPRESSION,
-along with a list of PIDs to wait for."
- (match compression
- ("none" (values input '()))
- ("bzip2" (filtered-port `(,%bzip2 "-dc") input))
- ("xz" (filtered-port `(,%xz "-dc") input))
- ("gzip" (filtered-port `(,%gzip "-dc") input))
- (else (error "unsupported compression scheme" compression))))
-
(define (progress-report-port report-progress port)
"Return a port that calls REPORT-PROGRESS every time something is read from
PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
@@ -598,7 +588,8 @@ substituter disabled~%")
(current-error-port))))
(progress-report-port progress raw)))
((input pids)
- (decompressed-port (narinfo-compression narinfo)
+ (decompressed-port (and=> (narinfo-compression narinfo)
+ string->symbol)
progress)))
;; Unpack the Nar at INPUT into DESTINATION.
(restore-file input destination)
diff --git a/guix/utils.scm b/guix/utils.scm
index 15a4390074..f786c83f47 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -70,7 +70,10 @@
call-with-temporary-output-file
with-atomic-file-output
fold2
- filtered-port))
+
+ filtered-port
+ compressed-port
+ decompressed-port))
;;;
@@ -200,6 +203,26 @@ buffered data is lost."
(close-port out)
(loop in (cons child pids)))))))))
+(define (decompressed-port compression input)
+ "Return an input port where INPUT is decompressed according to COMPRESSION,
+a symbol such as 'xz."
+ (match compression
+ ((or #f 'none) (values input '()))
+ ('bzip2 (filtered-port `(,%bzip2 "-dc") input))
+ ('xz (filtered-port `(,%xz "-dc") input))
+ ('gzip (filtered-port `(,%gzip "-dc") input))
+ (else (error "unsupported compression scheme" compression))))
+
+(define (compressed-port compression input)
+ "Return an input port where INPUT is decompressed according to COMPRESSION,
+a symbol such as 'xz."
+ (match compression
+ ((or #f 'none) (values input '()))
+ ('bzip2 (filtered-port `(,%bzip2 "-c") input))
+ ('xz (filtered-port `(,%xz "-c") input))
+ ('gzip (filtered-port `(,%gzip "-c") input))
+ (else (error "unsupported compression scheme" compression))))
+
;;;
;;; Nixpkgs.
diff --git a/tests/utils.scm b/tests/utils.scm
index 85daa3db91..39cad701b8 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -150,6 +150,17 @@
(any (compose (negate zero?) cdr waitpid)
pids))))
+(test-assert "compressed-port, decompressed-port, non-file"
+ (let ((data (call-with-input-file (search-path %load-path "guix.scm")
+ get-bytevector-all)))
+ (let*-values (((compressed pids1)
+ (compressed-port 'xz (open-bytevector-input-port data)))
+ ((decompressed pids2)
+ (decompressed-port 'xz compressed)))
+ (and (every (compose zero? cdr waitpid)
+ (append pids1 pids2))
+ (equal? (get-bytevector-all decompressed) data)))))
+
(false-if-exception (delete-file temp-file))
(test-equal "fcntl-flock wait"
42 ; the child's exit status