From 28d62b616997933ed7fa8c8c80da88044b90098d Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 00:42:50 +0200 Subject: [PATCH] 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. --- gash/bournish-commands.scm | 25 ++++++-- gash/ustar.scm | 120 ++++++++++++++++++++++++------------- 2 files changed, 100 insertions(+), 45 deletions(-) diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm index f63efd1..1d13941 100644 --- a/gash/bournish-commands.scm +++ b/gash/bournish-commands.scm @@ -364,6 +364,10 @@ Options: (for-each display-match matches) 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) (lambda _ (let* ((option-spec @@ -373,19 +377,24 @@ Options: (file (single-char #\f) (value #t)) (help (single-char #\h)) (mtime (value #t)) + (list (single-char #\t)) (numeric-owner?) (owner (value #t)) (sort (value #t)) - (version (single-char #\V)))) + (verbose (single-char #\v)) + (version (single-char #\V)))) (args (cons "tar" args)) (options (getopt-long args option-spec)) (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")) (files (option-ref options '() '())) (help? (option-ref options 'help #f)) - (usage? (and (not help?) (not (or (and create? (pair? files)) extract?)))) - (version? (option-ref options 'version #f))) + (usage? (and (not help?) (not (or (and create? (pair? files)) + 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) "\ Usage: tar [OPTION]... [FILE]... @@ -398,7 +407,9 @@ Usage: tar [OPTION]... [FILE]... --owner=NAME force NAME as owner for added files --sort=ORDER directory sorting order: none (default), name or inode + -t, --list list the contents of an archive -V, --version display version + -v, --verbose verbosely list files processed -x, --extract extract files from an archive ") (exit (if usage? 2 0))) @@ -416,9 +427,13 @@ Usage: tar [OPTION]... [FILE]... ,@(if group `(#:group ,group) '()) ,@(if mtime `(#:mtime ,mtime) '()) ,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '()) - ,@(if owner `(#:owner ,owner) '()))))) + ,@(if owner `(#:owner ,owner) '()) + ,@(if owner `(#:owner ,owner) '()) + #:verbosity ,verbosity)))) (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 `( diff --git a/gash/ustar.scm b/gash/ustar.scm index 3775314..6271e74 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -26,8 +26,9 @@ #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (gash guix-build-utils) - #:export (extract-ustar-archive - create-ustar-archive)) + #:export (create-ustar-archive + extract-ustar-archive + list-ustar-archive)) (define (fmt-error fmt . args) (error (apply format #f fmt args))) @@ -396,7 +397,7 @@ %uname %gname %dev-major %dev-minor %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) file-name-separator-string (string-trim-right file-name file-name-separator?))) @@ -422,51 +423,70 @@ (for-each (lambda (file-name) (write-ustar-file port 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)) - (name (ustar-header-name header)) - (prefix (ustar-header-prefix header)) - (file-name (if (string-null? prefix) name - (string-append prefix "/" name))) - (dir (dirname file-name))) - (mkdir-p dir) - (with-output-to-file file-name - (lambda _ - (let loop ((record (read-ustar-record port)) (wrote 0)) - (let* ((read (+ wrote 512)) - (block (if (< read size) record - (sub-bytevector record 0 (- size wrote))))) - (display (bv->ustar-0string block "block")) - (and (not (eof-object? record)) - (< read size) - (loop (read-ustar-record port) read)))))) - (chmod file-name (ustar-header-mode header)) - (let ((mtime (ustar-header-mtime header))) - (utime file-name mtime mtime)))) + (file-name (ustar-header-file-name header)) + (dir (dirname file-name)) + (thunk (lambda _ + (let loop ((record (read-ustar-record port)) (wrote 0)) + (let* ((read (+ wrote 512)) + (block (if (< read size) record + (sub-bytevector record 0 (- size wrote))))) + (when extract? + (display (bv->ustar-0string block "block"))) + (and (not (eof-object? record)) + (< read size) + (loop (read-ustar-record port) read))))))) + (when extract? + (mkdir-p dir)) + (if extract? (with-output-to-file file-name thunk) + (thunk)) + (when extract? + (chmod file-name (ustar-header-mode header)) + (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 - (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 () (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) + #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity) files) (write-ustar-footer out)))) (lambda (key subr message args . rest) @@ -475,6 +495,26 @@ (apply format #f message args)) (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: ;;; mode: scheme ;;; eval: (put 'call-with-port* 'scheme-indent-function 1)