diff options
Diffstat (limited to 'guix/utils.scm')
| -rw-r--r-- | guix/utils.scm | 129 |
1 files changed, 120 insertions, 9 deletions
diff --git a/guix/utils.scm b/guix/utils.scm index 68329ec915..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) @@ -70,7 +71,13 @@ call-with-temporary-output-file with-atomic-file-output fold2 - filtered-port)) + + filtered-port + compressed-port + decompressed-port + call-with-decompressed-port + compressed-output-port + call-with-compressed-output-port)) ;;; @@ -155,18 +162,29 @@ COMMAND (a list). In addition, return a list of PIDs that the caller must wait. When INPUT is a file port, it must be unbuffered; otherwise, any buffered data is lost." (let loop ((input input) - (pids '())) + (pids '())) (if (file-port? input) (match (pipe) ((in . out) (match (primitive-fork) (0 - (close-port in) - (close-port (current-input-port)) - (dup2 (fileno input) 0) - (close-port (current-output-port)) - (dup2 (fileno out) 1) - (apply execl (car command) command)) + (dynamic-wind + (const #f) + (lambda () + (close-port in) + (close-port (current-input-port)) + (dup2 (fileno input) 0) + (close-port (current-output-port)) + (dup2 (fileno out) 1) + (catch 'system-error + (lambda () + (apply execl (car command) command)) + (lambda args + (format (current-error-port) + "filtered-port: failed to execute '~{~a ~}': ~a~%" + command (strerror (system-error-errno args)))))) + (lambda () + (primitive-_exit 1)))) (child (close-port out) (values in (cons child pids)))))) @@ -184,11 +202,104 @@ buffered data is lost." (dump-port input out)) (lambda () (false-if-exception (close out)) - (primitive-exit 0)))) + (primitive-_exit 0)))) (child (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)))) + +(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 +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)))) + +(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. |