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

tar: Nicer verbose listing of files. 

* gash/guix-build-utils.scm (display-file): New function.
* gash/ustar.scm (display-header): Use it.
(ustar-header->stat): New function.
This commit is contained in:
Jan Nieuwenhuizen 2018-10-27 09:53:12 +02:00
parent 28d62b6169
commit 4e671558e5
2 changed files with 75 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
gash/guix-build-utils.scm
View File

@ -3,6 +3,7 @@
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
@ -23,6 +24,7 @@
(define-module (gash guix-build-utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
@ -33,6 +35,7 @@
#:use-module (rnrs io ports)
#:export (
delete-file-recursively
display-file
dump-port
file-name-predicate
find-files
@ -238,3 +241,44 @@ transferred and the continuation of the transfer as a thunk."
(loop tail path)
(apply throw args))))))
(() #t))))
(define* (display-file file-name #:optional st)
(define (display-rwx perm sticky)
(display (if (zero? (logand perm 4)) "-" "r"))
(display (if (zero? (logand perm 2)) "-" "w"))
(display (let ((x (logand perm 1)))
(if (zero? sticky) (if (zero? x) "-" "x")
(if (= sticky 1) (if (zero? x) "T" "t")
(if (zero? x) "S" "s"))))))
(define (display-bcdfsl type)
(display
(case type
((block-special) "b")
((char-special) "c")
((directory) "d")
((fifo) "p")
((regular) "-")
((socket) "s")
((symlink) "l")
(else "?"))))
(let* ((mode (stat:mode st))
(uid (stat:uid st))
(gid (stat:gid st))
(size (stat:size st))
(date (strftime "%c" (localtime (stat:mtime st))))
(sticky (ash mode -9)))
(display-bcdfsl (stat:type st))
(display-rwx (ash mode -6) (logand sticky 4))
(display-rwx (ash (logand mode #o70) -3) (logand sticky 2))
(display-rwx (logand mode #o7) (logand sticky 1))
(display " ")
(let ((ent (catch #t (compose passwd:name (cut getpwuid uid)) (const uid))))
(format #t "~8a" ent))
(display " ")
(let ((ent (catch #t (compose group:name (cut getgrgid gid)) (const gid))))
(format #t "~8a" ent))
(format #t "~8d" size)
(display " ")
(display date)
(display " "))
(display file-name))

57
gash/ustar.scm
View File

@ -226,6 +226,16 @@
(dev-minor ustar-header-dev-minor)
(prefix ustar-header-prefix ))
(define (ustar-header-type header)
(let ((file-types #(regular - symlink char-special block-special directory fifo))
(type (string->number (ustar-header-type-flag header))))
(when (or (not type)
(< type 0)
(>= type (vector-length file-types)))
(fmt-error "~a: unsupported file type ~a"
(ustar-header-file-name header) type))
(vector-ref file-types (string->number (ustar-header-type-flag header)))))
(define ustar-header-field-size-alist
'((name . 100)
(mode . 8)
@ -404,6 +414,10 @@
(st (lstat file-name))
(type (stat:type st))
(size (stat:size st)))
(unless (zero? verbosity)
(if (> verbosity 1) (display-file file-name st)
(display file-name))
(newline))
(write-ustar-header port file-name st #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner)
(case type
((regular)
@ -452,32 +466,23 @@
(let ((mtime (ustar-header-mtime header)))
(utime file-name mtime mtime)))))
(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 (ustar-header->stat header)
(let* ((stat-size 17)
(si (list->vector (iota stat-size)))
(st (make-vector stat-size 0)))
(vector-set! st (stat:mode si) (ustar-header-mode header))
(vector-set! st (stat:uid si) (ustar-header-uid header))
(vector-set! st (stat:gid si) (ustar-header-gid header))
(vector-set! st (stat:size si) (ustar-header-size header))
(vector-set! st (stat:mtime si) (ustar-header-mtime header))
(vector-set! st (stat:type si) (ustar-header-type header))
st))
(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))
(let ((file-name (ustar-header-file-name header)))
(if verbose? (display-file (ustar-header-file-name header) (ustar-header->stat header))
(display file-name))
(newline)))
(define* (create-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity)
(catch #t
@ -504,7 +509,7 @@
(when (and header
(not (eof-object? header)))
(unless (zero? verbosity)
(display-header header #:verbose? (not (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)
@ -513,7 +518,7 @@
(exit 1))))
(define* (list-ustar-archive file-name files #:key verbosity)
(extract-ustar-archive file-name files #:extract? #:verbosity verbosity))
(extract-ustar-archive file-name files #:extract? #f #:verbosity verbosity))
;;; Local Variables:
;;; mode: scheme