tar: Support creation of deterministic archives.
* gash/ustar.scm (write-ustar-header, write-ustar-file): Accept keyword arguments: group mtime numeric-owner? owner. (create-ustar-archive): Likewise. Rename from write-ustar-archive. * gash/bournish-commands.scm (tar-command): Support --group, --mtime, --numeric-owner, --owner and --sort.
This commit is contained in:
Jan Nieuwenhuizen
parent
92d2896134
commit
463b71acc9
|
|
@ -368,9 +368,14 @@ Options:
|
|||
(lambda _
|
||||
(let* ((option-spec
|
||||
'((create (single-char #\c))
|
||||
(group (value #t))
|
||||
(extract (single-char #\x))
|
||||
(file (single-char #\f) (value #t))
|
||||
(help (single-char #\h))
|
||||
(mtime (value #t))
|
||||
(numeric-owner?)
|
||||
(owner (value #t))
|
||||
(sort (value #t))
|
||||
(version (single-char #\V))))
|
||||
(args (cons "tar" args))
|
||||
(options (getopt-long args option-spec))
|
||||
|
|
@ -386,14 +391,32 @@ Options:
|
|||
Usage: tar [OPTION]... [FILE]...
|
||||
-c, --create create a new archive
|
||||
-f, --file=ARCHIVE use archive file or device ARCHIVE
|
||||
--group=NAME force NAME as group for added files
|
||||
-h, --help display this help
|
||||
--mtime=DATE-OR-FILE set mtime for added files from DATE-OR-FILE
|
||||
--numeric-owner always use numbers for user/group names
|
||||
--owner=NAME force NAME as owner for added files
|
||||
--sort=ORDER directory sorting order: none (default), name or
|
||||
inode
|
||||
-V, --version display version
|
||||
-x, --extract extract files from an archive
|
||||
")
|
||||
(exit (if usage? 2 0)))
|
||||
(version? (format #t "tar (GASH) ~a\n" %version) (exit 0))
|
||||
(create?
|
||||
(write-ustar-archive file files))
|
||||
(let ((files (if (not (option-ref options 'sort #f)) files
|
||||
(sort files string<)))
|
||||
(group (and=> (option-ref options 'group #f) string->number))
|
||||
(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) '())))))
|
||||
(extract?
|
||||
(extract-ustar-archive file files))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@
|
|||
#:use-module (rnrs io ports)
|
||||
#:use-module (gash guix-build-utils)
|
||||
#:export (extract-ustar-archive
|
||||
write-ustar-archive))
|
||||
create-ustar-archive))
|
||||
|
||||
(define (fmt-error fmt . args)
|
||||
(error (apply format #f fmt args)))
|
||||
|
|
@ -301,12 +301,12 @@
|
|||
checksum))
|
||||
header))))
|
||||
|
||||
(define (write-ustar-header port path st)
|
||||
(define* (write-ustar-header port path st #:key group mtime numeric-owner? owner)
|
||||
(let* ((type (stat:type st))
|
||||
(perms (stat:perms st))
|
||||
(mtime (stat:mtime st))
|
||||
(uid (stat:uid st))
|
||||
(gid (stat:gid st))
|
||||
(mtime (or mtime (stat:mtime st)))
|
||||
(uid (or owner (stat:uid st)))
|
||||
(gid (or group (stat:gid st)))
|
||||
(uname (or (false-if-exception (passwd:name (getpwuid uid)))
|
||||
""))
|
||||
(gname (or (false-if-exception (group:name (getgrgid gid)))
|
||||
|
|
@ -396,17 +396,17 @@
|
|||
%uname %gname %dev-major %dev-minor
|
||||
%prefix))))))
|
||||
|
||||
(define (write-ustar-path port path)
|
||||
(let* ((path (if (string-every file-name-separator? path)
|
||||
(define* (write-ustar-file port file-name #:key group mtime numeric-owner? owner)
|
||||
(let* ((file-name (if (string-every file-name-separator? file-name)
|
||||
file-name-separator-string
|
||||
(string-trim-right path file-name-separator?)))
|
||||
(st (lstat path))
|
||||
(string-trim-right file-name file-name-separator?)))
|
||||
(st (lstat file-name))
|
||||
(type (stat:type st))
|
||||
(size (stat:size st)))
|
||||
(write-ustar-header port path st)
|
||||
(write-ustar-header port file-name st #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner)
|
||||
(case type
|
||||
((regular)
|
||||
(call-with-port* (open-file path "rb")
|
||||
(call-with-port* (open-file file-name "rb")
|
||||
(lambda (in)
|
||||
(let ((buf (make-bytevector 512)))
|
||||
(let loop ((left size))
|
||||
|
|
@ -415,12 +415,12 @@
|
|||
(obtained (get-bytevector-n! in buf 0 asked)))
|
||||
(when (or (eof-object? obtained)
|
||||
(< obtained asked))
|
||||
(fmt-error "~a: file appears to have shrunk" path))
|
||||
(fmt-error "~a: file appears to have shrunk" file-name))
|
||||
(write-ustar-record port buf 0 obtained)
|
||||
(loop (- left obtained)))))))))
|
||||
((directory)
|
||||
(for-each (lambda (path) (write-ustar-path port path))
|
||||
(files-in-directory path))))))
|
||||
(for-each (lambda (file-name) (write-ustar-file port file-name))
|
||||
(files-in-directory file-name))))))
|
||||
|
||||
(define (extract-ustar-file port header)
|
||||
(let* ((size (ustar-header-size header))
|
||||
|
|
@ -459,17 +459,18 @@
|
|||
(apply format #f message args))
|
||||
(exit 1))))
|
||||
|
||||
(define (write-ustar-archive output-path paths)
|
||||
(catch #t
|
||||
(define* (create-ustar-archive file-name files #:key group mtime numeric-owner? owner)
|
||||
(catch 'fubar
|
||||
(lambda ()
|
||||
(call-with-port* (open-file output-path "wb")
|
||||
(call-with-port* (open-file file-name "wb")
|
||||
(lambda (out)
|
||||
(for-each (lambda (path)
|
||||
(write-ustar-path out path))
|
||||
paths)
|
||||
(for-each
|
||||
(cut write-ustar-file out <>
|
||||
#:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner)
|
||||
files)
|
||||
(write-ustar-footer out))))
|
||||
(lambda (key subr message args . rest)
|
||||
(false-if-exception (delete-file output-path))
|
||||
(false-if-exception (delete-file file-name))
|
||||
(format (current-error-port) "ERROR: ~a\n"
|
||||
(apply format #f message args))
|
||||
(exit 1))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue