diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh
index 8890283..b11e9f6 100755
--- a/build-aux/build-guile.sh
+++ b/build-aux/build-guile.sh
@@ -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
diff --git a/configure b/configure
index c4e6d63..105840c 100755
--- a/configure
+++ b/configure
@@ -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
diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm
index 9b8d70d..2c27b5b 100644
--- a/gash/bournish-commands.scm
+++ b/gash/bournish-commands.scm
@@ -19,6 +19,12 @@
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see .
+;;; 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 _
diff --git a/gash/config.scm.in b/gash/config.scm.in
index 078e827..439839c 100644
--- a/gash/config.scm.in
+++ b/gash/config.scm.in
@@ -17,7 +17,11 @@
;;; along with Gash. If not, see .
(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@")
diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm
index 33ce0f6..5deb307 100644
--- a/gash/guix-build-utils.scm
+++ b/gash/guix-build-utils.scm
@@ -20,6 +20,11 @@
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see .
+;;; Commentary:
+
+;;; The initial guix-build-utils.scm was taken from Guix.
+
+;;; Code:
(define-module (gash guix-build-utils)
#:use-module (srfi srfi-1)
diff --git a/gash/guix-utils.scm b/gash/guix-utils.scm
new file mode 100644
index 0000000..e0c6906
--- /dev/null
+++ b/gash/guix-utils.scm
@@ -0,0 +1,217 @@
+;;; Gash -- Guile As SHell
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès
+;;; Copyright © 2013, 2014, 2015 Mark H Weaver
+;;; Copyright © 2014 Eric Bavier
+;;; Copyright © 2014 Ian Denhardt
+;;; Copyright © 2016 Mathieu Lirzin
+;;; Copyright © 2015 David Thompson
+;;; Copyright © 2017 Efraim Flashner
+;;; Copyright © 2017 Mathieu Othacehe
+;;; Copyright © 2018 Marius Bakke
+;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen
+;;;
+;;; 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 .
+
+;;; 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))))))
diff --git a/gash/ustar.scm b/gash/ustar.scm
index a1d1d65..3dea668 100644
--- a/gash/ustar.scm
+++ b/gash/ustar.scm
@@ -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