From a10247aab17f63a0c9613a493b0bfd09d703144d Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 27 Oct 2018 21:29:46 +0200 Subject: [PATCH] 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. --- build-aux/build-guile.sh | 1 + configure | 10 ++ gash/bournish-commands.scm | 58 +++++++--- gash/config.scm.in | 18 ++- gash/guix-build-utils.scm | 5 + gash/guix-utils.scm | 217 +++++++++++++++++++++++++++++++++++++ gash/ustar.scm | 29 ++--- 7 files changed, 310 insertions(+), 28 deletions(-) create mode 100644 gash/guix-utils.scm 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