153 lines
7.1 KiB
Scheme
153 lines
7.1 KiB
Scheme
;;; Gash --- Guile As SHell
|
|
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
|
|
;;;
|
|
;;; This file is part of Gash.
|
|
;;;
|
|
;;; Gash is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
|
|
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
|
|
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
|
|
;;; details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;;; Code:
|
|
|
|
(define-module (gash commands tar)
|
|
#:use-module (ice-9 getopt-long)
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module (gash config)
|
|
#:use-module (gash compress)
|
|
#:use-module (gash ustar)
|
|
#:use-module (gash guix-utils)
|
|
#:use-module (gash shell-utils)
|
|
|
|
#:export (
|
|
tar
|
|
))
|
|
|
|
(define (tar . args)
|
|
(let* ((option-spec
|
|
'((create (single-char #\c))
|
|
(compress (single-char #\Z))
|
|
(gzip (single-char #\z))
|
|
(bzip2 (single-char #\j))
|
|
(xz (single-char #\J))
|
|
(group (value #t))
|
|
(extract (single-char #\x))
|
|
(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))
|
|
(verbose (single-char #\v))
|
|
(version (single-char #\V))))
|
|
(options (getopt-long args option-spec))
|
|
(options (if (or (option-ref options 'create #f)
|
|
(option-ref options 'extract #f)
|
|
(option-ref options 'list #f)
|
|
(null? (cdr args))
|
|
(string-prefix? "-" (cadr args))) options
|
|
(let ((args (cons* (car args)
|
|
(string-append "-" (cadr args))
|
|
(cddr args))))
|
|
(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 "-"))
|
|
(files (option-ref options '() '()))
|
|
(compress? (option-ref options 'compress #f))
|
|
(bzip2? (option-ref options 'bzip2 #f))
|
|
(gzip? (option-ref options 'gzip #f))
|
|
(xz? (option-ref options 'xz #f))
|
|
(compression (cond (bzip2? 'bzip2)
|
|
(compress? 'compress)
|
|
(gzip? 'gzip)
|
|
(xz? 'xz)
|
|
(else (and (or extract? list? )
|
|
(cond ((string-suffix? ".Z" file) 'compress)
|
|
((string-suffix? ".bz2" file) 'bzip2)
|
|
((string-suffix? ".gz" file) 'gzip)
|
|
((string-suffix? ".xz" file) 'xz)
|
|
(else #f))))))
|
|
(help? (option-ref options 'help #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 (version? (format #t "tar (GASH) ~a\n" %version) (exit 0))
|
|
((or help? usage?) (format (if usage? (current-error-port) #t)
|
|
"\
|
|
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
|
|
-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
|
|
-z, --gzip filter the archive through gzip
|
|
-Z, --compress filter the archive through compress
|
|
")
|
|
(exit (if usage? 2 0)))
|
|
(create?
|
|
(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)))
|
|
(if (or compression (equal? file "-"))
|
|
(let ((port (if (equal? file "-") (current-output-port)
|
|
(open-file file "wb"))))
|
|
(call-with-compressed-output-port compression port
|
|
(cut apply write-ustar-port <>
|
|
`(,files
|
|
,@(if group `(#:group ,group) '())
|
|
,@(if mtime `(#:mtime ,mtime) '())
|
|
,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '())
|
|
,@(if owner `(#:owner ,owner) '())
|
|
,@(if owner `(#:owner ,owner) '())
|
|
#:verbosity ,verbosity))))
|
|
(apply write-ustar-archive
|
|
`(,file
|
|
,files
|
|
,@(if group `(#:group ,group) '())
|
|
,@(if mtime `(#:mtime ,mtime) '())
|
|
,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '())
|
|
,@(if owner `(#:owner ,owner) '())
|
|
,@(if owner `(#:owner ,owner) '())
|
|
#:verbosity ,verbosity)))))
|
|
(extract?
|
|
(if (or compression (equal? 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)))
|
|
(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)))))))
|
|
|
|
(define main tar)
|