From e3e20738c22fb6d75c89401b189839f927eede46 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 19:37:40 +0200 Subject: [PATCH] tar: Handle stdin, stdout. * gash/ustar.scm (list-ustar-port, extract-ustar-port, write-ustar-port): New function. * gash/bournish-commands.scm (tar-command): Use them. --- gash/bournish-commands.scm | 36 ++++++++++++++------- gash/ustar.scm | 64 ++++++++++++++++++++++++++------------ 2 files changed, 68 insertions(+), 32 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index 5758c96..9b8d70d 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -393,7 +393,7 @@ Options: (create? (option-ref options 'create #f)) (list? (option-ref options 'list #f)) (extract? (option-ref options 'extract #f)) - (file (option-ref options 'file "/dev/stdout")) + (file (option-ref options 'file "-")) (files (option-ref options '() '())) (help? (option-ref options 'help #f)) (usage? (and (not help?) (not (or (and create? (pair? files)) @@ -426,19 +426,31 @@ Usage: tar [OPTION]... [FILE]... (mtime (and=> (option-ref options 'mtime #f) string->number)) (numeric-owner? (option-ref options 'numeric-owner? #f)) (owner (and=> (option-ref options 'owner #f) string->number))) - (apply create-ustar-archive - `(,file - ,files - ,@(if group `(#:group ,group) '()) - ,@(if mtime `(#:mtime ,mtime) '()) - ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) - ,@(if owner `(#:owner ,owner) '()) - ,@(if owner `(#:owner ,owner) '()) - #:verbosity ,verbosity)))) + (if (equal? file "-") + (apply write-ustar-port (current-output-port) + `(,file + ,files + ,@(if group `(#:group ,group) '()) + ,@(if mtime `(#:mtime ,mtime) '()) + ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) + ,@(if owner `(#:owner ,owner) '()) + ,@(if owner `(#:owner ,owner) '()) + #:verbosity ,verbosity)) + (apply write-ustar-archive + `(,file + ,files + ,@(if group `(#:group ,group) '()) + ,@(if mtime `(#:mtime ,mtime) '()) + ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) + ,@(if owner `(#:owner ,owner) '()) + ,@(if owner `(#:owner ,owner) '()) + #:verbosity ,verbosity))))) (extract? - (extract-ustar-archive file files #:verbosity verbosity)) + (if (equal? file "-") (read-ustar-port (current-input-port) files #:verbosity verbosity) + (read-ustar-archive file files #:verbosity verbosity))) (list? - (list-ustar-archive file files #:verbosity (1+ verbosity))))))) + (if (equal? file "-") (list-ustar-port (current-input-port) files #:verbosity (1+ verbosity)) + (list-ustar-archive file files #:verbosity (1+ verbosity)))))))) (define (compress-command . args) (lambda _ diff --git a/gash/ustar.scm b/gash/ustar.scm index 215fe54..a1d1d65 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -34,9 +34,12 @@ #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (gash guix-build-utils) - #:export (create-ustar-archive - extract-ustar-archive - list-ustar-archive)) + #:export (read-ustar-archive + read-ustar-port + write-ustar-archive + write-ustar-port + list-ustar-archive + list-ustar-port)) (define (fmt-error fmt . args) (error (apply format #f fmt args))) @@ -492,34 +495,52 @@ (display file-name)) (newline))) -(define* (create-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity) +(define* (write-ustar-port out files #:key group mtime numeric-owner? owner verbosity) (catch #t (lambda () - (call-with-port* (open-file file-name "wb") - (lambda (out) - (for-each - (cut write-ustar-file out <> - #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity) - files) - (write-ustar-footer out)))) + (for-each + (cut write-ustar-file out <> + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity) + files) + (write-ustar-footer out)) (lambda (key subr message args . rest) (false-if-exception (delete-file file-name)) (format (current-error-port) "ERROR: ~a\n" (apply format #f message args)) (exit 1)))) -(define* (extract-ustar-archive file-name files #:key (extract? #t) verbosity) +(define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity) (catch #t + (lambda () + (call-with-port* (open-file file-name "wb") + (cut write-ustar-port <> files + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity))) + (lambda (key subr message args . rest) + (false-if-exception (delete-file file-name)) + (format (current-error-port) "ERROR: ~a\n" + (apply format #f message args)) + (exit 1)))) + +(define* (extract-ustar-port in files #:key (extract? #t) verbosity) + (catch #t + (lambda () + (let loop ((header (read-ustar-header in))) + (when (and header + (not (eof-object? header))) + (unless (zero? verbosity) + (display-header header #:verbose? (> verbosity 1))) + (extract-ustar-file in header #:extract? extract?) + (loop (read-ustar-header in))))) + (lambda (key subr message args . rest) + (format (current-error-port) "ERROR: ~a\n" + (apply format #f message args)) + (exit 1)))) + +(define* (extract-ustar-archive file-name files #:key (extract? #t) verbosity) + (catch 'foo (lambda () (call-with-port* (open-file file-name "rb") - (lambda (in) - (let loop ((header (read-ustar-header in))) - (when (and header - (not (eof-object? header))) - (unless (zero? verbosity) - (display-header header #:verbose? (> verbosity 1))) - (extract-ustar-file in header #:extract? extract?) - (loop (read-ustar-header in))))))) + (cut extract-ustar-port <> files #:extract? extract? verbosity))) (lambda (key subr message args . rest) (format (current-error-port) "ERROR: ~a\n" (apply format #f message args)) @@ -528,6 +549,9 @@ (define* (list-ustar-archive file-name files #:key verbosity) (extract-ustar-archive file-name files #:extract? #f #:verbosity verbosity)) +(define* (list-ustar-port in file-name files #:key verbosity) + (extract-ustar-port file-name files #:extract? #f #:verbosity verbosity)) + ;;; Local Variables: ;;; mode: scheme ;;; eval: (put 'call-with-port* 'scheme-indent-function 1)