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

tar: Support --list and --verbose. 

* gash/ustar.scm (extract-ustar-file): Add keyword argument: extract?
(extract-ustar-archive): Add keyword arguments: extract?, verbose?:
(display-rwx, display-header, list-ustar-archive): New function
* gash/bournish-commands.scm (tar-command): Support --list, --verbose.
This commit is contained in:
Jan Nieuwenhuizen 2018-10-27 00:42:50 +02:00
parent 463b71acc9
commit 28d62b6169
2 changed files with 100 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gash/bournish-commands.scm
View File

@ -364,6 +364,10 @@ Options:
(for-each display-match matches) (for-each display-match matches)
0))))))))) 0)))))))))
(define (multi-opt options name)
(let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o)))))
(filter-map opt? options)))
(define (tar-command . args) (define (tar-command . args)
(lambda _ (lambda _
(let* ((option-spec (let* ((option-spec
@ -373,19 +377,24 @@ Options:
(file (single-char #\f) (value #t)) (file (single-char #\f) (value #t))
(help (single-char #\h)) (help (single-char #\h))
(mtime (value #t)) (mtime (value #t))
(list (single-char #\t))
(numeric-owner?) (numeric-owner?)
(owner (value #t)) (owner (value #t))
(sort (value #t)) (sort (value #t))
(version (single-char #\V)))) (verbose (single-char #\v))
(version (single-char #\V))))
(args (cons "tar" args)) (args (cons "tar" args))
(options (getopt-long args option-spec)) (options (getopt-long args option-spec))
(create? (option-ref options 'create #f)) (create? (option-ref options 'create #f))
(list? (option-ref options 'list #f))
(extract? (option-ref options 'extract #f)) (extract? (option-ref options 'extract #f))
(file (option-ref options 'file "/dev/stdout")) (file (option-ref options 'file "/dev/stdout"))
(files (option-ref options '() '())) (files (option-ref options '() '()))
(help? (option-ref options 'help #f)) (help? (option-ref options 'help #f))
(usage? (and (not help?) (not (or (and create? (pair? files)) extract?)))) (usage? (and (not help?) (not (or (and create? (pair? files))
(version? (option-ref options 'version #f))) extract? list?))))
(verbosity (length (multi-opt options 'verbose)))
(version? (option-ref options 'version #f)))
(cond ((or help? usage?) (format (if usage? (current-error-port) #t) (cond ((or help? usage?) (format (if usage? (current-error-port) #t)
"\ "\
Usage: tar [OPTION]... [FILE]... Usage: tar [OPTION]... [FILE]...
@ -398,7 +407,9 @@ Usage: tar [OPTION]... [FILE]...
--owner=NAME force NAME as owner for added files --owner=NAME force NAME as owner for added files
--sort=ORDER directory sorting order: none (default), name or --sort=ORDER directory sorting order: none (default), name or
inode inode
-t, --list list the contents of an archive
-V, --version display version -V, --version display version
-v, --verbose verbosely list files processed
-x, --extract extract files from an archive -x, --extract extract files from an archive
") ")
(exit (if usage? 2 0))) (exit (if usage? 2 0)))
@ -416,9 +427,13 @@ Usage: tar [OPTION]... [FILE]...
,@(if group `(#:group ,group) '()) ,@(if group `(#:group ,group) '())
,@(if mtime `(#:mtime ,mtime) '()) ,@(if mtime `(#:mtime ,mtime) '())
,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '())
,@(if owner `(#:owner ,owner) '()))))) ,@(if owner `(#:owner ,owner) '())
,@(if owner `(#:owner ,owner) '())
#:verbosity ,verbosity))))
(extract? (extract?
(extract-ustar-archive file files)))))) (extract-ustar-archive file files #:verbosity verbosity))
(list?
(list-ustar-archive file files #:verbosity (1+ verbosity)))))))
(define %bournish-commands (define %bournish-commands
`( `(

120
gash/ustar.scm
View File

@ -26,8 +26,9 @@
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (gash guix-build-utils) #:use-module (gash guix-build-utils)
#:export (extract-ustar-archive #:export (create-ustar-archive
create-ustar-archive)) extract-ustar-archive
list-ustar-archive))
(define (fmt-error fmt . args) (define (fmt-error fmt . args)
(error (apply format #f fmt args))) (error (apply format #f fmt args)))
@ -396,7 +397,7 @@
%uname %gname %dev-major %dev-minor %uname %gname %dev-major %dev-minor
%prefix)))))) %prefix))))))
(define* (write-ustar-file port file-name #:key group mtime numeric-owner? owner) (define* (write-ustar-file port file-name #:key group mtime numeric-owner? owner verbosity)
(let* ((file-name (if (string-every file-name-separator? file-name) (let* ((file-name (if (string-every file-name-separator? file-name)
file-name-separator-string file-name-separator-string
(string-trim-right file-name file-name-separator?))) (string-trim-right file-name file-name-separator?)))
@ -422,51 +423,70 @@
(for-each (lambda (file-name) (write-ustar-file port file-name)) (for-each (lambda (file-name) (write-ustar-file port file-name))
(files-in-directory file-name)))))) (files-in-directory file-name))))))
(define (extract-ustar-file port header) (define (ustar-header-file-name header)
(let ((name (ustar-header-name header))
(prefix (ustar-header-prefix header)))
(if (string-null? prefix) name
(string-append prefix "/" name))))
(define* (extract-ustar-file port header #:key (extract? #t))
(let* ((size (ustar-header-size header)) (let* ((size (ustar-header-size header))
(name (ustar-header-name header)) (file-name (ustar-header-file-name header))
(prefix (ustar-header-prefix header)) (dir (dirname file-name))
(file-name (if (string-null? prefix) name (thunk (lambda _
(string-append prefix "/" name))) (let loop ((record (read-ustar-record port)) (wrote 0))
(dir (dirname file-name))) (let* ((read (+ wrote 512))
(mkdir-p dir) (block (if (< read size) record
(with-output-to-file file-name (sub-bytevector record 0 (- size wrote)))))
(lambda _ (when extract?
(let loop ((record (read-ustar-record port)) (wrote 0)) (display (bv->ustar-0string block "block")))
(let* ((read (+ wrote 512)) (and (not (eof-object? record))
(block (if (< read size) record (< read size)
(sub-bytevector record 0 (- size wrote))))) (loop (read-ustar-record port) read)))))))
(display (bv->ustar-0string block "block")) (when extract?
(and (not (eof-object? record)) (mkdir-p dir))
(< read size) (if extract? (with-output-to-file file-name thunk)
(loop (read-ustar-record port) read)))))) (thunk))
(chmod file-name (ustar-header-mode header)) (when extract?
(let ((mtime (ustar-header-mtime header))) (chmod file-name (ustar-header-mode header))
(utime file-name mtime mtime)))) (let ((mtime (ustar-header-mtime header)))
(utime file-name mtime mtime)))))
(define (extract-ustar-archive file-name files) (define (display-rwx perm)
(display (if (zero? (logand perm 4)) "-" "r"))
(display (if (zero? (logand perm 2)) "-" "w"))
(display (if (zero? (logand perm 1)) "-" "x")))
(define* (display-header header #:key verbose?)
(when verbose?
(let ((mode (ustar-header-mode header))
(uid (ustar-header-uid header))
(gid (ustar-header-gid header))
(size (ustar-header-size header))
(date (strftime "%c" (localtime (ustar-header-mtime header)))))
(display "-")
(display-rwx (ash mode -6))
(display-rwx (ash (logand mode #o70) -3))
(display-rwx (logand mode #o7))
(display " ")
(format #t "~8s" uid)
(display " ")
(format #t "~8s" gid)
(format #t "~8d" size)
(display " ")
(display date)
(display " ")))
(display (ustar-header-file-name header))
(newline))
(define* (create-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity)
(catch #t (catch #t
(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)))
(extract-ustar-file in header)
(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* (create-ustar-archive file-name files #:key group mtime numeric-owner? owner)
(catch 'fubar
(lambda () (lambda ()
(call-with-port* (open-file file-name "wb") (call-with-port* (open-file file-name "wb")
(lambda (out) (lambda (out)
(for-each (for-each
(cut write-ustar-file out <> (cut write-ustar-file out <>
#:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner) #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity)
files) files)
(write-ustar-footer out)))) (write-ustar-footer out))))
(lambda (key subr message args . rest) (lambda (key subr message args . rest)
@ -475,6 +495,26 @@
(apply format #f message args)) (apply format #f message args))
(exit 1)))) (exit 1))))
(define* (extract-ustar-archive file-name files #:key (extract? #t) verbosity)
(catch #t
(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? (not (zero? verbosity))))
(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* (list-ustar-archive file-name files #:key verbosity)
(extract-ustar-archive file-name files #:extract? #:verbosity verbosity))
;;; Local Variables: ;;; Local Variables:
;;; mode: scheme ;;; mode: scheme
;;; eval: (put 'call-with-port* 'scheme-indent-function 1) ;;; eval: (put 'call-with-port* 'scheme-indent-function 1)