andrius
/
gash
mirror of https://git.savannah.gnu.org/git/gash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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.
This commit is contained in:
Jan Nieuwenhuizen 2018-10-27 19:37:40 +02:00
parent 8b56dcc2ab
commit e3e20738c2
2 changed files with 68 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
gash/bournish-commands.scm
View File

@ -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 _

64
gash/ustar.scm
View File

@ -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)