bournish: Add tar, from Guile100 challenge by Mark Weaver.
See https://github.com/spk121/guile100 * bin/tar.in: New file. * configure: Produce bin/tar. * .gitignore: Ignore it. * makefile (bin/tar): New target. * gash/tar.scm: New file. * gash/ustar.scm: New file. * build-aux/build-guile.sh: Compile new files.
This commit is contained in:
parent
019464acf6
commit
b8b170530c
|
@ -1,6 +1,7 @@
|
|||
*.go
|
||||
*~
|
||||
/bin/gash
|
||||
/bin/tar
|
||||
/.config.make
|
||||
/doc/version.texi
|
||||
/gash/config.scm
|
||||
|
|
|
@ -0,0 +1,12 @@
|
|||
#! /bin/sh
|
||||
# -*-scheme-*-
|
||||
exec ${GUILE-guile} -L $(dirname $0) -L $(dirname $(dirname $0)) -C $(dirname $0) -C $(dirname $(dirname $0)) --no-auto-compile -e '(tar)' -s $0 "$@"
|
||||
!#
|
||||
(define-module (tar)
|
||||
#:export (main))
|
||||
|
||||
(set! %load-path (append '("@GUILE_SITE_DIR@") %load-path))
|
||||
(set! %load-compiled-path (append '("@GUILE_SITE_CCACHE_DIR@") %load-compiled-path))
|
||||
|
||||
(define (main args)
|
||||
((@ (gash tar) main) (command-line)))
|
|
@ -51,6 +51,8 @@ gash/job.scm
|
|||
gash/peg.scm
|
||||
gash/pipe.scm
|
||||
gash/script.scm
|
||||
gash/tar.scm
|
||||
gash/ustar.scm
|
||||
gash/util.scm
|
||||
"
|
||||
|
||||
|
@ -67,6 +69,7 @@ done
|
|||
|
||||
SCRIPTS="
|
||||
bin/gash
|
||||
bin/tar
|
||||
"
|
||||
|
||||
for i in $SCRIPTS; do
|
||||
|
|
|
@ -34,6 +34,12 @@ sed \
|
|||
-e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\
|
||||
bin/gash.in > bin/gash
|
||||
chmod +x bin/gash
|
||||
sed \
|
||||
-e s,@GUILE@,$GUILE,\
|
||||
-e s,@GUILE_SITE_DIR@,$GUILE_SITE_DIR,\
|
||||
-e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\
|
||||
bin/tar.in > bin/tar
|
||||
chmod +x bin/tar
|
||||
cat > .config.make <<EOF
|
||||
BASH=$BASH
|
||||
GUILE=$GUILE
|
||||
|
|
|
@ -63,14 +63,14 @@ Options:
|
|||
|
||||
(define (display-version)
|
||||
(display (string-append "
|
||||
GASH " %version "
|
||||
gash (GASH) " %version "
|
||||
|
||||
Copryright (C) 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
|
||||
Copyright (C) 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
|
||||
and others.
|
||||
|
||||
This is gash, Guile As SHell. Gash is free software and is covered by
|
||||
This is Gash, Guile As SHell. Gash is free software and is covered by
|
||||
the GNU General Public License version 3 or later, see COPYING for the
|
||||
copyleft.
|
||||
|
||||
")))
|
||||
|
||||
(define (main args)
|
||||
|
|
|
@ -0,0 +1,66 @@
|
|||
;;; 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/>.
|
||||
|
||||
(define-module (gash tar)
|
||||
#:use-module (ice-9 getopt-long)
|
||||
#:use-module (gash config)
|
||||
#:use-module (gash ustar)
|
||||
#:export (main))
|
||||
|
||||
(define (parse-opts args)
|
||||
(let* ((option-spec
|
||||
'((create (single-char #\c))
|
||||
(extract (single-char #\x))
|
||||
(file (single-char #\f) (value #t))
|
||||
(help (single-char #\h))
|
||||
(version (single-char #\V))))
|
||||
(options (getopt-long args option-spec))
|
||||
(create? (option-ref options 'create #f))
|
||||
(extract? (option-ref options 'extract #f))
|
||||
(help? (option-ref options 'help #f))
|
||||
(files (option-ref options '() '()))
|
||||
(usage? (and (not help?) (not (or (and create? (pair? files)) extract?))))
|
||||
(version? (option-ref options 'version #f)))
|
||||
|
||||
(or
|
||||
(and version?
|
||||
(format #t "tar (GASH) ~a\n" %version)
|
||||
(exit 0))
|
||||
(and (or help? usage?)
|
||||
(format (or (and usage? (current-error-port)) (current-output-port))
|
||||
(string-append "\
|
||||
Usage: tar [OPTION]... [FILE]...
|
||||
-c, --create create a new archive
|
||||
-e, --extract extract files from an archive
|
||||
-f, --file=ARCHIVE use archive file or device ARCHIVE
|
||||
-h, --help display this help
|
||||
-V, --version display version
|
||||
"))
|
||||
(exit (or (and usage? 2) 0)))
|
||||
options)))
|
||||
|
||||
(define (main args)
|
||||
(let* ((options (parse-opts args))
|
||||
(create? (option-ref options 'create #f))
|
||||
(extract? (option-ref options 'extract #f))
|
||||
(file (option-ref options 'file "/dev/stdout"))
|
||||
(files (option-ref options '() '())))
|
||||
(cond (create?
|
||||
(write-ustar-archive file files))
|
||||
(extract?
|
||||
(read-ustar-archive file files)))))
|
|
@ -0,0 +1,318 @@
|
|||
;;; Gash --- Guile As SHell
|
||||
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
|
||||
;;; 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/>.
|
||||
|
||||
(define-module (gash ustar)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 receive)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (rnrs io ports)
|
||||
#:export (read-ustar-archive
|
||||
write-ustar-archive))
|
||||
|
||||
(define (fmt-error fmt . args)
|
||||
(error (apply format #f fmt args)))
|
||||
|
||||
;; Like 'string-pad-right', but for bytevectors. However, unlike
|
||||
;; 'string-pad-right', truncation is not allowed here.
|
||||
(define* (bytevector-pad
|
||||
bv len #:optional (byte 0) (start 0) (end (bytevector-length bv)))
|
||||
(when (< len (- end start))
|
||||
(fmt-error
|
||||
"bytevector-pad: truncation would occur: len ~a, start ~a, end ~a, bv ~s"
|
||||
len start end bv))
|
||||
(let ((result (make-bytevector len byte)))
|
||||
(bytevector-copy! bv start result 0 (- end start))
|
||||
result))
|
||||
|
||||
(define (bytevector-append . bvs)
|
||||
(let* ((lengths (map bytevector-length bvs))
|
||||
(total (fold + 0 lengths))
|
||||
(result (make-bytevector total)))
|
||||
(fold (lambda (bv len pos)
|
||||
(bytevector-copy! bv 0 result pos len)
|
||||
(+ pos len))
|
||||
0 bvs lengths)
|
||||
result))
|
||||
|
||||
(define ustar-charset
|
||||
#;
|
||||
(char-set-union (ucs-range->char-set #x20 #x23)
|
||||
(ucs-range->char-set #x25 #x40)
|
||||
(ucs-range->char-set #x41 #x5B)
|
||||
(ucs-range->char-set #x5F #x60)
|
||||
(ucs-range->char-set #x61 #x7B))
|
||||
char-set:ascii)
|
||||
|
||||
(define (valid-ustar-char? c)
|
||||
(char-set-contains? ustar-charset c))
|
||||
|
||||
(define (ustar-string n str name)
|
||||
(unless (>= n (string-length str))
|
||||
(fmt-error "~a is too long (max ~a): ~a" name n str))
|
||||
(unless (string-every valid-ustar-char? str)
|
||||
(fmt-error "~a contains unsupported character(s): ~s in ~s"
|
||||
name
|
||||
(string-filter (negate valid-ustar-char?) str)
|
||||
str))
|
||||
(bytevector-pad (string->utf8 str) n))
|
||||
|
||||
(define (ustar-0string n str name)
|
||||
(bytevector-pad (ustar-string (- n 1) str name)
|
||||
n))
|
||||
|
||||
(define (ustar-number n num name)
|
||||
(unless (and (integer? num)
|
||||
(exact? num)
|
||||
(not (negative? num)))
|
||||
(fmt-error "~a is not a non-negative exact integer: ~a" name num))
|
||||
(unless (< num (expt 8 (- n 1)))
|
||||
(fmt-error "~a is too large (max ~a): ~a" name (expt 8 (- n 1)) num))
|
||||
(bytevector-pad (string->utf8 (string-pad (number->string num 8)
|
||||
(- n 1)
|
||||
#\0))
|
||||
n))
|
||||
|
||||
(define (checksum-bv bv)
|
||||
(let ((len (bytevector-length bv)))
|
||||
(let loop ((i 0) (sum 0))
|
||||
(if (< i len)
|
||||
(loop (+ i 1) (+ sum (bytevector-u8-ref bv i)))
|
||||
sum))))
|
||||
|
||||
(define (checksum . bvs)
|
||||
(fold + 0 (map checksum-bv bvs)))
|
||||
|
||||
(define nuls (make-bytevector 512 0))
|
||||
|
||||
;; write a ustar record of exactly 512 bytes, starting with the
|
||||
;; segment of BV between START (inclusive) and END (exclusive), and
|
||||
;; padded at the end with nuls as needed.
|
||||
(define* (write-ustar-record
|
||||
port bv #:optional (start 0) (end (bytevector-length bv)))
|
||||
(when (< 512 (- end start))
|
||||
(fmt-error "write-ustar-record: record too long: start ~s, end ~s, bv ~s"
|
||||
start end bv))
|
||||
;; We could have used 'bytevector-pad' here,
|
||||
;; but instead use a method that avoids allocation.
|
||||
(put-bytevector port bv start end)
|
||||
(put-bytevector port nuls 0 (- 512 (- end start))))
|
||||
|
||||
;; write 1024 zero bytes, which indicates the end of a ustar archive.
|
||||
(define (write-ustar-footer port)
|
||||
(put-bytevector port nuls)
|
||||
(put-bytevector port nuls))
|
||||
|
||||
(define (compose-path-name dir name)
|
||||
(if (or (string-null? dir)
|
||||
(file-name-separator? (string-ref dir (- (string-length dir) 1))))
|
||||
(string-append dir name)
|
||||
(string-append dir "/" name)))
|
||||
|
||||
;; Like 'call-with-port', but also closes PORT if an error occurs.
|
||||
(define (call-with-port* port proc)
|
||||
(dynamic-wind
|
||||
(lambda () #f)
|
||||
(lambda () (proc port))
|
||||
(lambda () (close port))))
|
||||
|
||||
(define (call-with-dirstream* dirstream proc)
|
||||
(dynamic-wind
|
||||
(lambda () #f)
|
||||
(lambda () (proc dirstream))
|
||||
(lambda () (closedir dirstream))))
|
||||
|
||||
(define (files-in-directory dir)
|
||||
(call-with-dirstream* (opendir dir)
|
||||
(lambda (dirstream)
|
||||
(let loop ((files '()))
|
||||
(let ((name (readdir dirstream)))
|
||||
(cond ((eof-object? name)
|
||||
(reverse files))
|
||||
((member name '("." ".."))
|
||||
(loop files))
|
||||
(else
|
||||
(loop (cons (compose-path-name dir name) files)))))))))
|
||||
|
||||
;; split the path into prefix and name fields for purposes of the
|
||||
;; ustar header. If the entire path fits in the name field (100 chars
|
||||
;; max), then leave the prefix empty. Otherwise, try to put the last
|
||||
;; component into the name field and everything else into the prefix
|
||||
;; field (155 chars max). If that fails, put as much as possible into
|
||||
;; the prefix and the rest into the name field. This follows the
|
||||
;; behavior of GNU tar when creating a ustar archive.
|
||||
(define (ustar-path-name-split path orig-path)
|
||||
(define (too-long)
|
||||
(fmt-error "~a: file name too long" orig-path))
|
||||
(let ((len (string-length path)))
|
||||
(cond ((<= len 100) (values "" path))
|
||||
((> len 256) (too-long))
|
||||
((string-rindex path
|
||||
file-name-separator?
|
||||
(- len 101)
|
||||
(min (- len 1) 156))
|
||||
=> (lambda (i)
|
||||
(values (substring path 0 i)
|
||||
(substring path (+ i 1) len))))
|
||||
(else (too-long)))))
|
||||
|
||||
(define (write-ustar-header port path st)
|
||||
(let* ((type (stat:type st))
|
||||
(perms (stat:perms st))
|
||||
(mtime (stat:mtime st))
|
||||
(uid (stat:uid st))
|
||||
(gid (stat:gid st))
|
||||
(uname (or (false-if-exception (passwd:name (getpwuid uid)))
|
||||
""))
|
||||
(gname (or (false-if-exception (group:name (getgrgid gid)))
|
||||
""))
|
||||
|
||||
(size (case type
|
||||
((regular) (stat:size st))
|
||||
(else 0)))
|
||||
|
||||
(type-flag (case type
|
||||
((regular) "0")
|
||||
((symlink) "2")
|
||||
((char-special) "3")
|
||||
((block-special) "4")
|
||||
((directory) "5")
|
||||
((fifo) "6")
|
||||
(else (fmt-error "~a: unsupported file type ~a"
|
||||
path type))))
|
||||
|
||||
(link-name (case type
|
||||
((symlink) (readlink path))
|
||||
(else "")))
|
||||
|
||||
(dev-major (case type
|
||||
((char-special block-special)
|
||||
(quotient (stat:rdev st) 256))
|
||||
(else 0)))
|
||||
(dev-minor (case type
|
||||
((char-special block-special)
|
||||
(remainder (stat:rdev st) 256))
|
||||
(else 0)))
|
||||
|
||||
;; Convert file name separators to slashes.
|
||||
(slash-path (string-map (lambda (c)
|
||||
(if (file-name-separator? c) #\/ c))
|
||||
path))
|
||||
|
||||
;; Make the path name relative.
|
||||
;; TODO: handle drive letters on windows.
|
||||
(relative-path (if (string-every #\/ slash-path)
|
||||
"."
|
||||
(string-trim slash-path #\/)))
|
||||
|
||||
;; If it's a directory, add a trailing slash,
|
||||
;; otherwise remove trailing slashes.
|
||||
(full-path (case type
|
||||
((directory) (string-append relative-path "/"))
|
||||
(else (string-trim-right relative-path #\/)))))
|
||||
|
||||
(receive (prefix name) (ustar-path-name-split full-path path)
|
||||
|
||||
(let* ((%name (ustar-string 100 name "file name"))
|
||||
(%mode (ustar-number 8 perms "file mode"))
|
||||
(%uid (ustar-number 8 uid "user id"))
|
||||
(%gid (ustar-number 8 gid "group id"))
|
||||
(%size (ustar-number 12 size "file size"))
|
||||
(%mtime (ustar-number 12 mtime "modification time"))
|
||||
(%type-flag (ustar-string 1 type-flag "type flag"))
|
||||
(%link-name (ustar-string 100 link-name "link name"))
|
||||
(%magic (ustar-0string 6 "ustar" "magic field"))
|
||||
(%version (ustar-string 2 "00" "version number"))
|
||||
(%uname (ustar-0string 32 uname "user name"))
|
||||
(%gname (ustar-0string 32 gname "group name"))
|
||||
(%dev-major (ustar-number 8 dev-major "dev major"))
|
||||
(%dev-minor (ustar-number 8 dev-minor "dev minor"))
|
||||
(%prefix (ustar-string 155 prefix "directory name"))
|
||||
|
||||
(%dummy-checksum (string->utf8 " "))
|
||||
|
||||
(%checksum
|
||||
(bytevector-append
|
||||
(ustar-number
|
||||
7
|
||||
(checksum %name %mode %uid %gid %size %mtime
|
||||
%dummy-checksum
|
||||
%type-flag %link-name %magic %version
|
||||
%uname %gname %dev-major %dev-minor
|
||||
%prefix)
|
||||
"checksum")
|
||||
(string->utf8 " "))))
|
||||
|
||||
(write-ustar-record port
|
||||
(bytevector-append
|
||||
%name %mode %uid %gid %size %mtime
|
||||
%checksum
|
||||
%type-flag %link-name %magic %version
|
||||
%uname %gname %dev-major %dev-minor
|
||||
%prefix))))))
|
||||
|
||||
(define (write-ustar-path port path)
|
||||
(let* ((path (if (string-every file-name-separator? path)
|
||||
file-name-separator-string
|
||||
(string-trim-right path file-name-separator?)))
|
||||
(st (lstat path))
|
||||
(type (stat:type st))
|
||||
(size (stat:size st)))
|
||||
(write-ustar-header port path st)
|
||||
(case type
|
||||
((regular)
|
||||
(call-with-port* (open-file path "rb")
|
||||
(lambda (in)
|
||||
(let ((buf (make-bytevector 512)))
|
||||
(let loop ((left size))
|
||||
(when (positive? left)
|
||||
(let* ((asked (min left 512))
|
||||
(obtained (get-bytevector-n! in buf 0 asked)))
|
||||
(when (or (eof-object? obtained)
|
||||
(< obtained asked))
|
||||
(fmt-error "~a: file appears to have shrunk" path))
|
||||
(write-ustar-record port buf 0 obtained)
|
||||
(loop (- left obtained)))))))))
|
||||
((directory)
|
||||
(for-each (lambda (path) (write-ustar-path port path))
|
||||
(files-in-directory path))))))
|
||||
|
||||
(define (read-ustar-archive)
|
||||
(format (current-error-port) "TODO\n"))
|
||||
|
||||
(define (write-ustar-archive output-path paths)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(call-with-port* (open-file output-path "wb")
|
||||
(lambda (out)
|
||||
(for-each (lambda (path)
|
||||
(write-ustar-path out path))
|
||||
paths)
|
||||
(write-ustar-footer out))))
|
||||
(lambda (key subr message args . rest)
|
||||
(false-if-exception (delete-file output-path))
|
||||
(format (current-error-port) "ERROR: ~a\n"
|
||||
(apply format #f message args))
|
||||
(exit 1))))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; mode: scheme
|
||||
;;; eval: (put 'call-with-port* 'scheme-indent-function 1)
|
||||
;;; eval: (put 'call-with-dirstream* 'scheme-indent-function 1)
|
||||
;;; End:
|
10
makefile
10
makefile
|
@ -4,12 +4,14 @@
|
|||
default: all
|
||||
|
||||
.config.make: makefile
|
||||
|
||||
bin/gash: bin/gash.in | do-configure
|
||||
bin/tar: bin/tar.in | do-configure
|
||||
|
||||
do-configure:
|
||||
./configure --prefix=$(PREFIX)
|
||||
|
||||
bin/gash: bin/gash.in
|
||||
./configure --prefix=$(PREFIX)
|
||||
|
||||
all: all-go bin/gash
|
||||
all: all-go do-configure
|
||||
|
||||
all-go:
|
||||
build-aux/build-guile.sh
|
||||
|
|
Loading…
Reference in New Issue