andrius
/
gash
mirror of https://git.savannah.gnu.org/git/gash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Remove external commands. 

* gash/bournish-commands.scm, gash/commands/*, gash/compress.scm,
gash/guix-utils.scm, gash/lzw.scm, gash/ustar.scm: Delete files.
* gash/builtins.scm, gash/gash.scm, gash/script.scm: Remove references
to deleted modules.
* tests/100-basename-*, tests/100-dirname-*, tests/100-sed-*,
tests/100-tar-*, tests/100-tr-*: Delete files.
* Makefile.am: Remove deleted modules and tests.
This commit is contained in:
Timothy Sample 2019-01-11 22:20:52 -05:00
parent 42f9fb2671
commit 171796317f
78 changed files with 7 additions and 3420 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
Makefile.am
View File

@ -53,39 +53,14 @@ dist-hook:
echo $(VERSION) > $(distdir)/.tarball-version
MODULES = \
gash/bournish-commands.scm \
gash/builtins.scm \
gash/commands/basename.scm \
gash/commands/cat.scm \
gash/commands/chmod.scm \
gash/commands/compress.scm \
gash/commands/cp.scm \
gash/commands/dirname.scm \
gash/commands/find.scm \
gash/commands/grep.scm \
gash/commands/ls.scm \
gash/commands/mkdir.scm \
gash/commands/mv.scm \
gash/commands/reboot.scm \
gash/commands/rm.scm \
gash/commands/rmdir.scm \
gash/commands/sed.scm \
gash/commands/sed/reader.scm \
gash/commands/tar.scm \
gash/commands/touch.scm \
gash/commands/tr.scm \
gash/commands/wc.scm \
gash/commands/which.scm \
gash/compress.scm \
gash/config.scm \
gash/environment.scm \
gash/gash.scm \
gash/geesh.scm \
gash/grammar.scm \
gash/guix-utils.scm \
gash/io.scm \
gash/job.scm \
gash/lzw.scm \
gash/peg.scm \
gash/peg/cache.scm \
gash/peg/codegen.scm \
@ -96,7 +71,6 @@ MODULES = \
gash/readline.scm \
gash/script.scm \
gash/shell-utils.scm \
gash/ustar.scm \
gash/util.scm \
geesh/built-ins/break.scm \
geesh/built-ins/cd.scm \
@ -255,30 +229,7 @@ FULL_TESTS = \
tests/100-cd-foo.sh \
tests/100-test.sh \
tests/100-test-file.sh \
tests/100-bracket-file.sh \
tests/100-basename-root.sh \
tests/100-dirname-root.sh \
tests/100-basename-autoconf.sh \
tests/100-dirname-autoconf.sh \
tests/100-sed.sh \
tests/100-sed-once.sh \
tests/100-sed-global.sh \
tests/100-sed-case.sh \
tests/100-sed-group.sh \
tests/100-sed-group-extended.sh \
tests/100-sed-twice.sh \
tests/100-sed-undo.sh \
tests/100-sed-file.sh \
tests/100-sed-fooRbar.sh \
tests/100-sed-pattern-address.sh \
tests/100-sed-quit.sh \
tests/100-sed-autoconf-basename.sh \
tests/100-tar.sh \
tests/100-tar-Z.sh \
tests/100-tar-Z-old.sh \
tests/100-tar-Z-pipe.sh \
tests/100-tar-ro.sh \
tests/100-tr.sh
tests/100-bracket-file.sh
TESTS = $(UNIT_TESTS) $(FULL_TESTS)
@ -301,10 +252,7 @@ XFAIL_TESTS = \
tests/50-redirect-append.sh \
tests/50-redirect-pipe.sh \
tests/50-redirect-merge.sh \
tests/60-function-at.sh \
tests/100-basename-autoconf.sh \
tests/100-dirname-autoconf.sh \
tests/100-tar-Z-pipe.sh
tests/60-function-at.sh
# These tests will not be run. Put tests here
# that pass or fail based on environmental

128
gash/bournish-commands.scm
View File

@ -1,128 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; 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 bournish.scm was taken from Guix.
;;; Code:
(define-module (gash bournish-commands)
#:use-module (srfi srfi-26)
#:use-module (gash io)
#:use-module (gash config)
#:use-module (gash shell-utils)
#:use-module ((gash commands basename) #:prefix gash:)
#:use-module (gash commands cat)
#:use-module (gash commands compress)
#:use-module (gash commands cp)
#:use-module ((gash commands dirname) #:prefix gash:)
#:use-module (gash commands find)
#:use-module (gash commands grep)
#:use-module (gash commands ls)
#:use-module (gash commands mkdir)
#:use-module (gash commands mv)
#:use-module (gash commands reboot)
#:use-module (gash commands rm)
#:use-module (gash commands sed)
#:use-module (gash commands tar)
#:use-module (gash commands touch)
#:use-module (gash commands tr)
#:use-module (gash commands wc)
#:use-module (gash commands which)
#:export (
%bournish-commands
basename-command
cat-command
compress-command
cp-command
dirname-command
find-command
grep-command
ls-command
mkdir-command
mv-command
reboot-command
rm-command
sed-command
tar-command
touch-command
tr-command
rm-command
wc-command
which-command
))
(define (wrap-command name command)
(lambda args
(lambda _
(catch #t
(cut apply command (cons name args))
(lambda (key . args)
(format (current-error-port) "~a: ~a ~a\n" name key args)
(case key
((quit) (car args))
(else 1)))))))
(define basename-command (wrap-command "basename" gash:basename))
(define cat-command (wrap-command "cat" cat))
(define compress-command (wrap-command "compress" compress))
(define cp-command (wrap-command "cp" cp))
(define dirname-command (wrap-command "dirname" gash:dirname))
(define find-command (wrap-command "find" find))
(define grep-command (wrap-command "grep" grep))
(define ls-command (wrap-command "ls" ls))
(define mkdir-command (wrap-command "mkdir" mkdir'))
(define mv-command (wrap-command "mv" mv))
(define reboot-command (wrap-command "reboot" reboot'))
(define rm-command (wrap-command "rm" rm))
(define rmdir-command (wrap-command "rmdir" rmdir))
(define sed-command (wrap-command "sed" sed))
(define tar-command (wrap-command "tar" tar))
(define touch-command (wrap-command "touch" touch))
(define tr-command (wrap-command "tr" tr))
(define wc-command (wrap-command "wc" wc))
(define which-command (wrap-command "which" which))
(define (%bournish-commands)
`(
("basename" . ,basename-command)
("cat" . ,cat-command)
("compress" . ,compress-command)
("cp" . ,cp-command)
("dirname" . ,dirname-command)
("find" . ,find-command)
("grep" . ,grep-command)
("ls" . ,ls-command)
("mkdir" . ,mkdir-command)
("mv" . ,mv-command)
("reboot" . ,reboot-command)
("rm" . ,rm-command)
("rmdir" . ,rmdir-command)
("sed" . ,sed-command)
("tar" . ,tar-command)
("touch" . ,touch-command)
("tr" . ,tr-command)
("wc" . ,wc-command)
("which" . ,which-command)
))

6
gash/builtins.scm
View File

@ -30,7 +30,6 @@
#:use-module (gash config)
#:use-module (gash gash) ; %prefer-builtins?
#:use-module (gash bournish-commands)
#:use-module (gash environment)
#:use-module (gash shell-utils)
#:use-module (gash io)
@ -155,10 +154,7 @@ GASH is work in progress; many language constructs work, globbing
mostly works, pipes work, some redirections work.
")
(display "\nIt has these builtin commands:\n")
(display-tabulated (map car %builtin-commands))
(when (or %prefer-builtins? (not (PATH-search-path "ls")))
(display "\nand features the following, somewhat naive, bournish commands:\n")
(display-tabulated (map car %bournish-commands)))))
(display-tabulated (map car %builtin-commands))))
(define command-command
(case-lambda

77
gash/commands/basename.scm
View File

@ -1,77 +0,0 @@
;;; 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 basename)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 receive)
#:use-module (gash config)
#:export (
basename
))
(define (basename . args)
(let* ((option-spec
'((multiple (single-char #\a))
(help (single-char #\h))
(version (single-char #\V))
(suffix (single-char #\s) (value #t))
(zero (single-char #\z))))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(suffix (option-ref options 'suffix #f))
(mutliple? (or suffix (option-ref options 'multiple #f)))
(zero? (option-ref options 'zero #f))
(files (option-ref options '() '()))
(usage? (and (not help?) (null? files))))
(cond (version? (format #t "basename (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: basename NAME [SUFFIX]
or: basename OPTION... NAME...
Options:
-a, --multiple support multiple arguments and treat each as a NAME
--help display this help and exit
-s, --suffix=SUFFIX remove a trailing SUFFIX; implies -a
--version output version information and exit
-z, --zero end each output line with NUL, not newline
")
(exit (if usage? 2 0)))
(else
(receive (files suffix)
(if suffix (values files suffix)
(values (list-head files 1) (and (pair? (cdr files)) (cadr files))))
(for-each (lambda (file)
(let ((file
(if (and (> (string-length file) 1)
(string-suffix? "/" file)) (string-drop-right file 1)
file)))
(cond ((string=? file "/") (display "/"))
(suffix (display ((@ (guile) basename) file suffix)))
(else (display ((@ (guile) basename) file)))))
(if zero? (display #\nul) (newline)))
files))))))
(define main basename)

41
gash/commands/cat.scm
View File

@ -1,41 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; 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 bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands cat)
#:use-module (srfi srfi-1)
#:use-module (gash shell-utils)
#:export (cat))
(define (cat name . args)
(fold (lambda (file p)
(if (string=? file "-") (dump-port (current-input-port) (current-output-port))
(call-with-input-file file
(lambda (port)
(dump-port port (current-output-port))))))
0 (if (null? args) '("-") args)))
(define main cat)

99
gash/commands/chmod.scm
View File

@ -1,99 +0,0 @@
;;; 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 chmod)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash guix-utils)
#:use-module (gash shell-utils)
#:export (
chmod
))
(define (chmod . args)
(let* ((option-spec
'((reference (value #t))
(recursive (single-char #\R))
(help (single-char #\h))
(version (single-char #\V))
(writable (single-char #\w))
(readable (single-char #\r))
(executable (single-char #\x))
(xecutable (single-char #\X))))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(reference (option-ref options 'reference #f))
(readable? (option-ref options 'readable #f))
(writable? (option-ref options 'writable #f))
(executable? (option-ref options 'executable? #f))
(xecutable? (option-ref options 'xecutable? #f))
(usage? (and (not help?)
(< (length files) (if (or reference
readable?
writable?
executable?
xecutable?) 1 2)))))
(cond (version? (format #t "chmod (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: chmod [OPTION]... {MODE | --reference=REF_FILE} FILE...
Change the mode of each FILE to MODE.
With --reference, change the mode of each FILE to that of RFILE.
Options:
--help display this help and exit
-R, --recursive change files and directories recursively
--reference=FILE use FILE's mode instead of MODE values
--version output version information and exit
Each MODE is of the form '[ugoa]*([-+=]([rwxXst]*|[ugo]))+|[-+=][0-7]+'.
")
(exit (if usage? 2 0)))
(else
(receive (modifiers files)
(cond
(reference (values (list (make-numeric-chmodifier
(stat:mode (stat reference)))) files))
((or readable? writable? executable? xecutable?)
(let* ((m '())
(m (if readable? (cons (make-chmodifier 'o '- '(r)) m) m))
(m (if writable? (cons (make-chmodifier 'o '- '(w)) m) m))
(m (if executable? (cons (make-chmodifier 'o '- '(x)) m) m))
(m (if xecutable? (cons (make-chmodifier 'o '- '(X)) m) m)))
(values m files)))
(else (values (parse-chmodifiers (car files)) (cdr files))))
(let ((files (if (not (option-ref options 'recursive #f)) files
(append-map (cut find-files <> #:directories? #t) files))))
(for-each (cut apply-chmodifiers <> modifiers) (reverse files))))))))
(define main chmod)

68
gash/commands/compress.scm
View File

@ -1,68 +0,0 @@
;;; 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 compress)
#:use-module (ice-9 getopt-long)
#:use-module (srfi srfi-1)
#:use-module (gash config)
#:use-module (gash compress)
#:use-module (gash guix-utils)
#:export (
compress
))
(define (compress . args)
(let* ((option-spec
'((bits (single-char #\b) (value #t))
(decompress (single-char #\d))
(help (single-char #\h))
(stdout (single-char #\c))
(verbose (single-char #\v))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(bits (string->number (option-ref options 'bits "16")))
(decompress? (option-ref options 'decompress #f))
(stdout? (option-ref options 'stdout #f))
(files (option-ref options '() '()))
(help? (option-ref options 'help #f))
(usage? (and (not help?) (or (and (null? files) (isatty? (current-input-port))))))
(verbose? (option-ref options 'verbose #f))
(version? (option-ref options 'version #f)))
(cond (version? (format #t "compress (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: compress [OPTION]... [FILE]...
-b, --bits=BITS use a maximum of BITS bits per code [16]
-c, --stdout write on standard output, keep original files unchanged
-d, --decompress decompress
-h, --help display this help
-v, --verbose show compression ratio
-V, --version display version
")
(exit (if usage? 2 0)))
(decompress? (if (pair? files) (uncompress-file (car files) verbose?)
(uncompress-port (current-input-port) (current-output-port) verbose?)))
(else (if (pair? files) (compress-file (car files) bits verbose?)
(compress-port (current-input-port) (current-output-port) bits verbose?))))))
(define main compress)

84
gash/commands/cp.scm
View File

@ -1,84 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; 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 bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands cp)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash shell-utils)
#:export (
cp
))
(define (copy-file-force? force?)
(lambda (src dest)
(if (not force?) (copy-file src dest)
(catch 'system-error
(lambda _
(copy-file src dest))
(lambda (key func fmt msg errno . rest)
(format #t "errno:~s\n" (car errno))
(match errno
((13)
(delete-file dest)
(copy-file src dest))
(_ (throw key func fmt msg errno))))))))
(define (cp name . args)
(define (usage port)
(display "Usage: cp [OPTION]... SOURCE... DEST
Options:
-f, --force if an existing destination file cannot be opened,
remove it and try again
-h, --help display this help and exit
-V, --version display version information and exit
" port))
(match args
(((or "-f" "--force") args ...)
(apply cp (cons 'force args)))
(((or "-h" "--help") t ...)
(usage (current-output-port))
(exit 0))
(((or "-V" "--version") t ...)
(format #t "cp (GASH) ~a\n" %version) (exit 0))
((source (and (? directory-exists?) dir))
((copy-file-force? (eq? name 'force))
source (string-append dir "/" (basename source))))
((source dest)
((copy-file-force? (eq? name 'force)) source dest))
((sources ... dir)
(unless (directory-exists? dir)
(error (format #f "mv: target `~a' is not a directory\n" dir)))
(for-each
(copy-file-force? (eq? name 'force))
sources
(map (compose (cute string-append dir "/" <>) basename)
sources)))
(_ (usage (current-error-port)) (exit 2))))
(define main cp)

62
gash/commands/dirname.scm
View File

@ -1,62 +0,0 @@
;;; 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 dirname)
#:use-module (ice-9 getopt-long)
#:use-module (gash config)
#:export (
dirname
))
(define (dirname . args)
(let* ((option-spec
'((help (single-char #\h))
(version (single-char #\V))
(zero (single-char #\z))))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(zero? (option-ref options 'zero #f))
(usage? (and (not help?) (null? files))))
(cond (version? (format #t "dirname (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: dirname [OPTION] NAME...
Output each NAME with its last non-slash component and trailing slashes
removed; if NAME contains no /'s, output '.' (meaning the current directory).
Options:
--help display this help and exit
--version output version information and exit
-z, --zero end each output line with NUL, not newline
")
(exit (if usage? 2 0)))
(else
(for-each (lambda (file)
(display ((@ (guile) dirname) file))
(if zero? (display #\nul) (newline)))
files)))))
(define main dirname)

65
gash/commands/find.scm
View File

@ -1,65 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; 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 bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands find)
#:use-module (ice-9 getopt-long)
#:use-module (gash config)
#:use-module (gash io)
#:use-module (gash shell-utils)
#:export (
find
))
(define (find . args)
(let* ((option-spec
'((help)
(version)))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(files (if (null? files) '(".") files))
(file (car files)))
(when (> (length files) 1)
(format (current-error-port) "find: too many FILEs: ~s\n" files)
(error "find failed"))
;; TODO: find [OPTION]... [FILE]... [EXPRESSION]...
;; and options: esp: -x, -L
(cond (version? (format #t "find (GASH) ~a\n" %version))
(help? (display "Usage: find [OPTION]... [FILE]
Options:
--help display this help and exit
--version display version information and exit
"))
(else
(let* ((files (find-files file #:directories? #t #:fail-on-error? #t)))
(for-each stdout files))))))
(define main find)

109
gash/commands/grep.scm
View File

@ -1,109 +0,0 @@
;;; 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 grep)
#:use-module (ice-9 ftw)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (gash guix-utils)
#:use-module (gash compress)
#:use-module (gash config)
#:use-module (gash io)
#:use-module (gash ustar)
#:use-module (gash util)
#:use-module (gash shell-utils)
#:export (
grep
))
(define (grep . args)
(let* ((option-spec
'((help)
(line-number (single-char #\n))
(files-with-matches (single-char #\l))
(files-without-match (single-char #\L))
(with-file-name (single-char #\H))
(no-file-name (single-char #\h))
(only-matching (single-char #\o))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (version? (format #t "grep (GASH) ~a\n" %version))
(help? (display "Usage: grep [OPTION]... PATTERN [FILE]...
Options:
--help display this help and exit
-h, --no-filename suppress the file name prefix on output
-H, --with-filename print file name with output lines
-l, --files-with-matches print only names of FILEs with selected lines
-L, --files-without-match print only names of FILEs with no selected lines
-n, --line-number print line number with output lines
-o, --only-matching show only the part of a line matching PATTERN
-V, --version display version information and exit
"))
((null? files) #t)
(else
(let* ((pattern (car files))
(files (if (pair? (cdr files)) (cdr files)
(list "-")))
(matches (append-map (cut grep+ pattern <>) files)))
(define (display-match o)
(let* ((s (grep-match-string o))
(s (if (option-ref options 'only-matching #f)
(substring s (grep-match-column o) (grep-match-end-column o))
s))
(s (if (option-ref options 'line-number #f)
(string-append (number->string (grep-match-line o)) ":" s)
s))
(s (if (option-ref options 'with-file-name #f)
(string-append (grep-match-file-name o) ":" s)
s)))
(stdout s)))
(define (files-with-matches)
(delete-duplicates (map grep-match-file-name matches)))
(cond ((option-ref options 'files-with-matches #f)
(let ((result (files-with-matches)))
(and (pair? result)
(for-each stdout result)
0)))
((option-ref options 'files-without-match #f)
(let* ((result (files-with-matches))
(result (filter (negate (cut member <> result)) files)))
(and (pair? result)
(for-each stdout result)
0)))
(else
(and (pair? matches)
(for-each display-match matches)
0))))))))
(define main grep)

106
gash/commands/ls.scm
View File

@ -1,106 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; 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 bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands ls)
#:use-module (ice-9 ftw)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash io)
#:use-module (gash shell-utils)
#:export (
ls
))
(cond-expand
(guile
;; Support -1, see https://lists.gnu.org/archive/html/bug-guile/2018-07/msg00009.html
(module-define! (resolve-module '(ice-9 getopt-long)) 'short-opt-rx (make-regexp "^-([a-zA-Z0-9]+)(.*)")))
(else))
(define (ls . args)
(let* ((option-spec
'((all (single-char #\a))
(help)
(long (single-char #\l))
(one-file-per-line (single-char #\1))
(version)))
(options (getopt-long args option-spec))
(all? (option-ref options 'all #f))
(help? (option-ref options 'help #f))
(long? (option-ref options 'long #f))
(one-file-per-line? (option-ref options 'one-file-per-line #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (version? (format #t "ls (GASH) ~a\n" %version))
(help? (display "Usage: ls [OPTION]... [FILE]...
Options:
-a, --all do not ignore entries starting with .
--help display this help and exit
-l, --long use a long listing format
--version display version information and exit
-1 list one file per line
"))
(else
(let* ((files (if (null? files) (scandir ".")
(append-map (lambda (file)
(catch 'system-error
(lambda ()
(match (stat:type (lstat file))
('directory
;; Like GNU ls, list the contents of
;; FILE rather than FILE itself.
(match (scandir file
(match-lambda
((or "." "..") #f)
(_ #t)))
(#f
(list file))
((files ...)
(map (cut string-append file "/" <>)
files))))
(_
(list file))))
(lambda args
(let ((errno (system-error-errno args)))
(format (current-error-port) "~a: ~a~%"
file (strerror errno))
'()))))
files)))
(files (if all? files
(filter (negate (cut string-prefix? "." <>)) files))))
(cond (long? (for-each (lambda (f) (display-file f) (newline)) files))
(one-file-per-line? (for-each stdout files))
(else (display-tabulated files))))))))
(define main ls)

74
gash/commands/mkdir.scm
View File

@ -1,74 +0,0 @@
;;; 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 mkdir)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash guix-utils)
#:use-module (gash shell-utils)
#:export (
mkdir'
))
(define (mkdir' . args)
(let* ((option-spec
'((help (single-char #\h))
(mode (single-char #\m) (value #t))
(parents (single-char #\p))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(files (option-ref options '() '()))
(mode (option-ref options 'mode #f))
(parents? (option-ref options 'parents #f))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(usage? (and (not help?) (null? files))))
(cond (version? (format #t "mkdir (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: mkdir [OPTION]... DIRECTORY...
Create the DIRECTORY(ies), if they do not already exist.
Options:
--help display this help and exit
-m, --mode=MODE set file mode (as in chmod), not a=rwx - umask
-p, --parents no error if existing, make parent directories as needed
--version output version information and exit
")
(exit (if usage? 2 0)))
(else
(let ((mode (if mode (umask (chmodifiers->mode (parse-chmodifiers mode)))
#o755)))
(for-each (if parents? mkdir-p (@ (guile) mkdir)) files))))))
(define main mkdir')

63
gash/commands/mv.scm
View File

@ -1,63 +0,0 @@
;;; 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 mv)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash shell-utils)
#:export (
mv
))
(define (mv name . args)
(define (usage port)
(display "Usage: mv [OPTION]... SOURCE... DEST
Options:
-f, --force ignored for compatibility
-h, --help display this help and exit
-V, --version display version information and exit
" port))
(match args
(((or "-f" "--force") args ...)
(apply mv (cons name args)))
(((or "-h" "--help") t ...)
(usage (current-output-port))
(exit 0))
(((or "-V" "--version") t ...)
(format #t "mv (GASH) ~a\n" %version) (exit 0))
((source (and (? directory-exists?) dir))
(rename-file source (string-append dir "/" (basename source))))
((source dest)
(rename-file source dest))
((sources ... dir)
(unless (directory-exists? dir)
(error (format #f "mv: target `~a' is not a directory\n" dir)))
(for-each
rename-file
sources
(map (compose (cute string-append dir "/" <>) basename)
sources)))
(_ (usage (current-error-port)) (exit 2))))
(define main mv)

44
gash/commands/reboot.scm
View File

@ -1,44 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; 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 bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands reboot)
#:export (
reboot'
))
(define (reboot' name . args)
"Emit code for 'reboot'."
;; Normally Bournish is used in the initrd, where 'reboot' is provided
;; directly by (guile-user). In other cases, just bail out.
(if (defined? 'reboot)
(reboot)
(begin
(format (current-error-port)
"I don't know how to reboot, sorry about that!~%")
1)))
(define main reboot')

53
gash/commands/rm.scm
View File

@ -1,53 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; 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 bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands rm)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (gash shell-utils)
#:export (
rm
))
(define (rm name . args)
(let ((recursive? (or (member "-r" args)
(member "-fr" args)
(member "-rf" args)))
(force? (or (member "-f" args)
(member "-rf" args)
(member "-fr" args)))
(files (filter (negate (cut string-prefix? "-" <>)) args)))
(catch #t
(lambda _
(if recursive? (for-each delete-file-recursively files)
(for-each delete-file files))
#t)
(lambda ( . rest)
(or force?
(apply throw rest))))))
(define main rm)

71
gash/commands/rmdir.scm
View File

@ -1,71 +0,0 @@
;;; 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 rmdir)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash guix-utils)
#:use-module (gash shell-utils)
#:export (
rmdir
))
(define (rmdir . args)
(let* ((option-spec
'((help (single-char #\h))
(parents (single-char #\p))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(files (option-ref options '() '()))
(parents? (option-ref options 'parents #f))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(usage? (and (not help?) (null? files))))
(cond (version? (format #t "rmdir (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: rmdir [OPTION]... DIRECTORY...
Remove the DIRECTORY(ies), if they are empty.
Options:
--help display this help and exit
-p, --parents remove DIRECTORY and its ancestors; e.g., 'rmdir -p a/b/c' is
similar to 'rmdir a/b/c a/b a'
--version output version information and exit
")
(exit (if usage? 2 0)))
(else
(if parents? (for-each rmdir-p files)
(for-each rmdir files))))))
(define main rmdir)

233
gash/commands/sed.scm
View File

@ -1,233 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;;
;;; 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 sed)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-26)
#:use-module (gash commands sed reader)
#:use-module (gash config)
#:use-module (gash guix-utils)
#:use-module (gash shell-utils)
#:use-module (gash util)
#:export (
sed
))
(define (replace->lambda string global?)
(define (replace->string m s)
(list->string
(let loop ((lst (string->list string)))
(cond ((null? lst) '())
((null? (cdr lst)) lst)
((and (eq? (car lst) #\\)
(char-numeric? (cadr lst)))
(let ((i (- (char->integer (cadr lst)) (char->integer #\0))))
(append (string->list (match:substring m i)) (loop (cddr lst)))))
((and (eq? (car lst) #\\)
(eq? (cadr lst) #\n))
(append '(#\newline) (cddr lst)))
((and (eq? (car lst) #\\)
(eq? (cadr lst) #\t))
(append '(#\tab) (cddr lst)))
((and (eq? (car lst) #\\)
(eq? (cadr lst) #\r))
(append '(#\return) (cddr lst)))
((and (eq? (car lst) #\\)
(eq? (cadr lst) #\\))
(append '(#\\ #\\) (cddr lst)))
(else (cons (car lst) (loop (cdr lst))))))))
(lambda (l m+)
;; Iterate over matches M+ and
;; return the modified line
;; based on L.
(let loop ((m* m+) ; matches
(o 0) ; offset in L
(r '())) ; result
(match m*
(()
(let ((r (cons (substring l o) r)))
(string-concatenate-reverse r)))
((m . rest)
(let* ((refs (- (vector-length m) 2))
(replace (replace->string m string))
(replace (cons* replace (substring l o (match:start m)) r)))
(if global? (loop rest (match:end m) replace)
(loop '() (match:end m) replace))))))))
(define (replace-escapes str)
(let* ((str (string-replace-string str "\\n" "\n"))
(str (string-replace-string str "\\r" "\r"))
(str (string-replace-string str "\\t" "\t")))
str))
(define extended? (make-parameter #f))
(define quit-tag (make-prompt-tag))
(define (make-regexp-factory)
(let* ((previous-pattern #f)
(ht (make-hash-table))
(make-regexp/memoized
(lambda args
(or (hash-ref ht args #f)
(let ((regexp (apply make-regexp args)))
(hash-set! ht args regexp)
regexp)))))
(lambda (pattern . flags)
(if (string-null? pattern)
(if previous-pattern
(apply make-regexp/memoized previous-pattern flags)
(error "SED: no previous regular expression"))
(begin
(set! previous-pattern pattern)
(apply make-regexp/memoized pattern flags))))))
(define regexp-factory
(make-parameter
(lambda _
(error "SED: no regexp-factory available"))))
(define (substitute str pattern replacement flags)
(let* ((global? (memq 'g flags))
(flags (cons (if (extended?) regexp/extended regexp/basic)
(if (memq 'i flags) `(,regexp/icase) '())))
(regexp (apply (regexp-factory) (replace-escapes pattern) flags))
(proc (replace->lambda (replace-escapes replacement) global?)))
(match (list-matches regexp str)
((and m+ (_ _ ...)) (proc str m+))
(_ str))))
(define (address->pred address)
(if (string? address)
(let* ((flags `(,(if (extended?) regexp/extended regexp/basic)))
(pattern (replace-escapes address))
(regexp (apply (regexp-factory) pattern flags)))
(cut regexp-exec regexp <>))
(error "SED: unsupported address type" address)))
(define (execute-function function str)
(match function
(('begin . commands)
(execute-commands commands str))
(('q) (abort-to-prompt quit-tag str))
(('s pattern replacement flags)
(substitute str pattern replacement flags))
(_ (error "SED: unsupported function" function))))
(define (execute-commands commands str)
(match commands
(() str)
((('always function) . rest)
(execute-commands rest (execute-function function str)))
((('at address function) . rest)
;; XXX: This should be "compiled" ahead of time so that it only
;; runs once intead of once per line.
(if ((address->pred address) str)
(execute-commands rest (execute-function function str))
(execute-commands rest str)))
((cmd . rest) (error "SED: could not process command" cmd))))
(define* (edit-stream commands #:optional
(in (current-input-port))
(out (current-output-port)))
(parameterize ((regexp-factory (make-regexp-factory)))
(let loop ((pattern-space (read-line in)))
(unless (eof-object? pattern-space)
(call-with-prompt quit-tag
(lambda ()
(let ((result (execute-commands commands pattern-space)))
(display result out)
(newline out)
(loop (read-line in))))
(lambda (cont result)
(display result out)
(newline out))))
#t)))
(define (sed . args)
(let* ((option-spec
'((expression (single-char #\e) (value #t))
(extended (single-char #\r))
(posix-extended (single-char #\E))
(file (single-char #\f) (value #t))
(help (single-char #\h))
(in-place (single-char #\i))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(files (option-ref options '() '()))
(help? (option-ref options 'help #f))
(in-place? (option-ref options 'in-place #f))
(usage? (and (not help?) (or (and (null? files) (isatty? (current-input-port))))))
(version? (option-ref options 'version #f)))
(when (or (option-ref options 'extended #f)
(option-ref options 'posix-extended #f))
(extended? #t))
(cond (version? (format #t "sed (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: sed [OPTION]... [SCRIPT] [FILE]...
-e, --expression=SCRIPT add SCRIPT to the commands to be executed
-E, -r, --regexp-extended use extended regular expressions in the script
-f, --file=SCRIPT add contents of SCRIPT to the commands to be executed
-h, --help display this help
-i, --in-place edit files in place
-V, --version display version
")
(exit (if usage? 2 0)))
(else
(let* ((script-files (multi-opt options 'file))
(scripts (multi-opt options 'expression)))
(receive (scripts files)
(cond
((and (pair? script-files) (pair? scripts))
;; XXX: Until we respect the order in which scripts
;; are specified, we cannot do this properly.
(error "SED: cannot mix argument and file scripts"))
((pair? script-files)
(values (map (cut call-with-input-file <> get-string-all)
script-files)
files))
((pair? scripts) (values scripts files))
(else (values (list-head files 1) (cdr files))))
(let* ((script (string-join scripts "\n"))
(commands
(call-with-input-string script
(cut read-sed-all <> #:extended? (extended?)))))
(cond ((and in-place? (pair? files))
(with-atomic-file-replacement
(cut edit-stream commands <> <>)))
((pair? files)
(for-each (lambda (file)
(call-with-input-file file
(cut edit-stream commands <>)))
files))
(else (edit-stream commands))))))))))
(use-modules (ice-9 rdelim))
(define main sed)

322
gash/commands/sed/reader.scm
View File

@ -1,322 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;;
;;; 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 commands sed reader)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (read-sed
read-sed-all))
;;; Commentary:
;;;
;;; This module provides a reader for the `sed' stream editing
;;; language.
;;;
;;; Code:
(define (next-char port)
"Discard one character from PORT, and return the next character to
be read."
(get-char port)
(lookahead-char port))
(define (get-char-while cs port)
"Read text from PORT until a character is found that does not belong
to the character set CS."
(let loop ((chr (lookahead-char port)) (acc '()))
(if (or (eof-object? chr)
(not (char-set-contains? cs chr)))
(reverse-list->string acc)
(loop (next-char port) (cons chr acc)))))
(define (read-number port)
"Read a nonnegative integer from PORT."
(let* ((str (get-char-while char-set:digit port))
(n (string->number str)))
(unless n
(error "Expected a number"))
n))
(define (read-bracket-expression port)
"Read a regular expression bracket expression from PORT,
assuming that it is positioned just after the initial open
bracket (`['). Return as a string the complete bracket expression,
including both brackets.
This procedure takes into account all the ways that a close
bracket (`]') may occur in a bracket expression without terminating
it, such as named character classes and backslash escapes."
(define (read-until-pair chr1 chr2 port)
(let loop ((chunk (read-delimited chr1 port 'concat)) (acc '()))
(unless (and (not (string-null? chunk))
(char=? (string-ref chunk (1- (string-length chunk)))
chr1))
(error "Unterminated bracket expression"))
(if (char=? (lookahead-char port) chr2)
(string->list (string-concatenate (reverse! acc)))
(loop (read-delimited chr1 port 'concat) (cons chunk acc)))))
(define (read-rest)
(let loop ((chr (get-char port)) (acc '()))
(match chr
((? eof-object?) (error "Unterminated bracket expression"))
(#\] (reverse-list->string (cons #\] acc)))
(#\[ (match (get-char port)
((? eof-object?) (error "Unterminated bracket expression"))
((and cc (or #\= #\. #\:))
(let ((class (read-until-pair cc #\] port)))
(loop (get-char port) (append-reverse class acc))))
(chr (loop (get-char port) (cons* chr #\[ acc)))))
(#\\ (match (get-char port)
((? eof-object?) (error "Unterminated bracket expression"))
(chr (loop (get-char port) (cons* chr #\\ acc)))))
(chr (loop (get-char port) (cons chr acc))))))
(match (lookahead-char port)
(#\^ (match (next-char port)
(#\] (get-char port) (string-append "[^]" (read-rest)))
(_ (string-append "[^" (read-rest)))))
(#\] (get-char port) (string-append "[]" (read-rest)))
(_ (string-append "[" (read-rest)))))
(define %extended? (make-parameter #f))
(define (read-re-until delim port)
"Read text from PORT as a regular expression until encountering the
delimiting character DELIM. Return the text of the regular expression
with the trailing delimiter discarded.
This procedure takes into account the ways that the delimiter could
appear in the regular expression without ending it, such as in a
bracket expression or capture group. It order to determine what
constitutes a capture group, it uses the `%extended?' parameter."
(let loop ((chr (lookahead-char port)) (depth 0) (acc '()))
(cond
((eof-object? chr)
(error "Unterminated regular expression"))
((char=? chr #\[)
(get-char port)
(let* ((be (read-bracket-expression port))
(be-chars (string->list be)))
(loop (lookahead-char port) depth (append-reverse! be-chars acc))))
((and (%extended?) (char=? chr #\())
(loop (next-char port) (1+ depth) (cons #\( acc)))
((and (%extended?) (char=? chr #\)))
(loop (next-char port) (1- depth) (cons #\) acc)))
((char=? chr #\\)
(if (%extended?)
(match (next-char port)
((? eof-object?) (error "Unterminated regular expression"))
(nchr (loop (next-char port) depth (cons* nchr chr acc))))
(match (next-char port)
((? eof-object?) (error "Unterminated regular expression"))
(#\( (loop (next-char port) (1+ depth) (cons* #\( chr acc)))
(#\) (loop (next-char port) (1- depth) (cons* #\) chr acc)))
(nchr (loop (next-char port) depth (cons* nchr chr acc))))))
((and (= depth 0)
(char=? chr delim))
(get-char port)
(reverse-list->string acc))
(else (loop (next-char port) depth (cons chr acc))))))
(define (read-string-until delim port)
"Read text from PORT until encountering the character DELIM,
taking into account escaping with backslashes (`\\')."
(let loop ((chr (lookahead-char port)) (acc '()))
(cond
((eof-object? chr) (error "Unterminated string"))
((char=? chr #\\)
(let ((next-chr (next-char port)))
(if (eof-object? next-chr)
(error "Unterminated string")
(loop (next-char port) (cons* next-chr chr acc)))))
((and (char=? chr delim))
(get-char port)
(reverse-list->string acc))
(else (loop (next-char port) (cons chr acc))))))
(define (read-re port)
"Read a delimited regular expression from PORT."
(let ((delim (get-char port)))
(if (eof-object? delim)
(error "Expected regular expression")
(read-re-until delim port))))
(define (read-re+string port)
"Read a delimited regular expression and a replacement string from
PORT."
(let ((delim (get-char port)))
(if (eof-object? delim)
(error "Expected regular expression and replacement")
(let* ((re (read-re-until delim port))
(str (read-string-until delim port)))
`(,re . ,str)))))
(define (read-string+string port)
"Read two delimited strings from PORT."
(let ((delim (get-char port)))
(if (eof-object? delim)
(error "Expected characters and their replacements")
(let* ((str1 (read-string-until delim port))
(str2 (read-string-until delim port)))
`(,str1 . ,str2)))))
(define (read-text port)
"Read text from PORT until either an unescaped newline or end of
file is encountered."
(get-char-while char-set:whitespace port)
(let loop ((chr (get-char port)) (acc '()))
(match chr
((or (? eof-object?)
#\newline)
(reverse-list->string acc))
(#\\
(let ((next-chr (get-char port)))
(if (eof-object? next-chr)
(error "Unterminated text")
(loop (get-char port) (cons next-chr acc)))))
(_ (loop (get-char port) (cons chr acc))))))
(define char-set:label
(string->char-set
(string-append "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"abcdefghijklmnopqrstuvwxyz"
"0123456789._-")))
(define label-char? (cut char-set-contains? char-set:label <>))
(define (read-label port)
"Read a label from PORT."
(get-char-while char-set:whitespace port)
(get-char-while char-set:label port))
(define (read-flags port)
"Read flags (for the `s' command) from PORT."
(let loop ((chr (lookahead-char port)) (acc '()))
(match chr
((? eof-object?) (reverse! acc))
(#\g (loop (next-char port) (cons 'g acc)))
(#\i (loop (next-char port) (cons 'i acc)))
(#\p (loop (next-char port) (cons 'p acc)))
((? (cut char-set-contains? char-set:digit <>))
(let ((n (read-number port)))
(loop (lookahead-char port) (cons n acc))))
(#\w
(get-char port)
(let ((filename (read-text port)))
(reverse! (cons `(w ,filename) acc))))
(_ (reverse! acc)))))
(define (read-address port)
"Read an address from PORT."
(match (lookahead-char port)
(#\$ '$)
((? (cut char-set-contains? char-set:digit <>)) (read-number port))
(_ (read-re port))))
(define* (read-function port #:key (depth 0))
"Read a function and its arguments from PORT."
(get-char-while char-set:whitespace port)
(match (get-char port)
(#\{ `(begin ,@(%read-sed-all port #:depth (1+ depth))))
(#\a `(a ,(read-text port)))
(#\b `(b ,(read-label port)))
(#\c `(c ,(read-text port)))
(#\d '(d))
(#\D '(D))
(#\g '(g))
(#\G '(G))
(#\h '(h))
(#\H '(H))
(#\i `(i ,(read-text port)))
(#\l '(l))
(#\n '(n))
(#\N '(N))
(#\p '(p))
(#\P '(P))
(#\q '(q))
(#\r `(r ,(read-text port)))
(#\s (match-let (((re . str) (read-re+string port)))
`(s ,re ,str ,(read-flags port))))
(#\t `(t ,(read-label port)))
(#\w `(w ,(read-text port)))
(#\x '(x))
(#\y (match-let (((str1 . str2) (read-string+string port)))
`(y ,str1 ,str2)))
(#\: `(: ,(read-label port)))
(#\= `(= ,(1+ (port-line port))))
(#\# `(comment ,(read-line port)))))
(define char-set:function
(string->char-set "abcdDgGhHilnNpPqrstwxy:=#"))
(define function-char? (cut char-set-contains? char-set:function <>))
(define (read-addresses port)
"Read zero, one, or two address from PORT, separated by a
comma (`,') and delimited by a function name."
(match (lookahead-char port)
((? function-char?) '())
(_ (let ((address1 (read-address port)))
(match (lookahead-char port)
(#\, (let* ((_ (get-char port))
(address2 (read-address port)))
`(,address1 ,address2)))
(_ `(,address1)))))))
(define char-set:whitespace+semi (char-set-adjoin char-set:whitespace #\;))
(define* (%read-sed port #:key (depth 0))
"Read a sed command from PORT."
(get-char-while char-set:whitespace+semi port)
(match (lookahead-char port)
((? eof-object?) (eof-object))
(#\}
(get-char port)
(if (> depth 0)
(eof-object)
(error "Unmatched close brace")))
(_ (let* ((addresses (read-addresses port))
(function (read-function port #:depth depth)))
(match addresses
(() `(always ,function))
((address) `(at ,address ,function))
((address1 address2) `(in (,address1 . ,address2) ,function)))))))
(define* (%read-sed-all port #:key (depth 0))
"Read a sequence of sed commands from PORT."
(let loop ((cmd (%read-sed port #:depth depth)) (acc '()))
(match cmd
((? eof-object?) (reverse! acc))
(_ (loop (%read-sed port #:depth depth) (cons cmd acc))))))
(define* (read-sed port #:key (extended? #f))
"Read a sed command from PORT. If EXTENDED? is set, treat regular
expressions as extended rather than basic."
(parameterize ((%extended? extended?))
(%read-sed port)))
(define* (read-sed-all port #:key (extended? #f))
"Read a sequence of sed commands from PORT. If EXTENDED? is set,
treat regular expressions as extended rather than basic."
(parameterize ((%extended? extended?))
(%read-sed-all port)))

168
gash/commands/tar.scm
View File

@ -1,168 +0,0 @@
;;; 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))
(directory (single-char #\C) (value #t))
(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))
(strip (value #t))
(strip-components (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))))))
(directory (option-ref options 'directory #f))
(sort-order (and=> (option-ref options 'sort #f) string->symbol))
(strip (string->number
(or (option-ref options 'strip #f)
(option-ref options 'strip-components #f)
"0")))
(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))
(file (if (or (not directory) (string-prefix? "/" file) (equal? file "-")) file
(string-append (getcwd) "/" file))))
(when directory
(chdir directory))
(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, --directory=DIR change to directory DIR
-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
--strip-components=NUM strip NUM leading components from file names
names on extraction
-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 (eq? sort-order 'name) (sort files string<)
files))
(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 sort-order `(#:sort-order ,sort-order) '())
#: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 sort-order `(#:sort-order ,sort-order) '())
#: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 #:strip strip #: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 #:strip strip #:verbosity (1+ verbosity))))
(list-ustar-archive file files #:strip strip #:verbosity (1+ verbosity)))))))
(define main tar)

85
gash/commands/touch.scm
View File

@ -1,85 +0,0 @@
;;; 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 touch)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash guix-utils)
#:use-module (gash shell-utils)
#:export (
touch
))
(define (create-or-touch file time)
(let ((exists? (file-exists? file)))
(when (not exists?) (with-output-to-file file (cut display "")))
(cond (time (utime file time time))
(exists? (let ((time (current-time)))
(utime file time time))))))
(define (parse-date string)
(if (string-prefix? "@" string)
(string->number (substring string 1))
(error (format #f "touch: cannot parse date:~a\n" string))))
(define (touch . args)
(let* ((option-spec
'((date (single-char #\d) (value #t))
(help (single-char #\h))
(reference (single-char #\r) (value #t))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(date (option-ref options 'date #f))
(reference (option-ref options 'reference #f))
(files (option-ref options '() '()))
(usage? (and (not help?) (null? files))))
(cond (version? (format #t "touch (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: touch [OPTION]... FILE...
Update the access and modification times of each FILE to the current time.
Options:
-d, --date=DATE parse DATE and use it instead of current time
--help display this help and exit
-r, --reference=FILE use FILE's times instead of current time
--version output version information and exit
Each MODE is of the form '[ugoa]*([-+=]([rwxXst]*|[ugo]))+|[-+=][0-7]+'.
")
(exit (if usage? 2 0)))
(else
(let ((time (and=> date parse-date)))
(for-each (cut create-or-touch <> time) files))))))
(define main touch)

69
gash/commands/tr.scm
View File

@ -1,69 +0,0 @@
;;; 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 tr)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 rdelim)
#:use-module (gash config)
#:use-module (gash util)
#:export (
tr
))
(define (tr . args)
(let* ((option-spec
'((delete (single-char #\d))
(help (single-char #\h))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(delete? (option-ref options 'delete #f))
(files (option-ref options '() '()))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(usage? (and (not help?) (not (or (and delete? (= (length files) 1))
(= (length files) 2))))))
(cond (version? (format #t "tr (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: tr [OPTION]... SET1 [SET2]
Options:
-d, --delete delete characters in SET1, do not translate
-h, --help display this help and exit
-V, --version display version information and exit
")
(exit (if usage? 2 0)))
(delete?
(let* ((s (car files))
(s (string-replace-string s "\\n" "\n"))
(s (string-replace-string s "\\r" "\r"))
(s (string-replace-string s "\\t" "\t"))
(s (string->char-set s)))
(let loop ((line (read-line (current-input-port) 'concat)))
(if (eof-object? line) #t
(begin
(display (string-delete s line))
(loop (read-line (current-input-port) 'concat)))))))
(else
(format #t "TODO: TR A B\n")))))
(define main tr)

81
gash/commands/wc.scm
View File

@ -1,81 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; 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 bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands wc)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (ice-9 match)
#:use-module (gash shell-utils)
#:export (
wc
))
(define (lines+chars port)
"Return the number of lines and number of chars read from PORT."
(let loop ((lines 0) (chars 0))
(match (read-char port)
((? eof-object?) ;done!
(values lines chars))
(#\newline ;recurse
(loop (1+ lines) (1+ chars)))
(_ ;recurse
(loop lines (1+ chars))))))
(define (wc-print file)
(let-values (((lines chars)
(call-with-input-file file lines+chars)))
(format #t "~a ~a ~a~%" lines chars file)))
(define (wc-l-print file)
(let-values (((lines chars)
(call-with-input-file file lines+chars)))
(format #t "~a ~a~%" lines file)))
(define (wc-c-print file)
(let-values (((lines chars)
(call-with-input-file file lines+chars)))
(format #t "~a ~a~%" chars file)))
(define (wc- . files)
(for-each wc-print (filter file-exists?* files)))
(define (wc-l . files)
(for-each wc-l-print (filter file-exists?* files)))
(define (wc-c . files)
(for-each wc-c-print (filter file-exists?* files)))
(define (wc name . args)
(cond ((member "-l" args)
(apply wc-l (delete "-l" args)))
((member "-c" args)
(apply wc-c (delete "-c" args)))
(else
(apply wc- args))))
(define main wc)

38
gash/commands/which.scm
View File

@ -1,38 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; 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 bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands which)
#:use-module (gash io)
#:use-module (gash shell-utils)
#:export (
which
))
(define (which name program . rest)
(stdout (search-path (executable-path) program)))
(define main which)

162
gash/compress.scm
View File

@ -1,162 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2013 Daniel Hartwig <mandyke@gmail.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 lzw.scm was taken from the Guile100 challenge
;;; https://github.com/spk121/guile100 from a contribution by Daniel
;;; Hartwig.
;;; Code:
(define-module (gash compress)
#:use-module (gash lzw)
#:use-module (ice-9 control)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-37)
#:export (compress-file
compress-port
uncompress-file
uncompress-port))
(define *program-name* "compress (GASH)")
(define (_ msg . rest)
msg)
(define (error* status msg . args)
(force-output)
(let ((port (current-error-port)))
(when *program-name*
(display *program-name* port)
(display ": " port))
(apply format port msg args)
(newline port)
(unless (zero? status)
;; This call to 'abort' causes 'main' to immediately return the
;; specified status value. Similar to 'exit' but more
;; controlled, for example, when using the REPL to debug,
;; 'abort' will not cause the entire process to terminate.
;;
;; This is also handy to attempt processing every file, even
;; after an error has occured. To do this, establish another
;; prompt at an interesting place inside 'main'.
(abort (lambda (k)
status)))))
(define (make-file-error-handler filename)
(lambda args
(error* 1 (_ "~a: ~a")
filename
(strerror (system-error-errno args)))))
(define (system-error-handler key subr msg args rest)
(apply error* 1 msg args))
(define (compression-ratio nbytes-in nbytes-out)
(exact->inexact (/ (- nbytes-in nbytes-out) nbytes-in)))
(define (write-lzw-header port bits)
(put-bytevector port (u8-list->bytevector (list #x1F #x9D bits))))
(define (compress-port in out bits verbose?)
(set-port-encoding! in "ISO-8859-1")
(set-port-encoding! out "ISO-8859-1")
#;
(begin
(write-lzw-header out bits)
(%lzw-compress (cute get-u8 in)
(cute put-u16 out <>)
eof-object?
(expt 2 bits)))
(let* ((in-bv (get-bytevector-all in))
(out-bv (lzw-compress in-bv #:table-size (expt 2 bits))))
(write-lzw-header out bits)
(put-bytevector out out-bv)))
(define (compress-file infile bits verbose?)
(catch 'system-error
(lambda ()
(let ((outfile (string-append infile ".Z")))
(when (string-suffix? ".Z" infile)
(error* 1 (_ "~a: already has .Z suffix") infile))
(when (file-exists? outfile)
(error* 1 (_ "~a: already exists") outfile))
(let ((in (open-file infile "rb"))
(out (open-file outfile "wb")))
;; TODO: Keep original files ownership, modes, and access
;; and modification times.
(compress-port in out bits verbose?)
(when verbose?
(format #; (current-error-port)
(current-output-port)
(_ "~a: compression: ~1,2h%\n") ; '~h' is localized '~f'.
infile
(* 100 (compression-ratio (port-position in)
(port-position out)))))
(for-each close-port (list in out))
(delete-file infile))))
system-error-handler))
(define (read-lzw-header port)
(match (bytevector->u8-list (get-bytevector-n port 3))
((#x1F #x9D bits)
(and (<= 9 bits 16)
(values bits)))
(x #f)))
(define (uncompress-port in out verbose?)
(set-port-encoding! in "ISO-8859-1")
(set-port-encoding! out "ISO-8859-1")
(let ((bits (read-lzw-header in)))
(unless bits
(error* 1 (_ "incorrect header")))
#;
(%lzw-uncompress (cute get-u16 in)
(cute put-u8 out <>)
eof-object?
(expt 2 bits))
(let* ((in-bv (get-bytevector-all in))
(out-bv (lzw-uncompress in-bv #:table-size (expt 2 bits))))
(put-bytevector out out-bv))))
(define (uncompress-file infile verbose?)
(catch 'system-error
(lambda ()
(let ((outfile (string-drop-right infile 2)))
(when (not (string-suffix? ".Z" infile))
(error* 1 (_ "~a: does not have .Z suffix") infile))
(when (file-exists? outfile)
(error* 1 (_ "~a: already exists") outfile))
(let ((in (open-file infile "rb"))
(out (open-file outfile "wb")))
(uncompress-port in out verbose?)
(when verbose?
(format #; (current-error-port)
(current-output-port)
(_ "~a: compression: ~1,2h%\n") ; '~h is localized '~f'.
infile
(* 100 (compression-ratio (port-position out)
(port-position in)))))
(for-each close-port (list in out))
(delete-file infile))))
system-error-handler))

18
gash/gash.scm
View File

@ -14,7 +14,6 @@
#:use-module (gash config)
#:use-module (gash builtins)
#:use-module (gash bournish-commands)
#:use-module (gash environment)
#:use-module (gash job)
#:use-module (gash pipe)
@ -51,11 +50,9 @@
(call-with-input-file file-name parse))
(define (display-help)
(let ((builtins (sort (map car (append (%bournish-commands) ;;%builtin-commands
)) string<)))
(display (string-append "\
(display (string-append "\
Usage: gash [OPTION]... [FILE]...
or gash [OPTION]... -- BUILTIN [ARG]...
or gash [OPTION]...
Options:
-c, --command=STRING Evaluate STRING and exit
@ -67,10 +64,7 @@ Options:
--prefer-builtins Use builtins, even if command is available in PATH
-v, --version Display the version
-x, --xtrace Print simple command trace
Builtins:
" (string-join builtins) "
"))))
")))
(define (display-version)
(display (string-append "
@ -97,7 +91,6 @@ copyleft.
(geesh (single-char #\g))
(version (single-char #\v))
(xtrace (single-char #\x))))
(builtin-command-line (and=> (member "--" args) cdr))
(args (take-while (negate (cut equal? <> "--")) args))
(options (getopt-long args option-spec #:stop-at-first-non-option #t))
(command? (option-ref options 'command #f))
@ -128,11 +121,6 @@ copyleft.
(parameterize ((%command-line files))
(run ast)))
(exit (script-status))))
(builtin-command-line
(let* ((builtin (car builtin-command-line))
(args (cdr builtin-command-line))
(command (assoc-ref (%bournish-commands) builtin)))
((apply command args))))
(#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history"))
(thunk (lambda ()
(let loop ((line (readline (prompt))))

210
gash/guix-utils.scm
View File

@ -1,210 +0,0 @@
;;; 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-11)
#:use-module (ice-9 format)
#:autoload (ice-9 popen) (open-pipe*)
#:use-module ((gash shell-utils) #:select (dump-port))
#:use-module (ice-9 match)
#: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 ()
(match command
(((? string? name) . _)
(apply execl name command))
(((? procedure? proc) . args)
(apply proc args))))
(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 ()
(match command
(((? string? name) . _)
(apply execl name command))
(((? procedure? proc) . args)
(apply proc args))))
(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))))))

151
gash/lzw.scm
View File

@ -1,151 +0,0 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2013 Daniel Hartwig <mandyke@gmail.com>
;;;
;;; 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 lzw.scm was taken from the Guile100 challenge
;;; https://github.com/spk121/guile100 from a contribution by Daniel
;;; Hartwig.
;;; Code:
(define-module (gash lzw)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (lzw-compress
lzw-uncompress
%lzw-compress
%lzw-uncompress))
;; This procedure adapted from an example in the Guile Reference
;; Manual.
(define (make-serial-number-generator start end)
(let ((current-serial-number (- start 1)))
(lambda ()
(and (< current-serial-number end)
(set! current-serial-number (+ current-serial-number 1))
current-serial-number))))
(define (put-u16 port k)
;; Little endian.
(put-u8 port (logand k #xFF))
(put-u8 port (logand (ash k -8) #xFF)))
(define (get-u16 port)
;; Little endian. Order of evaluation is important, use 'let*'.
(let* ((a (get-u8 port))
(b (get-u8 port)))
(if (any eof-object? (list a b))
(eof-object)
(logior a (ash b 8)))))
(define (%lzw-compress in out done? table-size)
(let ((codes (make-hash-table table-size))
(next-code (make-serial-number-generator 0 table-size))
(universe (iota 256))
(eof-code #f))
;; Populate the initial dictionary with all one-element strings
;; from the universe.
(for-each (lambda (obj)
(hash-set! codes (list obj) (next-code)))
universe)
(set! eof-code (next-code))
(let loop ((cs '()))
(let ((c (in)))
(cond ((done? c)
(unless (null? cs)
(out (hash-ref codes cs)))
(out eof-code)
(values codes))
((hash-ref codes (cons c cs))
(loop (cons c cs)))
(else
(and=> (next-code)
(cut hash-set! codes (cons c cs) <>))
(out (hash-ref codes cs))
(loop (cons c '()))))))))
(define (ensure-bv-input-port bv-or-port)
(cond ((port? bv-or-port)
bv-or-port)
((bytevector? bv-or-port)
(open-bytevector-input-port bv-or-port))
(else
(scm-error 'wrong-type-arg "ensure-bv-input-port"
"Wrong type argument in position ~a: ~s"
(list 1 bv-or-port) (list bv-or-port)))))
(define (for-each-right proc lst)
(let loop ((lst lst))
(unless (null? lst)
(loop (cdr lst))
(proc (car lst)))))
(define (%lzw-uncompress in out done? table-size)
(let ((strings (make-hash-table table-size))
(next-code (make-serial-number-generator 0 table-size))
(universe (iota 256))
(eof-code #f))
(for-each (lambda (obj)
(hash-set! strings (next-code) (list obj)))
universe)
(set! eof-code (next-code))
(let loop ((previous-string '()))
(let ((code (in)))
(unless (or (done? code)
(= code eof-code))
(unless (hash-ref strings code)
(hash-set! strings
code
(cons (last previous-string) previous-string)))
(for-each-right out
(hash-ref strings code))
(let ((cs (hash-ref strings code)))
(and=> (and (not (null? previous-string))
(next-code))
(cut hash-set! strings <> (cons (last cs)
previous-string)))
(loop cs)))))))
(define* (lzw-compress bv #:key (table-size 65536) dictionary)
(call-with-values
(lambda ()
(open-bytevector-output-port))
(lambda (output-port get-result)
(let ((dict (%lzw-compress (cute get-u8 (ensure-bv-input-port bv))
(cute put-u16 output-port <>)
eof-object?
table-size)))
(if dictionary
(values (get-result) dict)
(get-result))))))
(define* (lzw-uncompress bv #:key (table-size 65536) dictionary)
(call-with-values
(lambda ()
(open-bytevector-output-port))
(lambda (output-port get-result)
(let ((dict (%lzw-uncompress (cute get-u16 (open-bytevector-input-port bv))
(cute put-u8 output-port <>)
eof-object?
table-size)))
(if dictionary
(values (get-result) dict)
(get-result))))))

4
gash/script.scm
View File

@ -29,7 +29,6 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (gash bournish-commands)
#:use-module (gash builtins)
#:use-module (gash config)
#:use-module (gash environment)
@ -314,8 +313,7 @@
(when (not (access? program X_OK))
(format (current-error-port) "gash: ~a: permission denied\n" command))
#f)
((and command (or (assoc-ref %builtin-commands command)
(assoc-ref (%bournish-commands) command)))
((and command (or (assoc-ref %builtin-commands command)))
=>
(lambda (command)
(if args

570
gash/ustar.scm
View File

@ -1,570 +0,0 @@
;;; 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/>.
;;; Commentary:
;;; The initial ustar.scm was taken from the Guile100 challenge
;;; https://github.com/spk121/guile100 from a contribution by Mark H
;;; Weaver.
;;; Code:
(define-module (gash ustar)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (gash shell-utils)
#:export (read-ustar-archive
read-ustar-port
write-ustar-archive
write-ustar-port
list-ustar-archive
list-ustar-port))
(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->bytevector str (make-transcoder (latin-1-codec))) 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->bytevector (string-pad (number->string num 8)
(- n 1)
#\0)
(make-transcoder (latin-1-codec)))
n))
(define (checksum-bv bv)
(let ((len (bytevector-length bv)))
(let loop ((i 0) (sum 0))
(if (= i len) sum
(loop (+ i 1) (+ sum (bytevector-u8-ref bv i)))))))
(define (checksum . bvs)
(fold + 0 (map checksum-bv bvs)))
(define nuls (make-bytevector 512 0))
;; read a ustar record of exactly 512 bytes.
(define (read-ustar-record port)
(get-bytevector-n port 512))
;; 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 (bv->ustar-string bv name)
(string-trim-right (bv->ustar-0string bv name) (compose zero? char->integer)))
(define (bv->ustar-number bv name)
(let ((string (bv->ustar-string bv name)))
(or (string->number string 8) 0)))
(define (bv->ustar-0string bv name)
(bytevector->string bv (make-transcoder (latin-1-codec))))
(define-immutable-record-type <ustar-header>
(make-ustar-header name
mode
uid
gid
size
mtime
checksum
;; space
type-flag
link-name
magic
version
uname
gname
dev-major
dev-minor
prefix)
ustar-header?
(name ustar-header-name )
(mode ustar-header-mode )
(uid ustar-header-uid )
(gid ustar-header-gid )
(size ustar-header-size )
(mtime ustar-header-mtime )
(checksum ustar-header-checksum )
;;(space ustar-header-space )
(type-flag ustar-header-type-flag)
(link-name ustar-header-link-name)
(magic ustar-header-magic )
(version ustar-header-version )
(uname ustar-header-uname )
(gname ustar-header-gname )
(dev-major ustar-header-dev-major)
(dev-minor ustar-header-dev-minor)
(prefix ustar-header-prefix ))
(define (ustar-header-type header)
(let ((file-types #(regular - symlink char-special block-special directory fifo))
(type (string->number (ustar-header-type-flag header))))
(when (or (not type)
(< type 0)
(>= type (vector-length file-types)))
(fmt-error "~a: unsupported file type ~a"
(ustar-header-file-name header) type))
(vector-ref file-types (string->number (ustar-header-type-flag header)))))
(define ustar-header-field-size-alist
'((name . 100)
(mode . 8)
(uid . 8)
(gid . 8)
(size . 12)
(mtime . 12)
(checksum . 7)
(space . 1)
(type-flag . 1)
(link-name . 100)
(magic . 6)
(version . 2)
(uname . 32)
(gname . 32)
(dev-major . 8)
(dev-minor . 8)
(prefix . 155)))
(define (ustar-footer? bv)
(every zero? (array->list bv)))
(define (sub-bytevector bv offset size)
(let ((sub (make-bytevector size)))
(bytevector-copy! bv offset sub 0 size)
sub))
(define (read-ustar-header port)
(define offset
(let ((offset 0))
(lambda (. args)
(if (null? args) offset
(let ((n (car args)))
(set! offset (+ offset n))
n)))))
(let ((%record (read-ustar-record port)))
(and (not (eof-object? %record))
(not (ustar-footer? %record))
(let* ((field-bv-alist
`((dummy-checksum . ,(string->utf8 " "))
,@(map
(match-lambda ((field . size)
(cons field (sub-bytevector %record (offset) (offset size)))))
ustar-header-field-size-alist)))
(checksum-fields '(name mode uid gid size mtime
dummy-checksum
type-flag link-name magic version
uname gname dev-major dev-minor
prefix))
(checksum (apply checksum (map (cut assoc-ref field-bv-alist <>)
checksum-fields)))
(header
(make-ustar-header
(bv->ustar-string (assoc-ref field-bv-alist 'name ) "file name" )
(bv->ustar-number (assoc-ref field-bv-alist 'mode ) "file mode" )
(bv->ustar-number (assoc-ref field-bv-alist 'uid ) "user id" )
(bv->ustar-number (assoc-ref field-bv-alist 'gid ) "group id" )
(bv->ustar-number (assoc-ref field-bv-alist 'size ) "file size" )
(bv->ustar-number (assoc-ref field-bv-alist 'mtime ) "modification time")
(bv->ustar-number (assoc-ref field-bv-alist 'checksum ) "checksum" )
;; (bv->ustar-string (assoc-ref field-bv-alist 'space ) "space" )
(bv->ustar-string (assoc-ref field-bv-alist 'type-flag) "type flag" )
(bv->ustar-string (assoc-ref field-bv-alist 'link-name) "link name" )
(bv->ustar-string (assoc-ref field-bv-alist 'magic ) "magic field" )
(bv->ustar-string (assoc-ref field-bv-alist 'version ) "version number" )
(bv->ustar-string (assoc-ref field-bv-alist 'uname ) "user name" )
(bv->ustar-string (assoc-ref field-bv-alist 'gname ) "group name" )
(bv->ustar-number (assoc-ref field-bv-alist 'dev-major) "dev major" )
(bv->ustar-number (assoc-ref field-bv-alist 'dev-minor) "dev minor" )
(bv->ustar-string (assoc-ref field-bv-alist 'prefix ) "directory name" ))))
(when (not (= (ustar-header-checksum header) checksum))
(error "checksum mismatch, expected: ~s, got: ~s\n"
(ustar-header-checksum header)
checksum))
header))))
(define* (write-ustar-header port path st #:key group mtime numeric-owner? owner)
(let* ((type (stat:type st))
(perms (stat:perms st))
(mtime (or mtime (stat:mtime st)))
(uid (or owner (stat:uid st)))
(gid (or group (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-file port file-name #:key group mtime numeric-owner? owner sort-order verbosity)
(let* ((file-name (if (string-every file-name-separator? file-name)
file-name-separator-string
(string-trim-right file-name file-name-separator?)))
(st (lstat file-name))
(type (stat:type st))
(size (stat:size st)))
(unless (zero? verbosity)
(if (> verbosity 1) (display-file file-name st)
(display file-name))
(newline))
(write-ustar-header port file-name st #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner)
(case type
((regular)
(call-with-port* (open-file file-name "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" file-name))
(write-ustar-record port buf 0 obtained)
(loop (- left obtained)))))))))
((directory)
(let* ((files (files-in-directory file-name))
(files (if (eq? sort-order 'name) (sort files string<)
files)))
(for-each (lambda (file-name) (write-ustar-file port file-name
#:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity))
files))))))
(define* (ustar-header-file-name header #:key (strip 0))
(let* ((name (ustar-header-name header))
(prefix (ustar-header-prefix header))
(file-name (if (string-null? prefix) name
(string-append prefix "/" name))))
(if (zero? strip) file-name
(string-join (list-tail (string-split file-name #\/) strip) "/"))))
(define* (read-ustar-file port header #:key (extract? #t) (strip 0))
(let* ((size (ustar-header-size header))
(file-name (ustar-header-file-name header #:strip strip))
(dir (dirname file-name))
(extract? (and extract? (not (string-null? file-name))))
(thunk (lambda _
(set-port-encoding! (current-output-port) "ISO-8859-1") ; bootstrap-guile uses default UTF-8
(let loop ((read 0))
(and (< read size)
(let ((record (read-ustar-record port)))
(and record
(let* ((read (+ read 512))
(block (if (< read size) record
(sub-bytevector record 0 (- size -512 read)))))
(when extract?
(display (bv->ustar-0string block "block")))
(loop read)))))))))
(when extract?
(mkdir-p dir))
(if extract?
(let ((mtime (ustar-header-mtime header)))
(case (ustar-header-type header)
((regular)
(if (file-exists? file-name) (delete-file file-name))
(with-output-to-file file-name thunk #:binary #t)
(utime file-name mtime mtime)
(chmod file-name (ustar-header-mode header)))
((directory)
(mkdir-p file-name)
(utime file-name mtime mtime))
((symlink) (symlink (ustar-header-link-name header) file-name ))))
(thunk))))
(define (ustar-header->stat header)
(let* ((stat-size 17)
(si (list->vector (iota stat-size)))
(st (make-vector stat-size 0)))
(vector-set! st (stat:mode si) (ustar-header-mode header))
(vector-set! st (stat:uid si) (ustar-header-uid header))
(vector-set! st (stat:gid si) (ustar-header-gid header))
(vector-set! st (stat:size si) (ustar-header-size header))
(vector-set! st (stat:mtime si) (ustar-header-mtime header))
(vector-set! st (stat:type si) (ustar-header-type header))
st))
(define* (display-header header #:key verbose?)
(let ((file-name (ustar-header-file-name header)))
(if verbose? (display-file (ustar-header-file-name header) (ustar-header->stat header))
(display file-name))
(newline)))
(define* (write-ustar-port out files #:key group mtime numeric-owner? owner sort-order verbosity)
(for-each
(cut write-ustar-file out <>
#:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:sort-order sort-order #:verbosity verbosity)
files)
(write-ustar-footer out))
(define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner sort-order verbosity)
(catch #t
(lambda _
(call-with-port* (open-file file-name "wb")
(cut write-ustar-port <> files
#:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:sort-order sort-order #:verbosity verbosity)))
(lambda (key subr message args . rest)
(false-if-exception (delete-file file-name))
(format (current-error-port) "ERROR: ~a\n"
(apply format #f message args))
(exit 1))))
(define* (read-ustar-port in files #:key (extract? #t) (strip 0) verbosity)
(let ((dirs
(let loop ((header (read-ustar-header in)) (dirs '()))
(if (not (and header (not (eof-object? header)))) dirs
(begin
(unless (zero? verbosity)
(display-header header #:verbose? (> verbosity 1)))
(read-ustar-file in header #:extract? extract? #:strip strip)
(loop (read-ustar-header in)
(if (eq? (ustar-header-type header) 'directory) (cons header dirs)
dirs)))))))
(define (chmod-header header)
(chmod (ustar-header-file-name header #:strip strip)
(ustar-header-mode header)))
(for-each chmod-header dirs)))
(define* (read-ustar-archive file-name files #:key (extract? #t) (strip 0) verbosity)
(catch #t
(lambda _
(call-with-port* (open-file file-name "rb")
(cut read-ustar-port <> files #:extract? extract? #:strip strip #: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 (strip 0) verbosity)
(read-ustar-archive file-name files #:extract? #f #:strip strip #:verbosity verbosity))
(define* (list-ustar-port in files #:key (strip 0) verbosity)
(read-ustar-port in files #:extract? #f #:strip strip #:verbosity verbosity))
;;; Local Variables:
;;; mode: scheme
;;; eval: (put 'call-with-port* 'scheme-indent-function 1)
;;; eval: (put 'call-with-dirstream* 'scheme-indent-function 1)
;;; End:

6
tests/100-basename-autoconf.sh
View File

@ -1,6 +0,0 @@
if (\basename -- /) >/dev/null 2>&1 && \test "X`\basename -- / 2>&1`" = "X/"; then
as_basename=basename
else
as_basename=false
fi
echo as_basename:$as_basename

1
tests/100-basename-autoconf.stdout
View File

@ -1 +0,0 @@
as_basename:basename

2
tests/100-basename-root.sh
View File

@ -1,2 +0,0 @@
\basename /root
\basename /

2
tests/100-basename-root.stdout
View File

@ -1,2 +0,0 @@
root
/

6
tests/100-dirname-autoconf.sh
View File

@ -1,6 +0,0 @@
if (as_dir=`\dirname -- /` && \test "X$as_dir" = X/) >/dev/null 2>&1; then
as_dirname=dirname
else
as_dirname=false
fi
echo as_dirname:$as_dirname

1
tests/100-dirname-autoconf.stdout
View File

@ -1 +0,0 @@
as_dirname:dirname

2
tests/100-dirname-root.sh
View File

@ -1,2 +0,0 @@
\dirname /root
\dirname /

2
tests/100-dirname-root.stdout
View File

@ -1,2 +0,0 @@
/
/

1
tests/100-sed-autoconf-basename.sh
View File

@ -1 +0,0 @@
echo 'X/foo/bar' | \sed -f tests/data/basename.sed

1
tests/100-sed-autoconf-basename.stdout
View File

@ -1 +0,0 @@
bar

1
tests/100-sed-case.sh
View File

@ -1 +0,0 @@
echo ooO | \sed s,o,O,i

1
tests/100-sed-case.stdout
View File

@ -1 +0,0 @@
OoO

4
tests/100-sed-command-list.sh
View File

@ -1,4 +0,0 @@
input='foo
bar'
echo "$input" | \sed '/foo/ { s/foo/baz/ s/baz/bar/ } s/bar/baz/'

2
tests/100-sed-command-list.stdout
View File

@ -1,2 +0,0 @@
baz
baz

1
tests/100-sed-file.sh
View File

@ -1 +0,0 @@
\sed s,foo,bar, tests/data/foo

3
tests/100-sed-file.stdout
View File

@ -1,3 +0,0 @@
bar
bar
baz

1
tests/100-sed-fooRbar.sh
View File

@ -1 +0,0 @@
\sed s",\r,\n," < tests/data/fooRbar

3
tests/100-sed-fooRbar.stdout
View File

@ -1,3 +0,0 @@
foo\rbar
foo
bar

1
tests/100-sed-global.sh
View File

@ -1 +0,0 @@
echo 001 | \sed s,0,1,g

1
tests/100-sed-global.stdout
View File

@ -1 +0,0 @@
111

1
tests/100-sed-group-extended.sh
View File

@ -1 +0,0 @@
echo 012 | \sed -r 's,(0)1(2),\21\1,'

1
tests/100-sed-group-extended.stdout
View File

@ -1 +0,0 @@
210

1
tests/100-sed-group.sh
View File

@ -1 +0,0 @@
echo 012 | \sed 's,\(0\)1\(2\),\21\1,'

1
tests/100-sed-group.stdout
View File

@ -1 +0,0 @@
210

1
tests/100-sed-once.sh
View File

@ -1 +0,0 @@
echo 001 | \sed s,0,1,

1
tests/100-sed-once.stdout
View File

@ -1 +0,0 @@
101

5
tests/100-sed-pattern-address.sh
View File

@ -1,5 +0,0 @@
input='bar
baz
bam'
echo "$input" | \sed '/baz/ s/a/i/'

3
tests/100-sed-pattern-address.stdout
View File

@ -1,3 +0,0 @@
bar
biz
bam

4
tests/100-sed-quit.sh
View File

@ -1,4 +0,0 @@
input='foo
bar'
echo "$input" | \sed 's/foo/baz/ ; q ; s/baz/foo/'

1
tests/100-sed-quit.stdout
View File

@ -1 +0,0 @@
baz

1
tests/100-sed-twice.sh
View File

@ -1 +0,0 @@
echo 0001 | \sed -e s,0,1, -e s,0,1,

1
tests/100-sed-twice.stdout
View File

@ -1 +0,0 @@
1101

1
tests/100-sed-undo.sh
View File

@ -1 +0,0 @@
echo 001 | \sed -e s,0,1, -e s,1,0,

1
tests/100-sed-undo.stdout
View File

@ -1 +0,0 @@
001

1
tests/100-sed.sh
View File

@ -1 +0,0 @@
\sed --help

7
tests/100-sed.stdout
View File

@ -1,7 +0,0 @@
Usage: sed [OPTION]... [SCRIPT] [FILE]...
-e, --expression=SCRIPT add SCRIPT to the commands to be executed
-E, -r, --regexp-extended use extended regular expressions in the script
-f, --file=SCRIPT add contents of SCRIPT to the commands to be executed
-h, --help display this help
-i, --in-place edit files in place
-V, --version display version

2
tests/100-tar-Z-old.sh
View File

@ -1,2 +0,0 @@
\tar cZf tmp.tar --sort=name tests/data/star
\tar tZf tmp.tar

5
tests/100-tar-Z-old.stdout
View File

@ -1,5 +0,0 @@
tests/data/star/
tests/data/star/0
tests/data/star/1
tests/data/star/2
tests/data/star/3

1
tests/100-tar-Z-pipe.sh
View File

@ -1 +0,0 @@
\tar -cZf- --sort=name tests/data/star | \tar -tZf-

5
tests/100-tar-Z-pipe.stdout
View File

@ -1,5 +0,0 @@
tests/data/star/
tests/data/star/0
tests/data/star/1
tests/data/star/2
tests/data/star/3

3
tests/100-tar-Z.sh
View File

@ -1,3 +0,0 @@
\tar -cZf tmp.tar --sort=name tests/data/star
\tar -tZf tmp.tar

5
tests/100-tar-Z.stdout
View File

@ -1,5 +0,0 @@
tests/data/star/
tests/data/star/0
tests/data/star/1
tests/data/star/2
tests/data/star/3

3
tests/100-tar-ro.sh
View File

@ -1,3 +0,0 @@
\tar -xvf tests/data/ro.tar
\chmod -R +w foo
\rm -r foo

3
tests/100-tar-ro.stdout
View File

@ -1,3 +0,0 @@
foo/
foo/bar/
foo/bar/baz

1
tests/100-tar.sh
View File

@ -1 +0,0 @@
\tar -cf- --sort=name tests/data/star | \tar -tf-

5
tests/100-tar.stdout
View File

@ -1,5 +0,0 @@
tests/data/star/
tests/data/star/0
tests/data/star/1
tests/data/star/2
tests/data/star/3

1
tests/100-tr.sh
View File

@ -1 +0,0 @@
\tr -d o < tests/data/foo

3
tests/100-tr.stdout
View File

@ -1,3 +0,0 @@
f
bar
baz