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 compression. 

* gash/guix-utils.scm: New file, partial import from Guix.
Throughout: Add `compress.'
* build-aux/build-guile.sh: Compile it.
* gash/config.scm.in: Support it by defining compressors.
* configure: Substitute them.
* gash/bournish-commands.scm (tar-command): Use it to have tar support
compression and decompression.
This commit is contained in:
Jan Nieuwenhuizen 2018-10-27 21:29:46 +02:00
parent e3e20738c2
commit a10247aab1
7 changed files with 310 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
build-aux/build-guile.sh
View File

@ -41,6 +41,7 @@ set -e
SCM_FILES="
gash/bournish-commands.scm
gash/guix-build-utils.scm
gash/guix-utils.scm
gash/builtins.scm
gash/compress.scm
gash/config.scm

10
configure vendored
View File

@ -70,7 +70,17 @@ SHELL=$BASH
VERSION=$VERSION
EOF
BZIP2=$(command -v bzip2)
COMPRESS=$(command -v compress)
[ -z "$COMPRESS" ] && COMPRESS=$PWD/bin/compress
GZIP=$(command -v gzip)
XZ=$(command -v xz)
sed \
-e "s,@BZIP2@,$BZIP2,"\
-e "s,@COMPRESS@,$COMPRESS,"\
-e "s,@GZIP@,$GZIP,"\
-e "s,@XZ@,$XZ,"\
-e "s,@VERSION@,$VERSION,"\
gash/config.scm.in > gash/config.scm

58
gash/bournish-commands.scm
View File

@ -19,6 +19,12 @@
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial bournish.scm was taken from Guix.
;;; Code:
(define-module (gash bournish-commands)
#:use-module (ice-9 ftw)
#:use-module (ice-9 getopt-long)
@ -31,6 +37,7 @@
#:use-module (srfi srfi-26)
#:use-module (gash guix-build-utils)
#:use-module (gash guix-utils)
#:use-module (gash compress)
#:use-module (gash config)
#:use-module (gash io)
@ -377,6 +384,10 @@ Options:
(lambda _
(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))
@ -390,6 +401,15 @@ Options:
(version (single-char #\V))))
(args (cons "tar" args))
(options (getopt-long args option-spec))
(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 #f)))
(create? (option-ref options 'create #f))
(list? (option-ref options 'list #f))
(extract? (option-ref options 'extract #f))
@ -416,6 +436,8 @@ Usage: tar [OPTION]... [FILE]...
-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)))
(version? (format #t "tar (GASH) ~a\n" %version) (exit 0))
@ -426,16 +448,18 @@ Usage: tar [OPTION]... [FILE]...
(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 (equal? file "-")
(apply write-ustar-port (current-output-port)
`(,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))
(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
@ -446,11 +470,19 @@ Usage: tar [OPTION]... [FILE]...
,@(if owner `(#:owner ,owner) '())
#:verbosity ,verbosity)))))
(extract?
(if (equal? file "-") (read-ustar-port (current-input-port) files #:verbosity verbosity)
(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 (equal? file "-") (list-ustar-port (current-input-port) files #:verbosity (1+ verbosity))
(list-ustar-archive file files #:verbosity (1+ verbosity))))))))
(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 (compress-command . args)
(lambda _

18
gash/config.scm.in
View File

@ -17,7 +17,11 @@
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash config)
#:export (%version))
#:export (%bzip2
%xz
%compress
%gzip
%version))
;;; Commentary:
;;;
@ -28,3 +32,15 @@
(define %version
"@VERSION@")
(define %bzip2
"@BZIP2@")
(define %compress
"@COMPRESS@")
(define %gzip
"@GZIP@")
(define %xz
"@XZ@")

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

@ -20,6 +20,11 @@
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial guix-build-utils.scm was taken from Guix.
;;; Code:
(define-module (gash guix-build-utils)
#:use-module (srfi srfi-1)

217
gash/guix-utils.scm Normal file
View File

@ -0,0 +1,217 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
;;; 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:
;;; The initial guix-utils.scm was taken from Guix.
;;; Code:
(define-module (gash guix-utils)
#:use-module (srfi srfi-1)
;; #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
;; #:use-module (srfi srfi-26)
;; #:use-module (srfi srfi-35)
;; #:use-module (srfi srfi-39)
;; #:use-module (ice-9 binary-ports)
;; #:autoload (rnrs io ports) (make-custom-binary-input-port)
;; #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
;; #:use-module (guix memoization)
;; #:use-module ((guix build utils) #:select (dump-port mkdir-p))
;; #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
;; #:use-module (ice-9 format)
#:autoload (ice-9 popen) (open-pipe*)
;; #:autoload (ice-9 rdelim) (read-line)
;; #:use-module (ice-9 regex)
#:use-module (ice-9 match)
;; #:use-module (ice-9 format)
;; #:use-module ((ice-9 iconv) #:prefix iconv:)
;; #:use-module (system foreign)
#:use-module (gash config)
#:export (filtered-port
compressed-port
decompressed-port
call-with-decompressed-port
compressed-output-port
call-with-compressed-output-port))
;;;
;;; Filtering & pipes.
;;;
(define (filtered-port command input)
"Return an input port where data drained from INPUT is filtered through
COMMAND (a list). In addition, return a list of PIDs that the caller must
wait. When INPUT is a file port, it must be unbuffered; otherwise, any
buffered data is lost."
(let loop ((input input)
(pids '()))
(if (file-port? input)
(match (pipe)
((in . out)
(match (primitive-fork)
(0
(dynamic-wind
(const #f)
(lambda ()
(close-port in)
(close-port (current-input-port))
(dup2 (fileno input) 0)
(close-port (current-output-port))
(dup2 (fileno out) 1)
(catch 'system-error
(lambda ()
(apply execl (car command) command))
(lambda args
(format (current-error-port)
"filtered-port: failed to execute '~{~a ~}': ~a~%"
command (strerror (system-error-errno args))))))
(lambda ()
(primitive-_exit 1))))
(child
(close-port out)
(values in (cons child pids))))))
;; INPUT is not a file port, so fork just for the sake of tunneling it
;; through a file port.
(match (pipe)
((in . out)
(match (primitive-fork)
(0
(dynamic-wind
(const #t)
(lambda ()
(close-port in)
(dump-port input out))
(lambda ()
(close-port input)
(false-if-exception (close out))
(primitive-_exit 0))))
(child
(close-port input)
(close-port out)
(loop in (cons child pids)))))))))
(define (decompressed-port compression input)
"Return an input port where INPUT is decompressed according to COMPRESSION,
a symbol such as 'xz."
(match compression
((or #f 'none) (values input '()))
('bzip2 (filtered-port `(,%bzip2 "-dc") input))
('compress (filtered-port `(,%compress "-dc") input))
('xz (filtered-port `(,%xz "-dc" "-T0") input))
('gzip (filtered-port `(,%gzip "-dc") input))
(else (error "unsupported compression scheme" compression))))
(define (compressed-port compression input)
"Return an input port where INPUT is decompressed according to COMPRESSION,
a symbol such as 'xz."
(match compression
((or #f 'none) (values input '()))
('bzip2 (filtered-port `(,%bzip2 "-c") input))
('compress (filtered-port `(,%compress "-c") input))
('xz (filtered-port `(,%xz "-c" "-T0") input))
('gzip (filtered-port `(,%gzip "-c") input))
(else (error "unsupported compression scheme" compression))))
(define (call-with-decompressed-port compression port proc)
"Call PROC with a wrapper around PORT, a file port, that decompresses data
read from PORT according to COMPRESSION, a symbol such as 'xz."
(let-values (((decompressed pids)
(decompressed-port compression port)))
(dynamic-wind
(const #f)
(lambda ()
(proc decompressed))
(lambda ()
(close-port decompressed)
(unless (every (compose zero? cdr waitpid) pids)
(error "decompressed-port failure" pids))))))
(define (filtered-output-port command output)
"Return an output port. Data written to that port is filtered through
COMMAND and written to OUTPUT, an output file port. In addition, return a
list of PIDs to wait for. OUTPUT must be unbuffered; otherwise, any buffered
data is lost."
(match (pipe)
((in . out)
(match (primitive-fork)
(0
(dynamic-wind
(const #f)
(lambda ()
(close-port out)
(close-port (current-input-port))
(dup2 (fileno in) 0)
(close-port (current-output-port))
(dup2 (fileno output) 1)
(catch 'system-error
(lambda ()
(apply execl (car command) command))
(lambda args
(format (current-error-port)
"filtered-output-port: failed to execute '~{~a ~}': ~a~%"
command (strerror (system-error-errno args))))))
(lambda ()
(primitive-_exit 1))))
(child
(close-port in)
(values out (list child)))))))
(define* (compressed-output-port compression output
#:key (options '()))
"Return an output port whose input is compressed according to COMPRESSION,
a symbol such as 'xz, and then written to OUTPUT. In addition return a list
of PIDs to wait for. OPTIONS is a list of strings passed to the compression
program--e.g., '(\"--fast\")."
(match compression
((or #f 'none) (values output '()))
('bzip2 (filtered-output-port `(,%bzip2 "-c" ,@options) output))
('compress (filtered-output-port `(,%compress "-c" ,@options) output))
('xz (filtered-output-port `(,%xz "-c" "-T0" ,@options) output))
('gzip (filtered-output-port `(,%gzip "-c" ,@options) output))
(else (error "unsupported compression scheme" compression))))
(define* (call-with-compressed-output-port compression port proc
#:key (options '()))
"Call PROC with a wrapper around PORT, a file port, that compresses data
that goes to PORT according to COMPRESSION, a symbol such as 'xz. OPTIONS is
a list of command-line arguments passed to the compression program."
(let-values (((compressed pids)
(compressed-output-port compression port
#:options options)))
(dynamic-wind
(const #f)
(lambda ()
(proc compressed))
(lambda ()
(close-port compressed)
(unless (every (compose zero? cdr waitpid) pids)
(error "compressed-output-port failure" pids))))))

29
gash/ustar.scm
View File

@ -445,7 +445,8 @@
(write-ustar-record port buf 0 obtained)
(loop (- left obtained)))))))))
((directory)
(for-each (lambda (file-name) (write-ustar-file port file-name))
(for-each (lambda (file-name) (write-ustar-file port file-name
#:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity))
(files-in-directory file-name))))))
(define (ustar-header-file-name header)
@ -454,7 +455,7 @@
(if (string-null? prefix) name
(string-append prefix "/" name))))
(define* (extract-ustar-file port header #:key (extract? #t))
(define* (read-ustar-file port header #:key (extract? #t))
(let* ((size (ustar-header-size header))
(file-name (ustar-header-file-name header))
(dir (dirname file-name))
@ -497,7 +498,7 @@
(define* (write-ustar-port out files #:key group mtime numeric-owner? owner verbosity)
(catch #t
(lambda ()
(lambda _
(for-each
(cut write-ustar-file out <>
#:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity)
@ -511,7 +512,7 @@
(define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner verbosity)
(catch #t
(lambda ()
(lambda _
(call-with-port* (open-file file-name "wb")
(cut write-ustar-port <> files
#:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity)))
@ -521,36 +522,36 @@
(apply format #f message args))
(exit 1))))
(define* (extract-ustar-port in files #:key (extract? #t) verbosity)
(define* (read-ustar-port in files #:key (extract? #t) verbosity)
(catch #t
(lambda ()
(lambda _
(let loop ((header (read-ustar-header in)))
(when (and header
(not (eof-object? header)))
(unless (zero? verbosity)
(display-header header #:verbose? (> verbosity 1)))
(extract-ustar-file in header #:extract? extract?)
(read-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* (extract-ustar-archive file-name files #:key (extract? #t) verbosity)
(catch 'foo
(lambda ()
(define* (read-ustar-archive file-name files #:key (extract? #t) verbosity)
(catch #t
(lambda _
(call-with-port* (open-file file-name "rb")
(cut extract-ustar-port <> files #:extract? extract? verbosity)))
(cut read-ustar-port <> files #:extract? extract? #: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)
(extract-ustar-archive file-name files #:extract? #f #:verbosity verbosity))
(read-ustar-archive file-name files #:extract? #f #:verbosity verbosity))
(define* (list-ustar-port in file-name files #:key verbosity)
(extract-ustar-port file-name files #:extract? #f #:verbosity verbosity))
(define* (list-ustar-port in files #:key verbosity)
(read-ustar-port in files #:extract? #f #:verbosity verbosity))
;;; Local Variables:
;;; mode: scheme