aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/utils.scm44
-rw-r--r--tests/utils.scm19
2 files changed, 62 insertions, 1 deletions
diff --git a/guix/utils.scm b/guix/utils.scm
index f786c83f47..44060c46b5 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -73,7 +73,8 @@
filtered-port
compressed-port
- decompressed-port))
+ decompressed-port
+ compressed-output-port))
;;;
@@ -223,6 +224,47 @@ a symbol such as 'xz."
('gzip (filtered-port `(,%gzip "-c") input))
(else (error "unsupported compression scheme" compression))))
+(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
+list of PIDs to wait for. OUTPUT must be unbuffered; otherwise, any buffered
+data is lost."
+ (match (pipe)
+ ((in . out)
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (close-port out)
+ (close-port (current-input-port))
+ (dup2 (fileno in) 0)
+ (close-port (current-output-port))
+ (dup2 (fileno output) 1)
+ (catch 'system-error
+ (lambda ()
+ (apply execl (car command) command))
+ (lambda args
+ (format (current-error-port)
+ "filtered-output-port: failed to execute '~{~a ~}': ~a~%"
+ command (strerror (system-error-errno args))))))
+ (lambda ()
+ (primitive-_exit 1))))
+ (child
+ (close-port in)
+ (values out (list child)))))))
+
+(define (compressed-output-port compression output)
+ "Return an output port whose input is compressed according to COMPRESSION,
+a symbol such as 'xz, and then written to OUTPUT. In addition return a list
+of PIDs to wait for."
+ (match compression
+ ((or #f 'none) (values output '()))
+ ('bzip2 (filtered-output-port `(,%bzip2 "-c") output))
+ ('xz (filtered-output-port `(,%xz "-c") output))
+ ('gzip (filtered-output-port `(,%gzip "-c") output))
+ (else (error "unsupported compression scheme" compression))))
+
;;;
;;; Nixpkgs.
diff --git a/tests/utils.scm b/tests/utils.scm
index 39cad701b8..adbfdf55ba 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -162,6 +162,25 @@
(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)))))))
+
+(false-if-exception (delete-file temp-file))
(test-equal "fcntl-flock wait"
42 ; the child's exit status
(let ((file (open-file temp-file "w0")))