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 --strip-components. 

* gash/commands/tar.scm (tar): Support --strip-components.
* gash/ustar.scm (list-ustar-archive, list-ustar-port,
read-ustar-archive, read-ustar-port, read-ustar-file): Likewise.
This commit is contained in:
Jan Nieuwenhuizen 2018-11-03 17:33:22 +01:00
parent 2a4e3ec71b
commit d13de88e43
2 changed files with 23 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
gash/commands/tar.scm
View File

@ -49,6 +49,8 @@
(numeric-owner?)
(owner (value #t))
(sort (value #t))
(strip (value #t))
(strip-components (value #t))
(verbose (single-char #\v))
(version (single-char #\V))))
(options (getopt-long args option-spec))
@ -81,6 +83,10 @@
((string-suffix? ".xz" file) 'xz)
(else #f))))))
(sort-order (and=> (option-ref options 'sort #f) string->symbol))
(strip (string->number
(or (option-ref options 'strip #f)
(option-ref options 'strip-components #f)
"0")))
(help? (option-ref options 'help #f))
(usage? (and (not help?) (not (or (and create? (pair? files))
extract? list?))))
@ -99,6 +105,8 @@ Usage: tar [OPTION]... [FILE]...
--owner=NAME force NAME as owner for added files
--sort=ORDER directory sorting order: none (default), name or
inode
--strip-components=NUM strip NUM leading components from file names
names on extraction
-t, --list list the contents of an archive
-V, --version display version
-v, --verbose verbosely list files processed
@ -140,14 +148,14 @@ Usage: tar [OPTION]... [FILE]...
(let ((port (if (equal? file "-") (current-input-port)
(open-file file "rb"))))
(call-with-decompressed-port compression port
(cut read-ustar-port <> files #:verbosity verbosity)))
(cut read-ustar-port <> files #:strip strip #:verbosity verbosity)))
(read-ustar-archive file files #:verbosity verbosity)))
(list?
(if (or compression (equal? file "-"))
(let ((port (if (equal? file "-") (current-input-port)
(open-file file "rb"))))
(call-with-decompressed-port compression port
(cut list-ustar-port <> files #:verbosity (1+ verbosity))))
(list-ustar-archive file files #:verbosity (1+ verbosity)))))))
(cut list-ustar-port <> files #:strip strip #:verbosity (1+ verbosity))))
(list-ustar-archive file files #:strip strip #:verbosity (1+ verbosity)))))))
(define main tar)

22
gash/ustar.scm
View File

@ -459,9 +459,11 @@
(if (string-null? prefix) name
(string-append prefix "/" name))))
(define* (read-ustar-file port header #:key (extract? #t))
(define* (read-ustar-file port header #:key (extract? #t) (strip 0))
(let* ((size (ustar-header-size header))
(file-name (ustar-header-file-name header))
(file-name (if (zero? strip) file-name
(string-join (list-tail (string-split file-name #\/) strip) "/")))
(dir (dirname file-name))
(thunk (lambda _
(let loop ((read 0))
@ -470,7 +472,7 @@
(and record
(let* ((read (+ read 512))
(block (if (< read size) record
(sub-bytevector record 0 (- size -512 read)))))
(sub-bytevector record 0 (- size -512 read)))))
(when extract?
(display (bv->ustar-0string block "block")))
(loop read)))))))))
@ -525,30 +527,30 @@
(apply format #f message args))
(exit 1))))
(define* (read-ustar-port in files #:key (extract? #t) verbosity)
(define* (read-ustar-port in files #:key (extract? #t) (strip 0) verbosity)
(let loop ((header (read-ustar-header in)))
(when (and header
(not (eof-object? header)))
(unless (zero? verbosity)
(display-header header #:verbose? (> verbosity 1)))
(read-ustar-file in header #:extract? extract?)
(read-ustar-file in header #:extract? extract? #:strip strip)
(loop (read-ustar-header in)))))
(define* (read-ustar-archive file-name files #:key (extract? #t) verbosity)
(define* (read-ustar-archive file-name files #:key (extract? #t) (strip 0) verbosity)
(catch #t
(lambda _
(call-with-port* (open-file file-name "rb")
(cut read-ustar-port <> files #:extract? extract? #:verbosity verbosity)))
(cut read-ustar-port <> files #:extract? extract? #:strip strip #:verbosity verbosity)))
(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)
(read-ustar-archive file-name files #:extract? #f #:verbosity verbosity))
(define* (list-ustar-archive file-name files #:key (strip 0) verbosity)
(read-ustar-archive file-name files #:extract? #f #:strip strip #:verbosity verbosity))
(define* (list-ustar-port in files #:key verbosity)
(read-ustar-port in files #:extract? #f #:verbosity verbosity))
(define* (list-ustar-port in files #:key (strip 0) verbosity)
(read-ustar-port in files #:extract? #f #:strip strip #:verbosity verbosity))
;;; Local Variables:
;;; mode: scheme