diff --git a/.dir-locals.el b/.dir-locals.el index 2aa4e8f..3e18df0 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -1,6 +1,17 @@ -((scheme-mode +((nil . - ((eval . (put ' 'scheme-indent-function 1)) + ((indent-tabs-mode . nil))) + (makefile-mode + (indent-tabs-mode . t)) + (scheme-mode + . + ((geiser-active-implementations . (guile)) + (eval + . + (progn + (let ((top (locate-dominating-file default-directory ".dir-locals.el"))) + (add-to-list 'geiser-guile-load-path top)))) + (eval . (put ' 'scheme-indent-function 1)) (eval . (put ' 'scheme-indent-function 1)) (eval . (put ' 'scheme-indent-function 1)) (eval . (put ' 'scheme-indent-function 1)) diff --git a/.gitignore b/.gitignore index 0af1084..bc4650a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,21 +1,58 @@ *.go *.log +*~ +/.config.make +/bin/basename +/bin/bash +/bin/cat +/bin/chmod +/bin/compress +/bin/cp +/bin/dirname +/bin/find +/bin/gash +/bin/grep +/bin/ls +/bin/mkdir +/bin/mv +/bin/reboot +/bin/rm +/bin/rmdir +/bin/sed +/bin/sh +/bin/tar +/bin/touch +/bin/tr +/bin/wc +/bin/which +/doc/version.texi +/gash/config.scm +/pre-inst-env +/test/*.1 +/test/*.2 +/test/*.log Makefile Makefile.in aclocal.m4 autom4te.cache/* build-aux/* +!build-aux/build-guile.sh !build-aux/git-version-gen !build-aux/gitlab-ci.yml +!build-aux/pre-inst-env.in +!build-aux/trace.sh config.log config.status -configure + +# Preserve this Gash file for now. +# configure + coverage/* lcov.info pre-inst-env scripts/geesh -tests/unit/*.trs -tests/unit/config.scm tests/spec/oil tests/spec/oil-link +tests/unit/*.trs +tests/unit/config.scm tools/coverage diff --git a/07-variable-or-slash.stdout b/07-variable-or-slash.stdout new file mode 100644 index 0000000..9787757 --- /dev/null +++ b/07-variable-or-slash.stdout @@ -0,0 +1 @@ +bar/ diff --git a/70-slash-string-slash.stdout b/70-slash-string-slash.stdout new file mode 100644 index 0000000..b5396b5 --- /dev/null +++ b/70-slash-string-slash.stdout @@ -0,0 +1 @@ +xxbar/xx diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..bcce19a --- /dev/null +++ b/AUTHORS @@ -0,0 +1,15 @@ +Rutger EW van Beusekom +Main author +All files except the imported files listed below + +Adapted from GNU Guix +gash/commands/*.scm +gash/shell-utils.scm +gash/guix-utils.scm + +Adapted from Mes +build-aux/build-guile.sh + +Adapted from Guile100 Challenge +gash/compress.scm +gash/ustar.scm diff --git a/HACKING b/HACKING new file mode 100644 index 0000000..abed6a0 --- /dev/null +++ b/HACKING @@ -0,0 +1,23 @@ +Working up to a 0.1 release. + +TODO: + * Fix word/delim/substitute + * Implement export + * Pass all tests + * Add missing tests, repeat :-) + +Try + + make check-bash + make check-gash + +or + + bash -e test/42-sh-export.sh + ./pre-inst-env gash -e test/42-sh-export.sh + +To use Geesh, assuming you have built it in ../geesh, do something like + + GUILE_LOAD_PATH=../geesh:$GUILE_LOAD_PATH + GUILE_LOAD_COMPILED_PATH=../geesh:$GUILE_LOAD_COMPILED_PATH + ./pre-inst-env gash --geesh -dd -p -c 'cat < README > bla' diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..caa5bac --- /dev/null +++ b/INSTALL @@ -0,0 +1,29 @@ + -*- org -*- +Building and Installing Gash + +* Get it + git clone https://gitlab.com/rutger.van.beusekom/gash + +* Regular build +** Prerequisites +*** Guix + guix environment -l guix.scm + +*** Other GNU/Linux + - [[https://gitlab.com/samplet/geesh][geesh]], 0.1-rc is known to work. + - GNU Guile, version 2.2.3 or is known to work. + - GNU make, version 4.2 known to work. + - SH, /bin/sh, GNU Bash 4.3 is known to work. + - git, 2.10 is known to work. + +** Build it + ./configure + make + +** Check it + make check +** Install it + make install + +* Guix it + guix package -f guix.scm diff --git a/README b/README index 01216a7..f2ce0f1 100644 --- a/README +++ b/README @@ -1 +1,20 @@ -Geesh is a shell interpreter written in Guile Scheme. +This project aims to produce at least a POSIX compliant sh replacement +or even implement GNU bash. On top of that it also intends to make +scheme available for interactive and scripting application. The +approach also intends to allow capturing the intermediate scheme +representation of the "original" shell script to offer a migration +path away from [ba]sh. On top of this GNU make could similarly be +replaced, as make turns out to be fraught with limitations and +complexities. One of the features I personally desire is not be +forced to keep doing what was done in the past, i.e. once an object +file is produced, it does not have to be produced again as long as the +original is kept around. The orignal must be replaced when any of its +dependencies change (source, compiler options, linker, etc.) + +I feel that the shell has been instrumental on my path to embracing +functional programming, however now I mostly experience that the +language itselfs folds on functional expression, pun intended. + + +* history flattened vs full, i.e. navigate interactively without + redundancy vs export as script diff --git a/TODO b/TODO new file mode 100644 index 0000000..9211b2f --- /dev/null +++ b/TODO @@ -0,0 +1,14 @@ +* setup test driven development: done +* execute tests using gash: done +* parsing posix shell: nested "'""'": done +* globbing: done +* job control: done +* substitution: done +* readline: prompt2: in progress +* pipe: in progress: mix built-in with process +* compound: case, while, until +* expansion: done +* alias: +* iohere: +* redirection: +* posix compliance: diff --git a/bin/builtin.in b/bin/builtin.in new file mode 100644 index 0000000..d0eff5f --- /dev/null +++ b/bin/builtin.in @@ -0,0 +1,24 @@ +#! @GUILE@ \ +--no-auto-compile -e main -L @guile_site_dir@ -C @guile_site_ccache_dir@ -L . -C . -s +!# +;;; Gash --- Guile As SHell +;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define (main args) + (apply (@@ (gash commands @builtin@) main) args)) diff --git a/bin/gash.in b/bin/gash.in new file mode 100644 index 0000000..c7587d1 --- /dev/null +++ b/bin/gash.in @@ -0,0 +1,25 @@ +#! @GUILE@ \ +--no-auto-compile -e main -L @guile_site_dir@ -C @guile_site_ccache_dir@ -L . -C . -s +!# +;;; Gash --- Guile As SHell +;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define (main args) + (setenv "SHELL" ((compose canonicalize-path car command-line))) + ((@ (gash gash) main) (command-line))) diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh new file mode 100755 index 0000000..6817a3c --- /dev/null +++ b/build-aux/build-guile.sh @@ -0,0 +1,134 @@ +#! /bin/sh + +# Gash --- Guile As SHell +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# This file is part of Gash. +# +# Gash is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or (at +# your option) any later version. +# +# Gash is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License +# along with Gash. If not, see . + +srcdir=${srcdir-.} +. ${srcdest}build-aux/trace.sh + +export GUILE +export GUILE_AUTO_COMPILE +GUILE=${GUILE-$(command -v guile)} +GUILD=${GUILD-$(command -v guild || command -v guile-tools)} +GUILE_AUTO_COMPILE=0 + +set -e + +SCM_FILES=" +${srcdest}gash/bournish-commands.scm +${srcdest}gash/guix-utils.scm +${srcdest}gash/builtins.scm +${srcdest}gash/compress.scm +${srcdest}gash/config.scm +${srcdest}gash/environment.scm +${srcdest}gash/gash.scm +${srcdest}gash/geesh.scm +${srcdest}gash/grammar.scm +${srcdest}gash/io.scm +${srcdest}gash/job.scm +${srcdest}gash/lzw.scm +${srcdest}gash/pipe.scm +${srcdest}gash/readline.scm +${srcdest}gash/script.scm +${srcdest}gash/shell-utils.scm +${srcdest}gash/ustar.scm +${srcdest}gash/util.scm + +${srcdest}gash/peg.scm +${srcdest}gash/peg/cache.scm +${srcdest}gash/peg/codegen.scm +${srcdest}gash/peg/simplify-tree.scm +${srcdest}gash/peg/string-peg.scm +${srcdest}gash/peg/using-parsers.scm + +${srcdest}gash/commands/basename.scm +${srcdest}gash/commands/cat.scm +${srcdest}gash/commands/chmod.scm +${srcdest}gash/commands/compress.scm +${srcdest}gash/commands/cp.scm +${srcdest}gash/commands/dirname.scm +${srcdest}gash/commands/find.scm +${srcdest}gash/commands/grep.scm +${srcdest}gash/commands/ls.scm +${srcdest}gash/commands/mkdir.scm +${srcdest}gash/commands/mv.scm +${srcdest}gash/commands/reboot.scm +${srcdest}gash/commands/rm.scm +${srcdest}gash/commands/rmdir.scm +${srcdest}gash/commands/sed.scm +${srcdest}gash/commands/tar.scm +${srcdest}gash/commands/touch.scm +${srcdest}gash/commands/tr.scm +${srcdest}gash/commands/wc.scm +${srcdest}gash/commands/which.scm + +${srcdest}gash/commands/sed/reader.scm + +" + +SCRIPTS=" +${srcdest}bin/basename +${srcdest}bin/cat +${srcdest}bin/chmod +${srcdest}bin/compress +${srcdest}bin/cp +${srcdest}bin/dirname +${srcdest}bin/find +${srcdest}bin/gash +${srcdest}bin/grep +${srcdest}bin/ls +${srcdest}bin/mkdir +${srcdest}bin/mv +${srcdest}bin/reboot +${srcdest}bin/rm +${srcdest}bin/rmdir +${srcdest}bin/sed +${srcdest}bin/tar +${srcdest}bin/touch +${srcdest}bin/tr +${srcdest}bin/wc +${srcdest}bin/which +" + +export host=$($GUILE -c "(display %host-type)") + +abs=$srcdest +if [ "$GUILE_EFFECTIVE_VERSION" = "2.0" ]; then + srcdest=$abs_top_srcdir/ +fi + +GUILE_AUTO_COMPILE=0 +WARNINGS=" +--warn=unsupported-warning +--warn=unused-variable +--warn=unused-toplevel +--warn=unbound-variable +--warn=macro-use-before-definition +--warn=arity-mismatch +--warn=duplicate-case-datum +--warn=bad-case-datum +--warn=format +" + +for i in $SCM_FILES $SCRIPTS; do + b=$(basename $i) + go=${i%%.scm}.go + if [ $i -nt $go ]; then + trace "GUILEC $b" $GUILD compile -L ${srcdir} $WARNINGS -o $go $i + fi +done diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in new file mode 100644 index 0000000..2e47e54 --- /dev/null +++ b/build-aux/pre-inst-env.in @@ -0,0 +1,45 @@ +#! @BASH@ + +# Gash --- Guile As SHell +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# This file is part of Gash. +# +# Gash is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or (at +# your option) any later version. +# +# Gash is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License +# along with Gash. If not, see . + +srcdir="@srcdir@" +abs_top_srcdir="@abs_top_srcdir@" +abs_top_builddir="@abs_top_builddir@" +prefix=${prefix-@prefix@} + +MES_PREFIX=${MES_PREFIX-${srcdest}mes} +export MES_PREFIX + +GUILE_LOAD_COMPILED_PATH="$abs_top_builddir/bin:$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" +GUILE_LOAD_PATH="$abs_top_srcdir${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH" +if [ -n "$srcdest" ]; then + GUILE_LOAD_PATH="${srcdest}module:${srcdest}mes:$GUILE_LOAD_PATH" +fi +export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH + +PATH="$abs_top_builddir/bin:$PATH" +export PATH + +COMMANDS="$abs_top_builddir/gash/commands" +export COMMANDS + +LANG= +LC_ALL= + +exec "$@" diff --git a/build-aux/trace.sh b/build-aux/trace.sh new file mode 100644 index 0000000..6f5d0ef --- /dev/null +++ b/build-aux/trace.sh @@ -0,0 +1,41 @@ +# Gash --- Guile As SHell +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# This file is part of Gash. +# +# Gash is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or (at +# your option) any later version. +# +# Gash is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License +# along with Gash. If not, see . + +if [ -z "$V" -o "$V0" = 0 ]; then + trace () { + echo " $1" + shift + eval "$@" $LOG + } + LOG=" >>build.log 2>&1" +fi +if [ "$V" = 1 ]; then + trace () { + shift + echo "$@" + eval "$@ $LOG" + } + LOG=" >>build.log 2>&1" +fi +if [ "$V" = 2 ]; then + set -x + trace () { + shift + eval "$@" + } +fi diff --git a/check.sh b/check.sh new file mode 100755 index 0000000..3c64bf8 --- /dev/null +++ b/check.sh @@ -0,0 +1,202 @@ +if [ -n "$V" ]; then + set -x +fi +DIFF=diff +SHELL=${SHELL-bin/gash} + +tests=' +00-exit +00-exit-0 +00-exit-1 +00-exit-2 +00-exit-error +00-exit-var + +01-script-newline +01-script-semi +01-script-backslash +01-script-backslash-space +01-script-backslash-twice +01-script-$0 +01-script-$# +01-script-$@ +01-script-shift + +03-echo +03-echo-doublequotes +03-echo-nesting +03-echo-escaped-doublequotes +03-echo-quoted-doublequotes +03-echo-brace + +04-echo-var +04-echo-equal +04-echo-word-at +04-echo-word-at-word + +05-assignment +05-assignment-echo +05-assignment-empty +05-assignment-singlequote +05-assignment-double-quote +05-assignment-variable-word +05-assignment-word-variable +05-assignment-doublequoted-doublequotes + +06-compound-word +06-command-compound-word + +07-variable-or +07-variable-not-or +07-variable-or-slash +07-variable-or-variable +07-variable-or-doublequote +07-variable-or-empty + +08-variable-and +08-variable-not-and + +10-if +10-if-false +10-if-word-variable +10-if-multiple +10-if-else +10-else-multiple +10-if-elif +10-if-test +10-if-test-false +10-if-bracket +10-if-bracket-false +10-if-redirect + +11-for +11-for-split-sequence +11-for-done-subshell + +20-semi +20-or +20-and +20-pipe-exit-0 +20-pipe-exit-1 +20-pipe-sed +20-exec + +30-substitution +30-substitution-word +30-substitution-backtick +30-substitution-assignment +30-for-substitution +30-substitution-assignment +30-substitution-assignment-at +30-substitution-redirect + +40-eval +40-eval-echo-variable +40-assignment-eval-echo + +41-dot +42-sh +42-sh-export + +50-iohere +50-iohere-builtin +50-redirect +50-redirect-space +50-redirect-in +50-redirect-append +50-redirect-pipe +50-redirect-merge +50-redirect-sed +50-redirect-in-out + +60-function +60-function-at +60-subst + +70-hash +70-hash-hash +70-percent +70-percent-percent +70-percent-space +70-slash +70-slash-string +70-slash-string-slash + +100-cd +100-cd-foo + +100-test +100-test-file +100-bracket-file + +100-basename-root +100-dirname-root +100-basename-autoconf +100-dirname-autoconf + +100-sed +100-sed-once +100-sed-global +100-sed-case +100-sed-group +100-sed-group-extended +100-sed-twice +100-sed-undo +100-sed-file +100-sed-fooRbar +100-sed-pattern-address +100-sed-quit +100-sed-autoconf-basename + +100-tar +100-tar-Z +100-tar-Z-old +100-tar-Z-pipe +100-tar-ro + +100-tr +' + +broken=" +" + +if [ "$(basename $SHELL)" = bash ]; then + broken=" +00-sed +" +fi + +expect=$(echo $broken | wc -w) +pass=0 +fail=0 +total=0 +for t in $tests; do + if [ "$PARSE" ]; then + bin/gash -p "test/$t.sh" + else + sh test.sh "test/$t" &> test/"$t".log + fi + r=$? + total=$((total+1)) + if [ $r = 0 ]; then + echo $t: [OK] + pass=$((pass+1)) + else + echo $t: [FAIL] + fail=$((fail+1)) + fi +done + +[ $expect != 0 ] && echo "expect: $expect" +[ $fail != 0 ] && echo "failed: $fail" +[ $fail -lt $expect ] && echo "solved: $(($expect - $fail))" +echo "passed: $pass" +echo "total: $total" +if [ $fail != 0 -a $fail -gt $expect ]; then + echo FAILED: $fail/$total + exit 1 +elif [ $fail != 0 ]; then + echo PASS: $pass/$total +else + echo PASS: $total +fi diff --git a/configure b/configure new file mode 100755 index 0000000..acc3b2c --- /dev/null +++ b/configure @@ -0,0 +1,129 @@ +#! /bin/sh + +VERSION=0.1 + +# parse --prefix=PREFIX, mainly for GuixSD/Debian +cmdline=$(echo "$@") +PREFIX=${cmdline##*--prefix=} +PREFIX=${PREFIX% *} +PREFIX=${PREFIX% -*} +if [ -z "$PREFIX" ]; then + PREFIX=/usr/local +fi + +BASH=$(command -v bash) +GUILE=${GUILE-$(command -v guile)} +GUILD=${GUILD-$(command -v guild || command -v guile-tools)} +guile_site_dir=$PREFIX/share/guile/site/$guile_effective_version +guile_site_ccache_dir=$PREFIX/lib/guile/$guile_effective_version/site-ccache +guile_effective_version=$(guile -c '(display (effective-version))') +MAKEINFO=$(command -v makeinfo) +GEESH_PREFIX=${GEESH_PREFIX-$HOME/src/geesh} +if [ -d $GEESH_PREFIX ]; then + GUILE_LOAD_PATH=$GEESH_PREFIX:$GUILE_LOAD_PATH + GUILE_LOAD_COMPILED_PATH=$GEESH_PREFIX:$GUILE_LOAD_COMPILED_PATH + if ! $GUILE -c '(use-modules (geesh parser)) (exit (defined? '"'"'read-sh-all))'; then + echo "warning: building without Geesh" + fi +fi + +if [ "$srcdir" = . ]; then + top_builddir=. +else + srcdest=${srcdest} + top_builddir=$PWD +fi +abs_top_srcdir=${abs_top_srcdir-$(cd ${srcdir} && pwd)} +abs_top_builddir=$PWD + +cat > .config.make < $2 +} + +SHELLS=" +bash +gash +sh +" + +for shell in $SHELLS; do + subst ${srcdest}bin/gash.in bin/$shell + chmod +x bin/$shell +done + +BUILTINS=" +basename +cat +chmod +compress +cp +dirname +find +grep +ls +mkdir +mv +reboot +rm +rmdir +sed +tar +touch +tr +wc +which +" +for builtin in $BUILTINS; do + subst ${srcdest}bin/builtin.in bin/$builtin + chmod +x bin/$builtin +done + +subst ${srcdest}gash/config.scm.in gash/config.scm +subst ${srcdest}build-aux/pre-inst-env.in pre-inst-env +chmod +x pre-inst-env + +cat < + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + 0. PREAMBLE + + The purpose of this License is to make a manual, textbook, or other + functional and useful document “free” in the sense of freedom: to + assure everyone the effective freedom to copy and redistribute it, + with or without modifying it, either commercially or + noncommercially. Secondarily, this License preserves for the + author and publisher a way to get credit for their work, while not + being considered responsible for modifications made by others. + + This License is a kind of “copyleft”, which means that derivative + works of the document must themselves be free in the same sense. + It complements the GNU General Public License, which is a copyleft + license designed for free software. + + We have designed this License in order to use it for manuals for + free software, because free software needs free documentation: a + free program should come with manuals providing the same freedoms + that the software does. But this License is not limited to + software manuals; it can be used for any textual work, regardless + of subject matter or whether it is published as a printed book. We + recommend this License principally for works whose purpose is + instruction or reference. + + 1. APPLICABILITY AND DEFINITIONS + + This License applies to any manual or other work, in any medium, + that contains a notice placed by the copyright holder saying it can + be distributed under the terms of this License. Such a notice + grants a world-wide, royalty-free license, unlimited in duration, + to use that work under the conditions stated herein. The + “Document”, below, refers to any such manual or work. Any member + of the public is a licensee, and is addressed as “you”. You accept + the license if you copy, modify or distribute the work in a way + requiring permission under copyright law. + + A “Modified Version” of the Document means any work containing the + Document or a portion of it, either copied verbatim, or with + modifications and/or translated into another language. + + A “Secondary Section” is a named appendix or a front-matter section + of the Document that deals exclusively with the relationship of the + publishers or authors of the Document to the Document’s overall + subject (or to related matters) and contains nothing that could + fall directly within that overall subject. (Thus, if the Document + is in part a textbook of mathematics, a Secondary Section may not + explain any mathematics.) The relationship could be a matter of + historical connection with the subject or with related matters, or + of legal, commercial, philosophical, ethical or political position + regarding them. + + The “Invariant Sections” are certain Secondary Sections whose + titles are designated, as being those of Invariant Sections, in the + notice that says that the Document is released under this License. + If a section does not fit the above definition of Secondary then it + is not allowed to be designated as Invariant. The Document may + contain zero Invariant Sections. If the Document does not identify + any Invariant Sections then there are none. + + The “Cover Texts” are certain short passages of text that are + listed, as Front-Cover Texts or Back-Cover Texts, in the notice + that says that the Document is released under this License. A + Front-Cover Text may be at most 5 words, and a Back-Cover Text may + be at most 25 words. + + A “Transparent” copy of the Document means a machine-readable copy, + represented in a format whose specification is available to the + general public, that is suitable for revising the document + straightforwardly with generic text editors or (for images composed + of pixels) generic paint programs or (for drawings) some widely + available drawing editor, and that is suitable for input to text + formatters or for automatic translation to a variety of formats + suitable for input to text formatters. A copy made in an otherwise + Transparent file format whose markup, or absence of markup, has + been arranged to thwart or discourage subsequent modification by + readers is not Transparent. An image format is not Transparent if + used for any substantial amount of text. A copy that is not + “Transparent” is called “Opaque”. + + Examples of suitable formats for Transparent copies include plain + ASCII without markup, Texinfo input format, LaTeX input format, + SGML or XML using a publicly available DTD, and standard-conforming + simple HTML, PostScript or PDF designed for human modification. + Examples of transparent image formats include PNG, XCF and JPG. + Opaque formats include proprietary formats that can be read and + edited only by proprietary word processors, SGML or XML for which + the DTD and/or processing tools are not generally available, and + the machine-generated HTML, PostScript or PDF produced by some word + processors for output purposes only. + + The “Title Page” means, for a printed book, the title page itself, + plus such following pages as are needed to hold, legibly, the + material this License requires to appear in the title page. For + works in formats which do not have any title page as such, “Title + Page” means the text near the most prominent appearance of the + work’s title, preceding the beginning of the body of the text. + + The “publisher” means any person or entity that distributes copies + of the Document to the public. + + A section “Entitled XYZ” means a named subunit of the Document + whose title either is precisely XYZ or contains XYZ in parentheses + following text that translates XYZ in another language. (Here XYZ + stands for a specific section name mentioned below, such as + “Acknowledgements”, “Dedications”, “Endorsements”, or “History”.) + To “Preserve the Title” of such a section when you modify the + Document means that it remains a section “Entitled XYZ” according + to this definition. + + The Document may include Warranty Disclaimers next to the notice + which states that this License applies to the Document. These + Warranty Disclaimers are considered to be included by reference in + this License, but only as regards disclaiming warranties: any other + implication that these Warranty Disclaimers may have is void and + has no effect on the meaning of this License. + + 2. VERBATIM COPYING + + You may copy and distribute the Document in any medium, either + commercially or noncommercially, provided that this License, the + copyright notices, and the license notice saying this License + applies to the Document are reproduced in all copies, and that you + add no other conditions whatsoever to those of this License. You + may not use technical measures to obstruct or control the reading + or further copying of the copies you make or distribute. However, + you may accept compensation in exchange for copies. If you + distribute a large enough number of copies you must also follow the + conditions in section 3. + + You may also lend copies, under the same conditions stated above, + and you may publicly display copies. + + 3. COPYING IN QUANTITY + + If you publish printed copies (or copies in media that commonly + have printed covers) of the Document, numbering more than 100, and + the Document’s license notice requires Cover Texts, you must + enclose the copies in covers that carry, clearly and legibly, all + these Cover Texts: Front-Cover Texts on the front cover, and + Back-Cover Texts on the back cover. Both covers must also clearly + and legibly identify you as the publisher of these copies. The + front cover must present the full title with all words of the title + equally prominent and visible. You may add other material on the + covers in addition. Copying with changes limited to the covers, as + long as they preserve the title of the Document and satisfy these + conditions, can be treated as verbatim copying in other respects. + + If the required texts for either cover are too voluminous to fit + legibly, you should put the first ones listed (as many as fit + reasonably) on the actual cover, and continue the rest onto + adjacent pages. + + If you publish or distribute Opaque copies of the Document + numbering more than 100, you must either include a machine-readable + Transparent copy along with each Opaque copy, or state in or with + each Opaque copy a computer-network location from which the general + network-using public has access to download using public-standard + network protocols a complete Transparent copy of the Document, free + of added material. If you use the latter option, you must take + reasonably prudent steps, when you begin distribution of Opaque + copies in quantity, to ensure that this Transparent copy will + remain thus accessible at the stated location until at least one + year after the last time you distribute an Opaque copy (directly or + through your agents or retailers) of that edition to the public. + + It is requested, but not required, that you contact the authors of + the Document well before redistributing any large number of copies, + to give them a chance to provide you with an updated version of the + Document. + + 4. MODIFICATIONS + + You may copy and distribute a Modified Version of the Document + under the conditions of sections 2 and 3 above, provided that you + release the Modified Version under precisely this License, with the + Modified Version filling the role of the Document, thus licensing + distribution and modification of the Modified Version to whoever + possesses a copy of it. In addition, you must do these things in + the Modified Version: + + A. Use in the Title Page (and on the covers, if any) a title + distinct from that of the Document, and from those of previous + versions (which should, if there were any, be listed in the + History section of the Document). You may use the same title + as a previous version if the original publisher of that + version gives permission. + + B. List on the Title Page, as authors, one or more persons or + entities responsible for authorship of the modifications in + the Modified Version, together with at least five of the + principal authors of the Document (all of its principal + authors, if it has fewer than five), unless they release you + from this requirement. + + C. State on the Title page the name of the publisher of the + Modified Version, as the publisher. + + D. Preserve all the copyright notices of the Document. + + E. Add an appropriate copyright notice for your modifications + adjacent to the other copyright notices. + + F. Include, immediately after the copyright notices, a license + notice giving the public permission to use the Modified + Version under the terms of this License, in the form shown in + the Addendum below. + + G. Preserve in that license notice the full lists of Invariant + Sections and required Cover Texts given in the Document’s + license notice. + + H. Include an unaltered copy of this License. + + I. Preserve the section Entitled “History”, Preserve its Title, + and add to it an item stating at least the title, year, new + authors, and publisher of the Modified Version as given on the + Title Page. If there is no section Entitled “History” in the + Document, create one stating the title, year, authors, and + publisher of the Document as given on its Title Page, then add + an item describing the Modified Version as stated in the + previous sentence. + + J. Preserve the network location, if any, given in the Document + for public access to a Transparent copy of the Document, and + likewise the network locations given in the Document for + previous versions it was based on. These may be placed in the + “History” section. You may omit a network location for a work + that was published at least four years before the Document + itself, or if the original publisher of the version it refers + to gives permission. + + K. For any section Entitled “Acknowledgements” or “Dedications”, + Preserve the Title of the section, and preserve in the section + all the substance and tone of each of the contributor + acknowledgements and/or dedications given therein. + + L. Preserve all the Invariant Sections of the Document, unaltered + in their text and in their titles. Section numbers or the + equivalent are not considered part of the section titles. + + M. Delete any section Entitled “Endorsements”. Such a section + may not be included in the Modified Version. + + N. Do not retitle any existing section to be Entitled + “Endorsements” or to conflict in title with any Invariant + Section. + + O. Preserve any Warranty Disclaimers. + + If the Modified Version includes new front-matter sections or + appendices that qualify as Secondary Sections and contain no + material copied from the Document, you may at your option designate + some or all of these sections as invariant. To do this, add their + titles to the list of Invariant Sections in the Modified Version’s + license notice. These titles must be distinct from any other + section titles. + + You may add a section Entitled “Endorsements”, provided it contains + nothing but endorsements of your Modified Version by various + parties—for example, statements of peer review or that the text has + been approved by an organization as the authoritative definition of + a standard. + + You may add a passage of up to five words as a Front-Cover Text, + and a passage of up to 25 words as a Back-Cover Text, to the end of + the list of Cover Texts in the Modified Version. Only one passage + of Front-Cover Text and one of Back-Cover Text may be added by (or + through arrangements made by) any one entity. If the Document + already includes a cover text for the same cover, previously added + by you or by arrangement made by the same entity you are acting on + behalf of, you may not add another; but you may replace the old + one, on explicit permission from the previous publisher that added + the old one. + + The author(s) and publisher(s) of the Document do not by this + License give permission to use their names for publicity for or to + assert or imply endorsement of any Modified Version. + + 5. COMBINING DOCUMENTS + + You may combine the Document with other documents released under + this License, under the terms defined in section 4 above for + modified versions, provided that you include in the combination all + of the Invariant Sections of all of the original documents, + unmodified, and list them all as Invariant Sections of your + combined work in its license notice, and that you preserve all + their Warranty Disclaimers. + + The combined work need only contain one copy of this License, and + multiple identical Invariant Sections may be replaced with a single + copy. If there are multiple Invariant Sections with the same name + but different contents, make the title of each such section unique + by adding at the end of it, in parentheses, the name of the + original author or publisher of that section if known, or else a + unique number. Make the same adjustment to the section titles in + the list of Invariant Sections in the license notice of the + combined work. + + In the combination, you must combine any sections Entitled + “History” in the various original documents, forming one section + Entitled “History”; likewise combine any sections Entitled + “Acknowledgements”, and any sections Entitled “Dedications”. You + must delete all sections Entitled “Endorsements.” + + 6. COLLECTIONS OF DOCUMENTS + + You may make a collection consisting of the Document and other + documents released under this License, and replace the individual + copies of this License in the various documents with a single copy + that is included in the collection, provided that you follow the + rules of this License for verbatim copying of each of the documents + in all other respects. + + You may extract a single document from such a collection, and + distribute it individually under this License, provided you insert + a copy of this License into the extracted document, and follow this + License in all other respects regarding verbatim copying of that + document. + + 7. AGGREGATION WITH INDEPENDENT WORKS + + A compilation of the Document or its derivatives with other + separate and independent documents or works, in or on a volume of a + storage or distribution medium, is called an “aggregate” if the + copyright resulting from the compilation is not used to limit the + legal rights of the compilation’s users beyond what the individual + works permit. When the Document is included in an aggregate, this + License does not apply to the other works in the aggregate which + are not themselves derivative works of the Document. + + If the Cover Text requirement of section 3 is applicable to these + copies of the Document, then if the Document is less than one half + of the entire aggregate, the Document’s Cover Texts may be placed + on covers that bracket the Document within the aggregate, or the + electronic equivalent of covers if the Document is in electronic + form. Otherwise they must appear on printed covers that bracket + the whole aggregate. + + 8. TRANSLATION + + Translation is considered a kind of modification, so you may + distribute translations of the Document under the terms of section + 4. Replacing Invariant Sections with translations requires special + permission from their copyright holders, but you may include + translations of some or all Invariant Sections in addition to the + original versions of these Invariant Sections. You may include a + translation of this License, and all the license notices in the + Document, and any Warranty Disclaimers, provided that you also + include the original English version of this License and the + original versions of those notices and disclaimers. In case of a + disagreement between the translation and the original version of + this License or a notice or disclaimer, the original version will + prevail. + + If a section in the Document is Entitled “Acknowledgements”, + “Dedications”, or “History”, the requirement (section 4) to + Preserve its Title (section 1) will typically require changing the + actual title. + + 9. TERMINATION + + You may not copy, modify, sublicense, or distribute the Document + except as expressly provided under this License. Any attempt + otherwise to copy, modify, sublicense, or distribute it is void, + and will automatically terminate your rights under this License. + + However, if you cease all violation of this License, then your + license from a particular copyright holder is reinstated (a) + provisionally, unless and until the copyright holder explicitly and + finally terminates your license, and (b) permanently, if the + copyright holder fails to notify you of the violation by some + reasonable means prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is + reinstated permanently if the copyright holder notifies you of the + violation by some reasonable means, this is the first time you have + received notice of violation of this License (for any work) from + that copyright holder, and you cure the violation prior to 30 days + after your receipt of the notice. + + Termination of your rights under this section does not terminate + the licenses of parties who have received copies or rights from you + under this License. If your rights have been terminated and not + permanently reinstated, receipt of a copy of some or all of the + same material does not give you any rights to use it. + + 10. FUTURE REVISIONS OF THIS LICENSE + + The Free Software Foundation may publish new, revised versions of + the GNU Free Documentation License from time to time. Such new + versions will be similar in spirit to the present version, but may + differ in detail to address new problems or concerns. See + . + + Each version of the License is given a distinguishing version + number. If the Document specifies that a particular numbered + version of this License “or any later version” applies to it, you + have the option of following the terms and conditions either of + that specified version or of any later version that has been + published (not as a draft) by the Free Software Foundation. If the + Document does not specify a version number of this License, you may + choose any version ever published (not as a draft) by the Free + Software Foundation. If the Document specifies that a proxy can + decide which future versions of this License can be used, that + proxy’s public statement of acceptance of a version permanently + authorizes you to choose that version for the Document. + + 11. RELICENSING + + “Massive Multiauthor Collaboration Site” (or “MMC Site”) means any + World Wide Web server that publishes copyrightable works and also + provides prominent facilities for anybody to edit those works. A + public wiki that anybody can edit is an example of such a server. + A “Massive Multiauthor Collaboration” (or “MMC”) contained in the + site means any set of copyrightable works thus published on the MMC + site. + + “CC-BY-SA” means the Creative Commons Attribution-Share Alike 3.0 + license published by Creative Commons Corporation, a not-for-profit + corporation with a principal place of business in San Francisco, + California, as well as future copyleft versions of that license + published by that same organization. + + “Incorporate” means to publish or republish a Document, in whole or + in part, as part of another Document. + + An MMC is “eligible for relicensing” if it is licensed under this + License, and if all works that were first published under this + License somewhere other than this MMC, and subsequently + incorporated in whole or in part into the MMC, (1) had no cover + texts or invariant sections, and (2) were thus incorporated prior + to November 1, 2008. + + The operator of an MMC Site may republish an MMC contained in the + site under CC-BY-SA on the same site at any time before August 1, + 2009, provided the MMC is eligible for relicensing. + +ADDENDUM: How to use this License for your documents +==================================================== + +To use this License in a document you have written, include a copy of +the License in the document and put the following copyright and license +notices just after the title page: + + Copyright (C) YEAR YOUR NAME. + Permission is granted to copy, distribute and/or modify this document + under the terms of the GNU Free Documentation License, Version 1.3 + or any later version published by the Free Software Foundation; + with no Invariant Sections, no Front-Cover Texts, and no Back-Cover + Texts. A copy of the license is included in the section entitled ``GNU + Free Documentation License''. + + If you have Invariant Sections, Front-Cover Texts and Back-Cover +Texts, replace the “with...Texts.” line with this: + + with the Invariant Sections being LIST THEIR TITLES, with + the Front-Cover Texts being LIST, and with the Back-Cover Texts + being LIST. + + If you have Invariant Sections without Cover Texts, or some other +combination of the three, merge those two alternatives to suit the +situation. + + If your document contains nontrivial examples of program code, we +recommend releasing these examples in parallel under your choice of free +software license, such as the GNU General Public License, to permit +their use in free software. + + +File: gash.info, Node: Concept Index, Next: Programming Index, Prev: GNU Free Documentation License, Up: Top + +Concept Index +************* + +[index] +* Menu: + +* license, GNU Free Documentation License: GNU Free Documentation License. + (line 6) +* repl: Invoking Gash. (line 6) + + +File: gash.info, Node: Programming Index, Prev: Concept Index, Up: Top + +Programming Index +***************** + + + +Tag Table: +Node: Top668 +Node: Introduction1144 +Node: Invoking Gash1304 +Node: GNU Free Documentation License1765 +Node: Concept Index27121 +Node: Programming Index27509 + +End Tag Table + + +Local Variables: +coding: utf-8 +End: diff --git a/doc/gash.texi b/doc/gash.texi new file mode 100644 index 0000000..8b21b22 --- /dev/null +++ b/doc/gash.texi @@ -0,0 +1,122 @@ +\input texinfo +@c -*- mode: texinfo; -*- + +@c %**start of header +@setfilename gash.info +@documentencoding UTF-8 +@settitle Gash Reference Manual +@c %**end of header + +@include version.texi + +@copying +Copyright @copyright{} 2018 Rutger EW van Beusekom@* +Copyright @copyright{} 2018 Jan (janneke) Nieuwenhuizen@* + +Permission is granted to copy, distribute and/or modify this document +under the terms of the GNU Free Documentation License, Version 1.3 or +any later version published by the Free Software Foundation; with no +Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A +copy of the license is included in the section entitled ``GNU Free +Documentation License''. +@end copying + +@dircategory Basics +@direntry +* Gash: (gash). Guile As SHell. +* gash: (gash)Invoking gash. Running Gash, a minimalist Bash lookalike. +@end direntry + +@titlepage +@title Gash Reference Manual +@subtitle A POSIX-compliant sh replacement in Guile Scheme. +@author The Gash developers + +@page +@vskip 0pt plus 1filll +Edition @value{EDITION} @* +@value{UPDATED} @* + +@insertcopying +@end titlepage + +@contents + +@c ********************************************************************* +@node Top +@top Gash + +This document describes Gash version @value{VERSION}, a +POSIX-compliant sh replacement in Guile Scheme. + +@menu +* Introduction:: What is Gash about? +* GNU Free Documentation License:: The license of this manual. +* Concept Index:: Concepts. +* Programming Index:: Data types, functions, and variables. + +@detailmenu + --- The Detailed Node Listing --- + +Introduction + +* Invoking Gash:: + +@end detailmenu +@end menu + +@c ********************************************************************* +@node Introduction +@chapter Introduction + +@menu +* Invoking Gash:: +@end menu + +@node Invoking Gash +@section Invoking Gash + +@cindex repl +The @command{gash} command is the sh interpreter. + +@example +gash @var{option}@dots{} @file{FILE} +@end example + +The @var{option}s can be among the following: + +@table @code + +@item -c @var{string} +By default, Gash will read a file named on the command line as a script. + +@item -h@r{, }--help +Display help on invoking Gash, and then exit. + +@item -v@r{, }--version +Display the current version of Gash, and then exit. + +@end table + +@c ********************************************************************* +@node GNU Free Documentation License +@appendix GNU Free Documentation License +@cindex license, GNU Free Documentation License +@include fdl-1.3.texi + +@c ********************************************************************* +@node Concept Index +@unnumbered Concept Index +@printindex cp + +@node Programming Index +@unnumbered Programming Index +@syncodeindex tp fn +@syncodeindex vr fn +@printindex fn + +@bye + +@c Local Variables: +@c ispell-local-dictionary: "american"; +@c End: diff --git a/gash.guix.scm b/gash.guix.scm new file mode 100644 index 0000000..1701913 --- /dev/null +++ b/gash.guix.scm @@ -0,0 +1,195 @@ +;;; guix.scm -- Guix package definition + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen + +;;; Also borrowing code from: +;;; guile-sdl2 --- FFI bindings for SDL2 +;;; Copyright © 2015 David Thompson + +;;; +;;; guix.scm: This file is part of Mes. +;;; +;;; Mes 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. +;;; +;;; Mes 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 Mes. If not, see . + +;;; Commentary: +;; +;; GNU Guix development package. To build and install, run: +;; +;; guix package -f guix.scm +;; +;; To build it, but not install it, run: +;; +;; guix build -f guix.scm +;; +;; To use as the basis for a development environment, run: +;; +;; guix environment -l guix.scm +;; +;;; Code: + +(use-modules (srfi srfi-1) + (srfi srfi-26) + (ice-9 match) + (ice-9 popen) + (ice-9 rdelim) + (gnu packages) + (gnu packages base) + (gnu packages bash) + (gnu packages guile) + (gnu packages mes) + (gnu packages package-management) + (gnu packages texinfo) + ((guix build utils) #:select (with-directory-excursion)) + (guix build-system gnu) + (guix build-system guile) + (guix gexp) + (guix download) + (guix git-download) + ((guix licenses) #:prefix license:) + (guix packages)) + +(define %source-dir (getcwd)) + +(define git-file? + (let* ((pipe (with-directory-excursion %source-dir + (open-pipe* OPEN_READ "git" "ls-files"))) + (files (let loop ((lines '())) + (match (read-line pipe) + ((? eof-object?) + (reverse lines)) + (line + (loop (cons line lines)))))) + (status (close-pipe pipe))) + (lambda (file stat) + (match (stat:type stat) + ('directory #t) + ((or 'regular 'symlink) + (any (cut string-suffix? <> file) files)) + (_ #f))))) + +(define-public guile-gash + (let ((version "0.1") + (commit "5b7f85aa3d15523edd05a07ed2b16b6f69690d53") + (revision "0") + (builtins '( + "basename" + "cat" + "chmod" + "compress" + "cp" + "dirname" + "find" + "grep" + "ls" + "mkdir" + "mv" + "reboot" + "rm" + "rmdir" + "sed" + "tar" + "touch" + "tr" + "wc" + "which" + )) + (shells '("bash" "gash" "sh"))) + (package + (name "guile-gash") + (version (string-append version "-" revision "." (string-take commit 7))) + (source (origin + (method url-fetch) + (uri (string-append "https://gitlab.com/janneke/gash" + "/-/archive/" commit + "/gash-" commit ".tar.gz")) + (sha256 + (base32 + "05nq0knklgk2iczsqmnhnh1365iv6gs3cxam38qf7dmdlglbf0sa")))) + (build-system guile-build-system) + (arguments + `(#:phases + (modify-phases %standard-phases + (add-after 'unpack 'remove-geesh + (lambda _ + (delete-file "guix.scm") ; should not and cannot be compiled + (delete-file "gash/geesh.scm") ; no Geesh yet + #t)) + (add-after 'unpack 'configure + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (guile (assoc-ref inputs "guile")) + (bin/guile (string-append guile "/bin/guile")) + (effective (target-guile-effective-version)) + (guile-site-dir + (string-append out "/share/guile/site/" effective)) + (guile-site-ccache-dir + (string-append out + "/lib/guile/" effective "/site-ccache"))) + (define (make-script source name) + (let ((script (string-append "bin/" name))) + (copy-file source script) + (substitute* script + (("@GUILE@") bin/guile) + (("@guile_site_dir@") guile-site-dir) + (("@guile_site_ccache_dir@") guile-site-ccache-dir) + (("@builtin@") name)) + (chmod script #o755))) + (copy-file "gash/config.scm.in" "gash/config.scm") + (substitute* "gash/config.scm" + (("@guile_site_ccache_dir@") guile-site-ccache-dir) + (("@VERSION@") ,version) + (("@COMPRESS@") (string-append out "/bin/compress")) + (("@BZIP2@") (which "bzip2")) + (("@GZIP@") (which "gzip")) + (("@XZ@") (which "xz"))) + (for-each + (lambda (s) (make-script "bin/gash.in" s)) ',shells) + (for-each + (lambda (s) (make-script "bin/builtin.in" s)) ',builtins)) + #t)) + (add-after 'install 'install-scripts + (lambda* (#:key inputs outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (bin (string-append out "/bin")) + (libexec/gash (string-append out "/libexec/gash"))) + (install-file "bin/gash" bin) + (for-each + (lambda (name) + (install-file (string-append "bin/" name) libexec/gash)) + ',(append builtins shells))) + #t))))) + (native-inputs + `(("guile" ,guile-2.2) + ("guile-readline" ,guile-readline))) + (home-page "https://gitlab.com/rutgervanbeusekom/gash") + (synopsis "Guile As SHell") + (description + "Gash--Guile As SHell-- aims to produce at least a POSIX compliant sh +replacement or even implement GNU bash. On top of that it also intends to +make Scheme available for interactive and scripting application.") + (license license:gpl3+)))) + +(define-public gash.git + (let ((version "0.1") + (revision "0") + (commit (read-string (open-pipe "git show HEAD | head -1 | cut -d ' ' -f 2" OPEN_READ)))) + (package + (inherit guile-gash) + (name "gash.git") + (version (string-append version "-" revision "." (string-take commit 7))) + (source (local-file %source-dir #:recursive? #t #:select? git-file?))))) + +;; Return it here so `guix build/environment/package' can consume it directly. +gash.git diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm new file mode 100644 index 0000000..6b448bb --- /dev/null +++ b/gash/bournish-commands.scm @@ -0,0 +1,128 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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) + )) diff --git a/gash/builtins.scm b/gash/builtins.scm new file mode 100644 index 0000000..a5d125c --- /dev/null +++ b/gash/builtins.scm @@ -0,0 +1,396 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash builtins) + #:use-module (ice-9 ftw) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 local-eval) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + + #: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) + #:use-module (gash job) + #:use-module (gash pipe) + #:use-module (gash script) + #:use-module (gash util) + + #:export ( + %builtin-commands + PATH-search-path + trace + + bg-command + cd-command + echo-command + eval-command + exit-command + fg-command + help-command + jobs-command + pwd-command + set-command + shift-command + )) + +(define (PATH-search-path program) + (search-path (string-split (getenv "PATH") #\:) program)) + +(define (cd-command . args) + (match args + (() (cd-command (getenv "HOME"))) + ((dir) + (let ((old (variable "OLDPWD"))) + (assignment "OLDPWD" (getcwd)) + (catch #t + (lambda _ + (if (string=? dir "-") (chdir old) + (chdir dir)) + 0) + (lambda (key command fmt args exit) + (apply format (current-error-port) "cd: ~a: ~a\n" (cons dir args)) + 1)))) + ((args ...) + (format (current-error-port) "cd: too many arguments: ~a\n" (string-join args))))) + +(define (echo-command . args) + (lambda _ + (match args + (() (newline)) + (("-n" args ...) (display (string-join args))) + (_ (display (string-join args)) (newline))))) + +(define (bg-command . args) + (match args + (() (bg 1)) + ((job x ...) (bg (string->number (car job)))))) + +(define (fg-command . args) + (match args + (() (fg 1)) + ((job x ...) (fg (string->number (car job)))))) + +(define (jobs-command) + (format (current-error-port) "jobs: ~s\n" job-table) + (for-each (lambda (job) (display-job job)) (reverse job-table))) + +(define (pwd-command . _) + (lambda _ (stdout (getcwd)))) + +(define (set-command . args) ;; TODO export; env vs set + (define (display-var o) + (format #t "~a=~a\n" (car o) (cdr o))) + (match args + (() (lambda _ (for-each display-var %global-variables))) + (("-e") (set-shell-opt! "errexit" #t)) + (("+e") (set-shell-opt! "errexit" #f)) + (("-u") (set-shell-opt! "nounset" #t)) + (("+u") (set-shell-opt! "nounset" #f)) + (("-x") (set-shell-opt! "xtrace" #t)) + (("+x") (set-shell-opt! "xtrace" #f)) + (("-o" option) (format (current-error-port) "warning: set: not supported: ~a\n" args)) + (("+o" option) (format (current-error-port) "warning: set: not supported: ~a\n" args)) + (((and (? string?) arg)) (let* ((lst (string->string-list arg)) + (set (car lst))) + (when (not (member set '("-" "+"))) + (error (format #f "set: no such option:~s\n" args))) + (apply set-command (map (cut string-append set <>) (cdr lst))))) + ((h ...) (last (map set-command args))))) + +(define (shift-command . args) + (lambda _ + (match args + (() (when (pair? (cdr (%command-line))) + (%command-line (cons (car (%command-line)) (cddr (%command-line))))))))) + +(define (eval-command . args) + (lambda _ + (match args + (() #t) + ((args ...) + (let ((ast (parse-string (string-join args)))) + ;;(ignore-error (run ast)) + (run ast) + (assignment "?" "0") + #t))))) + +(define (exit-command . args) + (match args + (() (exit 0)) + ((status) + (exit (string->number status))) + ((args ...) + (format (current-error-port) "exit: too many arguments: ~a\n" (string-join args))))) + +(define (help-command . _) + (lambda _ + (display "\ +Hello, this is GASH, Guile As SHell. + +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))))) + +(define command-command + (case-lambda + (() #t) + (args + (lambda _ + (let* ((option-spec + '((describe (single-char #\V)) + (help) + (show (single-char #\v)) + (version))) + (options (getopt-long (cons "command" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (help? (display "Usage: command [OPTION]... [COMMAND [ARG]...] + +Options: + --help display this help and exit + --version display version information and exit + -v display a description of COMMAND similar to the `type' builtin + -V display a more verbose description of COMMAND +")) + (version? (format #t "command (GASH) ~a\n" %version)) + ((null? files) #t) + ((option-ref options 'describe #f) + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (cond (builtin (format #t "~a is a shell builtin\n" command) + 0) + (else (let ((program (PATH-search-path command))) + (if (string? program) (begin (format #t "~a hashed (~a)\n" command program) 0) + 1)))))) + ((option-ref options 'show #f) + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (if builtin (begin (stdout command) 0) + (let ((program (PATH-search-path command))) + (if (string? program) (begin (stdout program) 0) + 1))))) + (else (let* ((command (car files)) + (builtin (builtin command #:prefer-builtin? %prefer-builtins?))) + ;; FIXME: + `(command ,@args))))))))) + +(define type-command + (case-lambda + (() #t) + (args + (lambda _ + (let* ((option-spec + '((help) + (canonical-file-name (single-char #\p)) + (version))) + (options (getopt-long (cons "type" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (help? (display "Usage: type [OPTION]... [COMMAND] + +Options: + --help display this help and exit + -p display canonical file name of COMMAND + --version display version information and exit +")) + (version? (format #t "type (GASH) ~a\n" %version)) + ((null? files) #t) + ((option-ref options 'canonical-file-name #f) + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (if builtin 0 + (let ((program (PATH-search-path command))) + (and (string? program) + (stdout program) + 0))))) + (else + (let* ((command (car files)) + (builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?))) + (cond (builtin (format #t "~a is a shell builtin\n" command) + 0) + (else (let ((program (PATH-search-path command))) + (if (string? program) (begin (format #t "~a hashed (~a)\n" command program) 0) + 1)))))))))))) + +(define test-command + (case-lambda + (() #f) + (args + (lambda _ + (let* ((option-spec + '((is-directory (single-char #\d)) + (exists (single-char #\e)) + (has-size (single-char #\s)) + (help) + (is-directory (single-char #\d)) + (is-file (single-char #\f)) + (is-symbolic-link (single-char #\L)) + (is-symbolic-link (single-char #\h)) + (is-readable (single-char #\r)) + (is-writable (single-char #\w)) + (is-exeutable (single-char #\x)) + (string-not-null (single-char #\n)) + (string-null (single-char #\z)) + (version))) + (options (getopt-long (cons "test" args) option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (file (and (pair? files) (car files))) + (no-options? (and file + (= (length options) 1)))) + (cond (help? (display "Usage: test [EXPRESSION] + +Expression: + + STRING equivalent to -n STRING + + STRING1 = STRING2 + STRING1 == STRING2 + the strings are equal + + STRING1 != STRING2 + the strings are not equal + +Options: + -d FILE FILE exists and is a directory + -e FILE FILE exists + -f FILE FILE exists and is a regular file + -h FILE FILE exists and is a symbolic link (same as -L) + -L FILE FILE exists and is a symbolic link (same as -h) + -n STRING the length of STRING is nonzero + -r FILE FILE exists and read permission is granted + -s FILE FILE exists and has a size greater than zero + -w FILE FILE exists and write permission is granted + -x FILE FILE exists and execute (or search) permission is granted + -z STRING the length of STRING is zero + --help display this help and exit + --version display version information and exit +")) + (version? (format #t "test (GASH) ~a\n" %version)) + ((null? files) #f) + ((or (option-ref options 'string-not-null #f) + (and no-options? + (= (length files) 1))) + (not (string-null? file))) + ((option-ref options 'string-null #f) + (string-null? file)) + ((and (= (length files) 3) + (member (cadr files) '("=" "=="))) + (match files + ((or (left "=" right) + (left "==" right)) + (equal? left right)) + ((left "!=" right) + (not (equal? left right))) + (expression + (pipeline (command expression))))) + ((not (= (length files) 1)) + (format (current-error-port) "test: too many files: ~s\n" files) + (format (current-error-port) "test: command: ~s\n" args) + 1) + ((option-ref options 'is-file #f) + (regular-file? file)) + ((option-ref options 'is-directory #f) + (directory-exists? file)) + ((option-ref options 'exists #f) + (file-exists? file)) + ((option-ref options 'is-symbolic-link #f) + (symbolic-link? file)) + ((option-ref options 'is-readable #f) + (access? file R_OK)) + ((option-ref options 'has-size #f) + (and (file-exists? file) + (not (zero? (stat:size (stat file)))))) + ((option-ref options 'is-writable #f) + (access? file W_OK)) + ((option-ref options 'is-exeutable #f) + (access? file X_OK)) + (else + (error "gash: test: not supported" args)))))))) + +(define bracket-command + (case-lambda + (() #f) + (args + (cond ((and (pair? args) (equal? (car args) "--help")) + (test-command "--help")) + ((and (pair? args) (equal? (car args) "--version")) + (test-command "--version")) + (else + (if (not (equal? (last args) "]")) (begin + (format (current-error-port) "gash: [: missing `]'\n") + #f) + (apply test-command (drop-right args 1)))))))) + +(define (term->string o) + (match o + ((? string?) o) + (('variable name) (variable name)) + (('variable-or name default) (variable-or name default)) + (('variable-and name default) (variable-and name default)) + (_ (format #f "~s" o)))) + +(define (trace commands) + `(xtrace + ,(lambda _ + (when (shell-opt? "xtrace") + (for-each + (lambda (o) + (match o + (('command (and command (or (? string?) ('variable _))) ...) + (format (current-error-port) "+ ~a\n" (string-join (map term->string command)))) + (('command ('assignment name value)) + (format (current-error-port) "+ ~a=~a\n" name (term->string value))) + (_ (format (current-error-port) "+ ~s \n" o)))) + (reverse commands)))))) + +(define %builtin-commands + `( + ("bg" . ,bg-command) + ("command" . ,command-command) + ("cd" . ,cd-command) + ("echo" . ,echo-command) + ("eval" . ,eval-command) + ("exit" . ,exit-command) + ("fg" . ,fg-command) + ("help" . ,help-command) + ("jobs" . ,jobs-command) + ("pwd" . ,pwd-command) + ("set" . ,set-command) + ("shift" . ,shift-command) + ("test" . ,test-command) + ("type" . ,type-command) + ("[" . ,bracket-command) + )) diff --git a/gash/commands/basename.scm b/gash/commands/basename.scm new file mode 100644 index 0000000..9c4a4fc --- /dev/null +++ b/gash/commands/basename.scm @@ -0,0 +1,77 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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) diff --git a/gash/commands/cat.scm b/gash/commands/cat.scm new file mode 100644 index 0000000..bd9a505 --- /dev/null +++ b/gash/commands/cat.scm @@ -0,0 +1,41 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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) diff --git a/gash/commands/chmod.scm b/gash/commands/chmod.scm new file mode 100644 index 0000000..df1ab14 --- /dev/null +++ b/gash/commands/chmod.scm @@ -0,0 +1,99 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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) diff --git a/gash/commands/compress.scm b/gash/commands/compress.scm new file mode 100644 index 0000000..5abf055 --- /dev/null +++ b/gash/commands/compress.scm @@ -0,0 +1,68 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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) diff --git a/gash/commands/cp.scm b/gash/commands/cp.scm new file mode 100644 index 0000000..69ad1d4 --- /dev/null +++ b/gash/commands/cp.scm @@ -0,0 +1,84 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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) diff --git a/gash/commands/dirname.scm b/gash/commands/dirname.scm new file mode 100644 index 0000000..567542e --- /dev/null +++ b/gash/commands/dirname.scm @@ -0,0 +1,62 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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) diff --git a/gash/commands/find.scm b/gash/commands/find.scm new file mode 100644 index 0000000..e3abb4a --- /dev/null +++ b/gash/commands/find.scm @@ -0,0 +1,65 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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) diff --git a/gash/commands/grep.scm b/gash/commands/grep.scm new file mode 100644 index 0000000..bc0aba5 --- /dev/null +++ b/gash/commands/grep.scm @@ -0,0 +1,109 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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) diff --git a/gash/commands/ls.scm b/gash/commands/ls.scm new file mode 100644 index 0000000..d7e2e03 --- /dev/null +++ b/gash/commands/ls.scm @@ -0,0 +1,106 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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) diff --git a/gash/commands/mkdir.scm b/gash/commands/mkdir.scm new file mode 100644 index 0000000..c798592 --- /dev/null +++ b/gash/commands/mkdir.scm @@ -0,0 +1,74 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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') diff --git a/gash/commands/mv.scm b/gash/commands/mv.scm new file mode 100644 index 0000000..724bf4e --- /dev/null +++ b/gash/commands/mv.scm @@ -0,0 +1,63 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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) diff --git a/gash/commands/reboot.scm b/gash/commands/reboot.scm new file mode 100644 index 0000000..b0783ad --- /dev/null +++ b/gash/commands/reboot.scm @@ -0,0 +1,44 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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') diff --git a/gash/commands/rm.scm b/gash/commands/rm.scm new file mode 100644 index 0000000..0638898 --- /dev/null +++ b/gash/commands/rm.scm @@ -0,0 +1,53 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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) diff --git a/gash/commands/rmdir.scm b/gash/commands/rmdir.scm new file mode 100644 index 0000000..3c21de8 --- /dev/null +++ b/gash/commands/rmdir.scm @@ -0,0 +1,71 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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) diff --git a/gash/commands/sed.scm b/gash/commands/sed.scm new file mode 100644 index 0000000..d7f9cc7 --- /dev/null +++ b/gash/commands/sed.scm @@ -0,0 +1,233 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2018 Timothy Sample +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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) diff --git a/gash/commands/sed/reader.scm b/gash/commands/sed/reader.scm new file mode 100644 index 0000000..8e9387d --- /dev/null +++ b/gash/commands/sed/reader.scm @@ -0,0 +1,322 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Timothy Sample +;;; +;;; 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 . + +(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))) diff --git a/gash/commands/tar.scm b/gash/commands/tar.scm new file mode 100644 index 0000000..fff6a8c --- /dev/null +++ b/gash/commands/tar.scm @@ -0,0 +1,168 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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) diff --git a/gash/commands/touch.scm b/gash/commands/touch.scm new file mode 100644 index 0000000..bd477bf --- /dev/null +++ b/gash/commands/touch.scm @@ -0,0 +1,85 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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) diff --git a/gash/commands/tr.scm b/gash/commands/tr.scm new file mode 100644 index 0000000..20eaa93 --- /dev/null +++ b/gash/commands/tr.scm @@ -0,0 +1,69 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; 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) diff --git a/gash/commands/wc.scm b/gash/commands/wc.scm new file mode 100644 index 0000000..3ca7f91 --- /dev/null +++ b/gash/commands/wc.scm @@ -0,0 +1,81 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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) diff --git a/gash/commands/which.scm b/gash/commands/which.scm new file mode 100644 index 0000000..cc0f49a --- /dev/null +++ b/gash/commands/which.scm @@ -0,0 +1,38 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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) diff --git a/gash/compress.scm b/gash/compress.scm new file mode 100644 index 0000000..d2f7e94 --- /dev/null +++ b/gash/compress.scm @@ -0,0 +1,162 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2013 Daniel Hartwig +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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)) diff --git a/gash/config.scm.in b/gash/config.scm.in new file mode 100644 index 0000000..8cb16da --- /dev/null +++ b/gash/config.scm.in @@ -0,0 +1,57 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash config) + #:export (%bzip2 + %commands + %xz + %compress + %gzip + %version)) + +;;; Commentary: +;;; +;;; Compile-time configuration of gash. When adding a substitution variable +;;; here, make sure to have configure substitute it. +;;; +;;; Code: + +(define %version + "@VERSION@") + +(define %bzip2 + "@BZIP2@") + +(define %compress + (let ((compress "@COMPRESS@") + (reloc (string-append (dirname (car (command-line))) "/compress"))) + (cond ((getenv "COMPRESS")) + ((file-exists? compress) compress) + ((file-exists? reloc) reloc)))) + +(define %commands + (let* ((guile-site-ccache-dir "@guile_site_ccache_dir@") + (commands-dir (string-append guile-site-ccache-dir "/gash/commands"))) + (cond ((getenv "COMMANDS")) + (else commands-dir)))) + +(define %gzip + "@GZIP@") + +(define %xz + "@XZ@") diff --git a/gash/environment.scm b/gash/environment.scm new file mode 100644 index 0000000..66b0381 --- /dev/null +++ b/gash/environment.scm @@ -0,0 +1,107 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 R.E.W. van Beusekom +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash environment) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + + #:use-module (ice-9 match) + #:use-module (gash io) + + #:export ( + %command-line + %functions + %global-variables + assignment + function + set-shell-opt! + shell-opt? + variable + variable-and + variable-or + )) + +(define %command-line (make-parameter (command-line))) + +;; FIXME: export/env vs set +(define %global-variables + (map identity ;; FIXME: make mutable + `(,(cons "SHELL" (car (command-line))) + ,(cons "SHELLOPTS" "") + ,(cons "PIPESTATUS" "([0]=\"0\"") + ,(cons "?" "0") + ,@(map (lambda (key-value) + (let* ((key-value (string-split key-value #\=)) + (key (car key-value)) + (value (cadr key-value))) + (cons key value))) + (environ))))) + +(define %functions '()) + +(define* (assignment name #:optional value) + (let ((value (match value + ((? string?) value) + (((? string?) ...) (apply string-append value)) + (#f "")))) + (set! %global-variables + (assoc-set! %global-variables name value)) + #t)) + +(define* (variable name #:optional (default "")) + (cond ((string->number name) + => + (lambda (n) + (if (< n (length (%command-line))) (list-ref (%command-line) n) + ""))) + ((equal? name "@") + (if (pair? (cdr (%command-line))) (cdr (%command-line)) + "")) + ((equal? name "#") + (number->string (length (cdr (%command-line))))) + (else + (or (assoc-ref %global-variables name) + (if (shell-opt? "nounset") (begin + ;; TODO: throw/error + (format (current-error-port) "gash: ~a: unbound variable\n" name) + #f) + default))))) + +(define (variable-or name . default) + (variable name (apply string-append default))) + +(define (variable-and name . default) + (let ((value (variable name #f))) + (if value (apply string-append default) ""))) + +(define (set-shell-opt! name set?) + (let* ((shell-opts (variable "SHELLOPTS")) + (options (if (string-null? shell-opts) '() + (string-split shell-opts #\:))) + (new-options (if set? (delete-duplicates (sort (cons name options) string<)) + (filter (negate (cut equal? <> name)) options))) + (new-shell-opts (string-join new-options ":"))) + (assignment "SHELLOPTS" new-shell-opts))) + +(define (shell-opt? name) + (member name (string-split (assoc-ref %global-variables "SHELLOPTS") #\:))) + +(define (function name body) + (set! %functions + (assoc-set! %functions name body))) diff --git a/gash/gash.scm b/gash/gash.scm new file mode 100644 index 0000000..37a95c9 --- /dev/null +++ b/gash/gash.scm @@ -0,0 +1,236 @@ +(define-module (gash gash) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + + #:use-module (ice-9 buffered-input) + #:use-module (ice-9 ftw) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 local-eval) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + + #: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) + #:use-module (gash io) + #:use-module (gash script) + #:use-module (gash util) + + #:export (main + %debug-level + %prefer-builtins? + parse + parse-string)) + +(catch #t + (lambda _ (use-modules (ice-9 readline))) + (lambda (key . args) + (use-modules (gash readline)))) + +(define %debug-level 0) ; 1 informational, 2 verbose, 3 peg tracing +(define %prefer-builtins? #f) ; use builtin, even if COMMAND is available in PATH? +(define %geesh-parser? #f) ; use Geesh parser [EXPERIMENTAL] + +(define (parse-string string) + (let ((parser (cond (%geesh-parser? (@ (gash geesh) parse-string)) + (else (@ (gash grammar) parse-string))))) + (parser string))) + +(define (parse port) + (let ((parser (cond (%geesh-parser? (@ (gash geesh) parse)) + (else (@ (gash grammar) parse))))) + (parser port))) + +(define (file-to-ast file-name) + (call-with-input-file file-name parse)) + +(define (display-help) + (let ((builtins (sort (map car (append (%bournish-commands) ;;%builtin-commands + )) string<))) + (display (string-append "\ +Usage: gash [OPTION]... [FILE]... + or gash [OPTION]... -- BUILTIN [ARG]... + +Options: + -c, --command=STRING Evaluate STRING and exit + -e, --errexit Exit upon error + -d, --debug Enable PEG tracing + -g, --geesh Use Geesh parser [EXPERIMENTAL] + -h, --help Display this help + -p, --parse Parse the shell script and print the parse tree + --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 " +gash (GASH) " %version " + +Copyright (C) 2016,2017,2018 R.E.W. van Beusekom +and others. + +This is Gash, Guile As SHell. Gash is free software and is covered by +the GNU General Public License version 3 or later, see COPYING for the +copyleft. +"))) + +(define (main args) + (let ((thunk + (lambda () + (job-control-init) + (let* ((option-spec '((command (single-char #\c) (value #t)) + (debug (single-char #\d)) + (errexit (single-char #\e)) + (help (single-char #\h)) + (parse (single-char #\p)) + (prefer-builtins) + (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)) + (opt? (lambda (name) (lambda (o) (and (eq? (car o) name) (cdr o))))) + (debug (length (filter-map (opt? 'debug) options))) + (debug? (option-ref options 'debug #f)) + (help? (option-ref options 'help #f)) + (parse? (option-ref options 'parse #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (set! %prefer-builtins? (option-ref options 'prefer-builtins #f)) + (set! %geesh-parser? (option-ref options 'geesh #f)) + (set-shell-opt! "errexit" (option-ref options 'errexit #f)) + (set-shell-opt! "xtrace" (option-ref options 'xtrace #f)) + (when (option-ref options 'debug #f) + (set! %debug-level debug)) + (cond + (help? (display-help)) + (version? (display-version)) + (command? (let ((ast (parse-string command?))) + (if parse? (pretty-print ast) + (run ast)) + (exit (script-status)))) + ((pair? files) + (let* ((script (car files)) + (ast (file-to-ast script))) + (if parse? (pretty-print ast) + (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)))) + (when (not (eof-object? line)) + (let* ((ast (parse-string line))) + (when (and ast + (not (string-null? line))) + (unless parse? + (run ast)) + (add-history line)) + (loop (let ((previous (if ast "" (string-append line "\n"))) + (next (readline (if ast (prompt) "> ")))) + (if (eof-object? next) next + (string-append previous next)))))))))) + (clear-history) + (read-history HOME) + (with-readline-completion-function completion thunk) + (write-history HOME) + (newline)))))))) + (thunk))) + +(define prompt + (let* ((l (string #\001)) + (r (string #\002)) + (e (string #\033)) + (user (getenv "USER")) + (host (gethostname)) + (home (getenv "HOME"))) + (lambda () + (let* ((cwd (getcwd)) + (cwd (if (string-prefix? home cwd) + (string-replace cwd "~" 0 (string-length home)) + cwd))) + (report-jobs) + (string-append + l e "[01;32m" r user "@" host l e "[00m" r ":" + l e "[01;34m" r cwd l e "[00m" r (if (zero? (getuid)) "# " "$ ")))))) + +(define (string-prefix s1 s2) + (substring/read-only s1 0 (string-prefix-length s1 s2))) + +(define next->file-completion (lambda () #f)) +(define next->binary-completion (lambda () #f)) + +(define (isdir? path) + (and (access? path F_OK) (eq? 'directory (stat:type (stat path))))) + +(define (ls dir) + (map (lambda (path) + (if (isdir? (string-append dir path)) + (string-append path "/") + path)) + (sort (filter (negate (cut string-every #\. <>)) + (scandir (if (string-null? dir) (getcwd) dir))) string) list))) + +(define (slash dir) + (if (string-suffix? "/" dir) dir + (string-append dir "/"))) + +(define (after-slash path) + (let ((at (string-index-right path #\/))) + (if at (string-drop path (+ 1 at)) + path))) + + +(define (file-name-completion text continue?) + (if continue? + (next->file-completion) + (let* ((dir (slash (if (isdir? text) text (dirname text)))) + (listing (ls dir)) + (dir (if (string=? "./" dir) "" dir)) + (completions (complete (after-slash text) listing))) + (set! next->file-completion + (lambda () + (if (null? completions) + #f + (let ((completion (car completions))) + (set! completions (cdr completions)) + (string-append dir completion))))) + (next->file-completion)))) + +(define (search-binary-in-path-completion text continue?) + (if (not continue?) + (let* ((paths (string-split (getenv "PATH") #\:)) + (binaries (apply append (filter identity (map scandir paths)))) + (completions (sort (filter (cut string-prefix? text <>) binaries) stringbinary-completion (lambda () + (if (null? completions) + #f + (let ((completion (car completions))) + (set! completions (cdr completions)) + completion)))) + (next->binary-completion)) + (next->binary-completion))) + +(define (completion text continue?) + (or (file-name-completion text continue?) (search-binary-in-path-completion text continue?))) diff --git a/gash/geesh.scm b/gash/geesh.scm new file mode 100644 index 0000000..73e4fa6 --- /dev/null +++ b/gash/geesh.scm @@ -0,0 +1,132 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash geesh) + #:use-module (srfi srfi-1) + + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + + #:use-module (gash builtins) + #:use-module (gash gash) + #:use-module (gash io) + #:export ( + parse + parse-string + )) + +(catch #t + (lambda _ (use-modules (geesh parser))) + (lambda (key . args) + #t)) + +(define (parse port) + (let ((parse-tree (read-sh-all port))) + (when (> %debug-level 1) + (format (current-error-port) "parse-tree:\n") + (pretty-print parse-tree (current-error-port))) + (let ((ast (parse-tree->script parse-tree))) + (when (> %debug-level 1) + (format (current-error-port) "transformed:\n") + (pretty-print ast (current-error-port))) + (let* ((script (match ast + (((or 'command 'pipeline) _ ...) `(script ,ast)) + ((_ ...) `(script ,@ast)) + (_ `(script ,ast)))) + (tracing-script (annotate-tracing script))) + (when (> %debug-level 0) + (format (current-error-port) "script:\n") + (pretty-print tracing-script (current-error-port))) + tracing-script)))) + +(define (parse-string string) + (call-with-input-string string parse)) + +(define (parse-tree->script tree) + (define (transform o) + (when (> %debug-level 2) + (format (current-error-port) "transform:\n") + (pretty-print o (current-error-port))) + (match o + ((' body ...) `(begin ,@(map transform body))) + ((' ((' (left ...))) right) + `(pipeline ,@(map transform left) ,(transform right))) + ((' (' (left ...) right)) + `(pipeline ,@(map transform left) ,(transform right))) + ((' (left right)) + `(pipeline ,(transform left) ,(transform right))) + ((' command) `(command ,(transform command))) + ((' command ...) `(command ,@(map transform command))) + (((and ref (' _)) words ...) + `(word ,(transform ref) ,@(map transform words))) + ((' var) `(variable ,var)) + ((' (var (and value ((? symbol?) _ ...)))) + `(assignment ,(transform var) ,(transform value))) + ((' (var (value ...))) + `(assignment ,(transform var) (word ,@(map transform value)))) + ((' (var value)) `(assignment ,(transform var) ,(transform value))) + (((and kwote (' _)) word) + `(word ,(transform kwote) ,(transform word))) + ((') + `(doublequotes "")) + ((' words ...) + `(doublequotes (word ,@(map transform words)))) + (((and quote (' _)) tail ...) + `(word ,(transform quote) ,@(map transform tail))) + ((' cmd) `(substitution ,(transform cmd))) + ((' (expression then)) `(if-clause ,(transform expression) ,(transform then))) + ((' (('<< 0 string)) pipeline) + (let ((pipeline (transform pipeline))) + `(pipeline (display ,(transform string)) + ,@(match pipeline + (('command command ...) `(,pipeline)) + (('pipeline commands ...) commands))))) + + ((' (name (sequence)) body) + `(for ,(transform name) + (lambda _ (split ,(transform sequence))) + (lambda _ ,(transform body)))) + + ((' (name sequence) body) + `(for ,(transform name) + (lambda _ (split ,(transform sequence))) + (lambda _ ,(transform body)))) + + ((? string?) o) + (((? string?) _ ...) `(word ,@(map re-word o))) + ((_ ...) (map transform o)) + (_ o))) + (transform tree)) + +(define (re-word word) + (match word + ((? string?) word) + (((and h (? string?)) t ...) + `(word ,h ,@(map (compose re-word parse-tree->script) t))) + (_ (parse-tree->script word)))) + +(define (annotate-tracing script) + (match script + (('pipeline command) + `(pipeline ,(trace (list command)) ,command)) + (('pipeline commands ...) + `(pipeline ,(trace commands) ,@commands)) + (('command command ...) + `(pipeline ,(trace (list script)) ,script)) + ((_ ...) (map annotate-tracing script)) + (_ script))) diff --git a/gash/grammar.scm b/gash/grammar.scm new file mode 100644 index 0000000..eb96872 --- /dev/null +++ b/gash/grammar.scm @@ -0,0 +1,301 @@ +(define-module (gash grammar) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 rdelim) + + #:use-module (srfi srfi-8) + + #:use-module (gash gash) + #:use-module (gash peg) + #:use-module (gash peg codegen) + + #:export (parse + parse-string)) + +(define (parse port) + (parse-string (read-string port))) + +(define (parse-string input) + + (define io-label "") + + (define (io-label-name str len pos) + (let ((at (string-skip str char-alphabetic? pos len))) + (set! io-label (substring str pos at)) + (if (< at len) (list at '()) + #f))) + + (define (io-label-match str len pos) + (if (string-prefix? io-label (substring str pos)) + (list (+ pos (string-length io-label)) '()) + #f)) + + (define-peg-pattern io-here-label none io-label-name) + (define-peg-pattern io-here-delim none io-label-match) + (define-peg-pattern io-here-document all + (and (+ (and (not-followed-by io-here-delim) + peg-any)) + io-here-delim)) + + (define-peg-string-patterns + "script <-- ws* compound + ws < sp / eol + sp < '\\\n'* (comment / [ \t\v]) + comment < [#] (!eol .)* + eol < [\n\r\f] + + compound <-- (term (&rpar / sep#))* + + sep <- sp* (amp ws* / semi ws* / eof) / ws+ + amp <- '&' + semi < ';'!';' + eof < !. + + term <- and / or / pipeline + and <-- pipeline and-op ws* term + or <-- pipeline or-op ws* term + and-op < '&&' + or-op < '||' + + pipeline <-- '!'? sp* (command (&sep / &or-op / &and-op / &rpar / eof / pipe#))+ + + and-or <- '&&' / '||' + + exclamation <- '!' + pipe < sp* '|' !'|' ws* + + command <-- function / compound-command / simple-command + + compound-command <- (subshell / brace-group / for-clause / case-clause / + if-clause / while-clause / until-clause) (sp* io-redirect)* + + simple-command <- ((io-redirect / assignment) sp*)* + ((io-redirect / nonreserved) sp*)+ / + ((io-redirect / assignment) sp*)+ + ((io-redirect / nonreserved) sp*)* + + assignment <-- name assign word? + assign < '=' + + io-redirect <-- [0-9]* (io-here / io-file) + io-file <-- io-op ([0-9]+ / sp* word) + io-op <- '<&' / '>&' / '>>' / '>' / '<>'/ '<' / '>|' + io-here <-- io-here-op io-here-label sp* eol io-here-document + io-here-op <- '<<-' / '<<' + + reserved < ('case' / 'esac' / 'in' / 'if' / 'fi' / 'then' / 'else' / + 'elif' / 'for' / 'done' / 'do' / 'until' / 'while') &ws + nonreserved <- !reserved word + + word <-- test / substitution / + (number / variable-subst / variable / delim / literal)+ + + function <-- name sp* lpar rpar# ws* function-body + name <-- !reserved identifier + function-body <- brace-group (sp* io-redirect)* + + subshell <-- lpar compound rpar# + brace-group <-- lbrace ws* compound rbrace# + + case-clause <-- case-keyword sp* word sp* in-keyword# ws* case-item+ ws* esac-keyword# + case-item <-- pattern sp* colon? ws* compound? case-sep? + colon < ':' + case-sep < ';;' ws* + pattern <-- (word (!rpar '|'# / !'|' &rpar))+ rpar# + + for-clause <-- for-keyword sp+ identifier ws+ (in-keyword sp+ expression)? sep# do-group + expression <-- command + do-group <-- do-keyword ws+ compound done-keyword# + + if-clause <-- if-keyword sp+ compound then-keyword# ws+ compound else-part? fi-keyword# + else-part <-- else-keyword ws+ compound / elif + elif <-- elif-keyword ws+ compound then-keyword# ws+ compound else-part? + + while-clause <-- while-keyword compound do-group + + until-clause <-- until-keyword compound do-group + + test <- ('[' / '\\[') sp+ test-args sp+ ']'# + test-args <-- (sp* word)+ + + literal <- !reserved (escaped / !allowed .)+ + escaped <- escape [ \"$] + escape < [\\] + allowed <- ']' / [ \t\v\f\n`'\")};|&$] / '\\\n' + + identifier <- [_a-zA-Z][_a-zA-Z0-9]* + + dollar < '$' + number <-- [0-9]+ + + substitution <-- dollar lpar compound rpar# / bt ([\\] bt / !bt .)+ bt# + lpar < '(' + rpar < ')' + bt < [`] + + variable <-- dollar ('#' / '@' / '*' / [0-9] / name / + lbrace name (variable-literal / &rbrace) rbrace) + variable-subst <- dollar lbrace (variable-or / variable-and / variable-regex) rbrace + variable-or <-- name min variable-word variable-word* + variable-and <-- name plus variable-word variable-word* + variable-word <- variable-regex / substitution / variable-subst / variable / variable-literal !slash / variable-string / sp* + variable-regex <-- name &slash regex-sep variable-literal '/' variable-string &rbrace / + name regex-sep variable-string + slash < '/' + variable-string <- (!rbrace ((!dq !sq .) / delim))+ + variable-literal <- (!rbrace !min !plus !slash ((!dq !sq .) / delim))+ + regex-sep <-- ('/' / '%%' / '%' / '##' / '#' / '^^' / '^' /',,' / ',' / '*' / '@' / '?') + min < '-' + plus < '+' + lbrace < '{' + rbrace < '}' + + + delim <-- singlequotes / doublequotes / substitution + sq < ['] + dq < [\"] + singlequotes <- sq (!sq .)* sq# + doublequotes <- dq (substitution / variable-subst / variable / (!dq (escape '\"' / .)))* dq# + + case-keyword < 'case' + do-keyword < 'do' + done-keyword < 'done' + elif-keyword < 'elif' + else-keyword < 'else' + esac-keyword < 'esac' + fi-keyword < 'fi' + for-keyword < 'for' + if-keyword < 'if' + in-keyword < 'in' + then-keyword < 'then' + until-keyword < 'until' + while-keyword < 'while' +") + + (catch 'syntax-error + (lambda () + (let* ((match (match-pattern script input)) + (end (peg:end match)) + (tree (peg:tree match))) + (when (> %debug-level 0) + (format #t "parse tree:\n") + (pretty-print tree)) + (if (eq? (string-length input) end) + (let ((script (transform tree))) + (when (> %debug-level 0) + (format #t "script:\n") + (pretty-print script)) + script) + (if match + (begin + (format (current-error-port) "parse error: at offset: ~a\n" end) + (pretty-print tree) + #f) + (begin + (format (current-error-port) "parse error: no match\n") + #f))))) + (lambda (key . args) + (define (line-column input pos) + (let ((length (string-length input))) + (let loop ((lines (string-split input #\newline)) (ln 1) (p 0)) + (if (null? lines) (values #f #f input) + (let* ((line (car lines)) + (length (string-length line)) + (end (+ p length 1)) + (last? (null? (cdr lines)))) + (if (<= pos end) (values ln (+ (if last? 0 1) (- pos p)) + (if last? line + (string-append line "\\n" (cadr lines)))) + (loop (cdr lines) (1+ ln) end))))))) + (define (format-peg o) + (match o + (('or l ...) (string-join (map format-peg l) ", or ")) + (('and l ...) (string-join (map format-peg l) " ")) + ((? symbol?) (symbol->string o)) + ((? string?) o))) + + (receive (ln col line) (line-column input (caar args)) + (let* ((col (- col 1)) + (indent (make-string col #\space))) + (format #t "~a:~a:~a: syntax-error:\n~a\n~a^\n~aexpected: ~a\n" + "" + ln col line + indent + indent + (format-peg (cadar args))) + (exit 1)))))) + +(define (transform o) + (match o + + (('script command) (transform command)) + (('script command ...) `(begin ,@(map transform command))) + + ;; FIXME: cannot remove pipeline even if it's a single command + ;; `pipeline' is what executes commands and evaluates them + ;; (set -e) + ;; (('pipeline pipeline) (transform pipeline)) + ;; or it results in ((if ...)); which won't work either + ;; (('pipeline pipeline) (let ((x (transform pipeline))) + ;; (match x + ;; (('command command ...) (list x)) + ;; (_ x)))) + + (('compound compound) (transform compound)) + (('compound compound ...) `(begin ,@(map transform compound))) + + (('command ('word (or "." "source")) file-name) + `(source ,(transform file-name))) + (('command word ... ('io-redirect ('io-here "<<" ('io-here-document string)))) + `(pipeline (cut display ,string) (command ,@word))) + (('command word ... ('io-redirect filedes ... ('io-file ">" file-name))) + (cond ((or (null? filedes) (equal? filedes '("1"))) + `(with-output-to-file ,file-name + ,(let ((command (transform `(command ,@word)))) + (match command + (('with-input-from-file arg ...) + `(cut with-input-from-file ,@arg)) + (_ command))))) + ((equal? filedes '("2")) + `(with-error-to-file ,file-name + ,(let ((command (transform `(command ,@word)))) + (match command + (('with-input-from-file arg ...) + `(cut with-input-from-file ,@arg)) + (_ command))))) + (else (error (format #f "TODO: output to filedes=~a\n" filedes))))) + (('command word ... ('io-redirect ('io-file "<" file-name))) + `(with-input-from-file ,file-name ,(transform `(command ,@word)))) + + (('command ('word (and (? string?) string)) ...) + `(command ,@string)) + + (('command ('if-clause if-clause ...)) + (transform `(if-clause ,@if-clause))) + (('if-clause expr then) + `(if (true? ,(transform expr)) ,(transform then) 0)) + (('if-clause expr then ('else-part else)) + `(if (true? ,(transform expr)) ,(transform then) ,(transform else))) + (('if-clause expr then ..1) + `(if (true? ,(transform expr)) (begin ,@(map transform then)) 0)) + (('if-clause expr then ..1 ('else-part else)) + `(if (true? ,(transform expr)) (begin ,@(map transform then)) ,(transform else))) + (('if-clause expr then ('else-part else ..1)) + `(if (true? ,(transform expr)) ,(transform then) ,@(map transform else))) + (('if-clause expr then ..1 ('else-part else ..1)) + `(if (true? ,(transform expr)) (begin ,@(map transform then)) (begin ,@(map transform else)))) + + (('elif elif ...) (transform `(if-clause ,@elif))) + + (('function name body) + `(function ,name (lambda ( . args) ,(transform body)))) + + (('word 'delim) '(word "")) + + (('pipeline ('command ('word "shift"))) '(shift)) + + (('command ('word (and (or "[" "\\[") bracket) ('test-args test-args ...) "]")) + `(command (word ,bracket) ,@(map transform test-args) (word "]"))) + + ((h t ...) (map transform o)) + (_ o))) diff --git a/gash/guix-utils.scm b/gash/guix-utils.scm new file mode 100644 index 0000000..f347b5b --- /dev/null +++ b/gash/guix-utils.scm @@ -0,0 +1,202 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015 Mark H Weaver +;;; Copyright © 2014 Eric Bavier +;;; Copyright © 2014 Ian Denhardt +;;; Copyright © 2016 Mathieu Lirzin +;;; Copyright © 2015 David Thompson +;;; Copyright © 2017 Efraim Flashner +;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2018 Marius Bakke +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial guix-utils.scm was taken from Guix. + +;;; Code: + +(define-module (gash guix-utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-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 () + (apply execl (car command) command)) + (lambda args + (format (current-error-port) + "filtered-port: failed to execute '~{~a ~}': ~a~%" + command (strerror (system-error-errno args)))))) + (lambda () + (primitive-_exit 1)))) + (child + (close-port out) + (values in (cons child pids)))))) + + ;; INPUT is not a file port, so fork just for the sake of tunneling it + ;; through a file port. + (match (pipe) + ((in . out) + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (close-port in) + (dump-port input out)) + (lambda () + (close-port input) + (false-if-exception (close out)) + (primitive-_exit 0)))) + (child + (close-port input) + (close-port out) + (loop in (cons child pids))))))))) + +(define (decompressed-port compression input) + "Return an input port where INPUT is decompressed according to COMPRESSION, +a symbol such as 'xz." + (match compression + ((or #f 'none) (values input '())) + ('bzip2 (filtered-port `(,%bzip2 "-dc") input)) + ('compress (filtered-port `(,%compress "-dc") input)) + ('xz (filtered-port `(,%xz "-dc" "-T0") input)) + ('gzip (filtered-port `(,%gzip "-dc") input)) + (else (error "unsupported compression scheme" compression)))) + +(define (compressed-port compression input) + "Return an input port where INPUT is decompressed according to COMPRESSION, +a symbol such as 'xz." + (match compression + ((or #f 'none) (values input '())) + ('bzip2 (filtered-port `(,%bzip2 "-c") input)) + ('compress (filtered-port `(,%compress "-c") input)) + ('xz (filtered-port `(,%xz "-c" "-T0") input)) + ('gzip (filtered-port `(,%gzip "-c") input)) + (else (error "unsupported compression scheme" compression)))) + +(define (call-with-decompressed-port compression port proc) + "Call PROC with a wrapper around PORT, a file port, that decompresses data +read from PORT according to COMPRESSION, a symbol such as 'xz." + (let-values (((decompressed pids) + (decompressed-port compression port))) + (dynamic-wind + (const #f) + (lambda () + (proc decompressed)) + (lambda () + (close-port decompressed) + (unless (every (compose zero? cdr waitpid) pids) + (error "decompressed-port failure" pids)))))) + +(define (filtered-output-port command output) + "Return an output port. Data written to that port is filtered through +COMMAND and written to OUTPUT, an output file port. In addition, return a +list of PIDs to wait for. OUTPUT must be unbuffered; otherwise, any buffered +data is lost." + (match (pipe) + ((in . out) + (match (primitive-fork) + (0 + (dynamic-wind + (const #f) + (lambda () + (close-port out) + (close-port (current-input-port)) + (dup2 (fileno in) 0) + (close-port (current-output-port)) + (dup2 (fileno output) 1) + (catch 'system-error + (lambda () + (apply execl (car command) command)) + (lambda args + (format (current-error-port) + "filtered-output-port: failed to execute '~{~a ~}': ~a~%" + command (strerror (system-error-errno args)))))) + (lambda () + (primitive-_exit 1)))) + (child + (close-port in) + (values out (list child))))))) + +(define* (compressed-output-port compression output + #:key (options '())) + "Return an output port whose input is compressed according to COMPRESSION, +a symbol such as 'xz, and then written to OUTPUT. In addition return a list +of PIDs to wait for. OPTIONS is a list of strings passed to the compression +program--e.g., '(\"--fast\")." + (match compression + ((or #f 'none) (values output '())) + ('bzip2 (filtered-output-port `(,%bzip2 "-c" ,@options) output)) + ('compress (filtered-output-port `(,%compress "-c" ,@options) output)) + ('xz (filtered-output-port `(,%xz "-c" "-T0" ,@options) output)) + ('gzip (filtered-output-port `(,%gzip "-c" ,@options) output)) + (else (error "unsupported compression scheme" compression)))) + +(define* (call-with-compressed-output-port compression port proc + #:key (options '())) + "Call PROC with a wrapper around PORT, a file port, that compresses data +that goes to PORT according to COMPRESSION, a symbol such as 'xz. OPTIONS is +a list of command-line arguments passed to the compression program." + (let-values (((compressed pids) + (compressed-output-port compression port + #:options options))) + (dynamic-wind + (const #f) + (lambda () + (proc compressed)) + (lambda () + (close-port compressed) + (unless (every (compose zero? cdr waitpid) pids) + (error "compressed-output-port failure" pids)))))) diff --git a/gash/io.scm b/gash/io.scm new file mode 100644 index 0000000..749320b --- /dev/null +++ b/gash/io.scm @@ -0,0 +1,24 @@ +(define-module (gash io) + + #:use-module (srfi srfi-1) + #:export (pke stdout stderr)) + +(define (output port o) + (map (lambda (o) (display o port)) o) + (newline port) + (force-output port)) + +(define (stdout . o) + (output (current-output-port) o) + (last o)) + +(define (stderr . o) + (output (current-error-port) o) + (last o)) + +(define (pke . stuff) + (newline (current-error-port)) + (display ";;; " (current-error-port)) + (write stuff (current-error-port)) + (newline (current-error-port)) + (car (last-pair stuff))) diff --git a/gash/job.scm b/gash/job.scm new file mode 100644 index 0000000..fe0b906 --- /dev/null +++ b/gash/job.scm @@ -0,0 +1,175 @@ +(define-module (gash job) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + + #:use-module (gash io) + #:use-module (gash util) + + #:export ( + bg + fg + display-job + job-table + job? + job-add-process + job-control-init + job-debug-id + job-setup-process + job-status + new-job + report-jobs + wait + )) + +(define-record-type + (make-process pid command status) + process? + (pid process-pid) + (command process-command) + (status process-status set-process-status!)) + +(define-record-type + (make-job id pgid processes debug-id) + job? + (id job-id) + (pgid job-pgid set-job-pgid!) + (processes job-processes set-job-processes!) + (debug-id job-debug-id)) + +(define debug-id + (let ((id -1)) + (lambda () + (set! id (1+ id)) + (number->string id)))) + +(define (new-job) + (let ((job (make-job (+ 1 (length job-table)) #f '() (debug-id)))) + (set! job-table (cons job job-table)) + job)) + +(define job-table '()) ;; list of + +(define (job-index index) + (let ((index (- (length job-table) index))) + (if (<= 0 index) + (list-ref job-table index) + #f))) + +(define (status->state status) + (cond ((not status) 'Running) + ((status:exit-val status) 'Done) + ((status:term-sig status) 'Terminated) + ((status:stop-sig status) 'Stopped))) + +(define (job-command job) + (string-join (map (compose string-join process-command) (reverse (job-processes job))) " | ")) + +(define (display-job job) + (stdout "[" (job-id job) "] " (map status->state (job-status job)) "\t\t" + (job-command job))) + +(define (job-status job) + (map process-status (job-processes job))) + +(define (job-update job pid status) + (unless (= 0 pid) + (let ((proc (find (compose (cut eqv? pid <>) process-pid) (job-processes job)))) + (when proc + (set-process-status! proc status))))) + +(define (job-running? job) + (find (compose not process-status) (job-processes job))) + +(define (job-stopped? job) + (find status:stop-sig (filter-map process-status (job-processes job)))) + +(define (job-completed? job) + (let ((state (map (compose status->state process-status) (job-processes job)))) + (every (cut member <> '(Done Terminated)) state))) + +(define (add-to-process-group job pid) + (let* ((interactive? (isatty? (current-error-port))) + (pgid (if interactive? + (or (job-pgid job) pid) + (getpgrp)))) + (set-job-pgid! job pgid) + (when interactive? (setpgid pid pgid)) + pgid)) + +(define (job-add-process fg? job pid command) + (let ((pgid (add-to-process-group job pid))) + (set-job-pgid! job pgid) + (stderr "job-add-process fg?=~a\n" fg?) + (when (and (isatty? (current-error-port)) + fg?) + (tcsetpgrp (current-error-port) pgid)) + (set-job-processes! job (cons (make-process pid command #f) (job-processes job))))) + +(define (job-setup-process fg? job) + (when (isatty? (current-error-port)) + (when (and (isatty? (current-error-port)) + fg?) + (tcsetpgrp (current-error-port) (add-to-process-group job (getpid)))) + (map (cut sigaction <> SIG_DFL) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)))) + +(define (job-control-init) + (when (isatty? (current-error-port)) + (let ((pgid (getpgrp))) + (while (and #f ;; FIXME: make check backgrouds our tests + (isatty? (current-error-port)) + (not (eqv? (tcgetpgrp (current-error-port)) pgid))) + (kill (- pgid) SIGTTIN))) ;; oops we are not in the foreground + (map (cut sigaction <> SIG_IGN) (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU)) + (sigaction SIGCHLD SIG_DFL) + (let ((pid (getpid))) + (setpgid pid pid) ;; create new process group for ourself + (tcsetpgrp (current-error-port) pid)))) + +(define (reap-jobs) + (set! job-table (filter (disjoin job-running? job-stopped?) job-table))) + +(define (report-jobs) + (when (not (null? job-table)) + (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) + (pid (car pid-status)) + (status (cdr pid-status))) + (unless (= 0 pid) + (map (cut job-update <> pid status) job-table) + (map display-job (filter job-completed? job-table)) + (reap-jobs))))) + +(define (wait job) + (when (job-running? job) + (let loop () + (let* ((pid-status (waitpid (- (job-pgid job)) WUNTRACED)) + (pid (car pid-status)) + (status (cdr pid-status))) + (job-update job pid status) + (if (job-running? job) (loop))))) + (unless (job-completed? job) + (newline) (display-job job)) + (reap-jobs) + (or (find (negate zero?) (job-status job)) + 0)) + +(define (fg index) + (let ((job (job-index index))) + (cond (job + (let ((pgid (job-pgid job))) + (tcsetpgrp (current-error-port) pgid) + (kill (- (job-pgid job)) SIGCONT)) + (stdout (job-command job)) + (wait job)) + (#t + (stderr "fg: no such job " index))))) + +(define (bg index) + (let ((job (job-index index))) + (cond (job + (map (cut set-process-status! <> #f) (job-processes job)) + (kill (- (job-pgid job)) SIGCONT)) + (#t + (stderr "fg: no such job " index))))) diff --git a/gash/lzw.scm b/gash/lzw.scm new file mode 100644 index 0000000..fcf7a2c --- /dev/null +++ b/gash/lzw.scm @@ -0,0 +1,151 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2013 Daniel Hartwig +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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)))))) diff --git a/gash/peg.scm b/gash/peg.scm new file mode 100644 index 0000000..5d6ab04 --- /dev/null +++ b/gash/peg.scm @@ -0,0 +1,41 @@ +;;;; peg.scm --- Parsing Expression Grammar (PEG) parser generator +;;;; +;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (gash peg) + #:use-module (gash peg codegen) + #:use-module (gash peg string-peg) + ;; Note: the most important effect of using string-peg is not whatever + ;; functions it exports, but the fact that it adds a new handler to + ;; peg-sexp-compile. + #:use-module (gash peg simplify-tree) + #:use-module (gash peg using-parsers) + #:use-module (gash peg cache) + #:re-export (define-peg-pattern + define-peg-string-patterns + match-pattern + search-for-pattern + compile-peg-pattern + keyword-flatten + context-flatten + peg:start + peg:end + peg:string + peg:tree + peg:substring + peg-record?)) diff --git a/gash/peg/cache.scm b/gash/peg/cache.scm new file mode 100644 index 0000000..fd192b7 --- /dev/null +++ b/gash/peg/cache.scm @@ -0,0 +1,45 @@ +;;;; cache.scm --- cache the results of parsing +;;;; +;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (gash peg cache) + #:export (cg-cached-parser)) + +;; The results of parsing using a nonterminal are cached. Think of it like a +;; hash with no conflict resolution. Process for deciding on the cache size +;; wasn't very scientific; just ran the benchmarks and stopped a little after +;; the point of diminishing returns on my box. +(define *cache-size* 512) + +(define (make-cache) + (make-vector *cache-size* #f)) + +;; given a syntax object which is a parser function, returns syntax +;; which, if evaluated, will become a parser function that uses a cache. +(define (cg-cached-parser parser) + #`(let ((cache (make-cache))) + (lambda (str strlen at) + (let* ((vref (vector-ref cache (modulo at *cache-size*)))) + ;; Check to see whether the value is cached. + (if (and vref (eq? (car vref) str) (= (cadr vref) at)) + (caddr vref);; If it is return it. + (let ((fres ;; Else calculate it and cache it. + (#,parser str strlen at))) + (vector-set! cache (modulo at *cache-size*) + (list str at fres)) + fres)))))) diff --git a/gash/peg/codegen.scm b/gash/peg/codegen.scm new file mode 100644 index 0000000..9b91474 --- /dev/null +++ b/gash/peg/codegen.scm @@ -0,0 +1,390 @@ +;;;; codegen.scm --- code generation for composable parsers +;;;; +;;;; Copyright (C) 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (gash peg codegen) + #:export (compile-peg-pattern wrap-parser-for-users add-peg-compiler!) + #:use-module (ice-9 pretty-print) + #:use-module (system base pmatch)) + +(define-syntax single? + (syntax-rules () + "Return #t if X is a list of one element." + ((_ x) + (pmatch x + ((_) #t) + (else #f))))) + +(define-syntax single-filter + (syntax-rules () + "If EXP is a list of one element, return the element. Otherwise +return EXP." + ((_ exp) + (pmatch exp + ((,elt) elt) + (,elts elts))))) + +(define-syntax push-not-null! + (syntax-rules () + "If OBJ is non-null, push it onto LST, otherwise do nothing." + ((_ lst obj) + (if (not (null? obj)) + (push! lst obj))))) + +(define-syntax push! + (syntax-rules () + "Push an object onto a list." + ((_ lst obj) + (set! lst (cons obj lst))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; CODE GENERATORS +;; These functions generate scheme code for parsing PEGs. +;; Conventions: +;; accum: (all name body none) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Code we generate will have a certain return structure depending on how we're +;; accumulating (the ACCUM variable). +(define (cg-generic-ret accum name body-uneval at) + ;; name, body-uneval and at are syntax + #`(let ((body #,body-uneval)) + #,(cond + ((and (eq? accum 'all) name) + #`(list #,at + (cond + ((not (list? body)) (list '#,name body)) + ((null? body) '#,name) + ((symbol? (car body)) (list '#,name body)) + (else (cons '#,name body))))) + ((eq? accum 'name) + #`(list #,at '#,name)) + ((eq? accum 'body) + #`(list #,at + (cond + ((single? body) (car body)) + (else body)))) + ((eq? accum 'none) + #`(list #,at '())) + (else + (begin + (pretty-print `(cg-generic-ret-error ,accum ,name ,body-uneval ,at)) + (pretty-print "Defaulting to accum of none.\n") + #`(list #,at '())))))) + +;; The short name makes the formatting below much easier to read. +(define cggr cg-generic-ret) + +;; Generates code that matches a particular string. +;; E.g.: (cg-string syntax "abc" 'body) +(define (cg-string pat accum) + (let ((plen (string-length pat))) + #`(lambda (str len pos) + (let ((end (+ pos #,plen))) + (and (<= end len) + (string= str #,pat pos end) + #,(case accum + ((all) #`(list end (list 'cg-string #,pat))) + ((name) #`(list end 'cg-string)) + ((body) #`(list end #,pat)) + ((none) #`(list end '())) + (else (error "bad accum" accum)))))))) + +;; Generates code for matching any character. +;; E.g.: (cg-peg-any syntax 'body) +(define (cg-peg-any accum) + #`(lambda (str len pos) + (and (< pos len) + #,(case accum + ((all) #`(list (1+ pos) + (list 'cg-peg-any (substring str pos (1+ pos))))) + ((name) #`(list (1+ pos) 'cg-peg-any)) + ((body) #`(list (1+ pos) (substring str pos (1+ pos)))) + ((none) #`(list (1+ pos) '())) + (else (error "bad accum" accum)))))) + +;; Generates code for matching a range of characters between start and end. +;; E.g.: (cg-range syntax #\a #\z 'body) +(define (cg-range pat accum) + (syntax-case pat () + ((start end) + (if (not (and (char? (syntax->datum #'start)) + (char? (syntax->datum #'end)))) + (error "range PEG should have characters after it; instead got" + #'start #'end)) + #`(lambda (str len pos) + (and (< pos len) + (let ((c (string-ref str pos))) + (and (char>=? c start) + (char<=? c end) + #,(case accum + ((all) #`(list (1+ pos) (list 'cg-range (string c)))) + ((name) #`(list (1+ pos) 'cg-range)) + ((body) #`(list (1+ pos) (string c))) + ((none) #`(list (1+ pos) '())) + (else (error "bad accum" accum)))))))))) + +;; Generate code to match a pattern and do nothing with the result +(define (cg-ignore pat accum) + (syntax-case pat () + ((inner) + (compile-peg-pattern #'inner 'none)))) + +(define (cg-capture pat accum) + (syntax-case pat () + ((inner) + (compile-peg-pattern #'inner 'body)))) + +;; Filters the accum argument to compile-peg-pattern for buildings like string +;; literals (since we don't want to tag them with their name if we're doing an +;; "all" accum). +(define (builtin-accum-filter accum) + (cond + ((eq? accum 'all) 'body) + ((eq? accum 'name) 'name) + ((eq? accum 'body) 'body) + ((eq? accum 'none) 'none))) +(define baf builtin-accum-filter) + +;; Top-level function builder for AND. Reduces to a call to CG-AND-INT. +(define (cg-and clauses accum) + #`(lambda (str len pos) + (let ((body '())) + #,(cg-and-int clauses (baf accum) #'str #'len #'pos #'body)))) + +;; Internal function builder for AND (calls itself). +(define (cg-and-int clauses accum str strlen at body) + (syntax-case clauses () + (() + (cggr accum 'cg-and #`(reverse #,body) at)) + ((first rest ...) + #`(let ((res (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at))) + (and res + ;; update AT and BODY then recurse + (let ((newat (car res)) + (newbody (cadr res))) + (set! #,at newat) + (push-not-null! #,body (single-filter newbody)) + #,(cg-and-int #'(rest ...) accum str strlen at body))))))) + +;; Top-level function builder for OR. Reduces to a call to CG-OR-INT. +(define (cg-or clauses accum) + #`(lambda (str len pos) + #,(cg-or-int clauses (baf accum) #'str #'len #'pos))) + +;; Internal function builder for OR (calls itself). +(define (cg-or-int clauses accum str strlen at) + (syntax-case clauses () + (() + #f) + ((first rest ...) + #`(or (#,(compile-peg-pattern #'first accum) #,str #,strlen #,at) + #,(cg-or-int #'(rest ...) accum str strlen at))))) + +(define (cg-* args accum) + (syntax-case args () + ((pat) + #`(lambda (str strlen at) + (let ((body '())) + (let lp ((end at) (count 0)) + (let* ((match (#,(compile-peg-pattern #'pat (baf accum)) + str strlen end)) + (new-end (if match (car match) end)) + (count (if (> new-end end) (1+ count) count))) + (if (> new-end end) + (push-not-null! body (single-filter (cadr match)))) + (if (and (> new-end end) + #,#t) + (lp new-end count) + (let ((success #,#t)) + #,#`(and success + #,(cggr (baf accum) 'cg-body + #'(reverse body) #'new-end))))))))))) + +(define (cg-+ args accum) + (syntax-case args () + ((pat) + #`(lambda (str strlen at) + (let ((body '())) + (let lp ((end at) (count 0)) + (let* ((match (#,(compile-peg-pattern #'pat (baf accum)) + str strlen end)) + (new-end (if match (car match) end)) + (count (if (> new-end end) (1+ count) count))) + (if (> new-end end) + (push-not-null! body (single-filter (cadr match)))) + (if (and (> new-end end) + #,#t) + (lp new-end count) + (let ((success #,#'(>= count 1))) + #,#`(and success + #,(cggr (baf accum) 'cg-body + #'(reverse body) #'new-end))))))))))) + +(define (cg-? args accum) + (syntax-case args () + ((pat) + #`(lambda (str strlen at) + (let ((body '())) + (let lp ((end at) (count 0)) + (let* ((match (#,(compile-peg-pattern #'pat (baf accum)) + str strlen end)) + (new-end (if match (car match) end)) + (count (if (> new-end end) (1+ count) count))) + (if (> new-end end) + (push-not-null! body (single-filter (cadr match)))) + (if (and (> new-end end) + #,#'(< count 1)) + (lp new-end count) + (let ((success #,#t)) + #,#`(and success + #,(cggr (baf accum) 'cg-body + #'(reverse body) #'new-end))))))))))) + +(define (cg-followed-by args accum) + (syntax-case args () + ((pat) + #`(lambda (str strlen at) + (let ((body '())) + (let lp ((end at) (count 0)) + (let* ((match (#,(compile-peg-pattern #'pat (baf accum)) + str strlen end)) + (new-end (if match (car match) end)) + (count (if (> new-end end) (1+ count) count))) + (if (> new-end end) + (push-not-null! body (single-filter (cadr match)))) + (if (and (> new-end end) + #,#'(< count 1)) + (lp new-end count) + (let ((success #,#'(= count 1))) + #,#`(and success + #,(cggr (baf accum) 'cg-body #''() #'at))))))))))) + +(define (cg-not-followed-by args accum) + (syntax-case args () + ((pat) + #`(lambda (str strlen at) + (let ((body '())) + (let lp ((end at) (count 0)) + (let* ((match (#,(compile-peg-pattern #'pat (baf accum)) + str strlen end)) + (new-end (if match (car match) end)) + (count (if (> new-end end) (1+ count) count))) + (if (> new-end end) + (push-not-null! body (single-filter (cadr match)))) + (if (and (> new-end end) + #,#'(< count 1)) + (lp new-end count) + (let ((success #,#'(= count 1))) + #,#`(if success + #f + #,(cggr (baf accum) 'cg-body #''() #'at))))))))))) + + +(define (cg-expect-int clauses accum str strlen at) + (syntax-case clauses () + ((pat) + #`(or (#,(compile-peg-pattern #'pat accum) #,str #,strlen #,at) + (throw 'syntax-error (list #,at (syntax->datum #'pat))))))) ;;TODO throw partial match + +(define (cg-expect clauses accum) + #`(lambda (str len pos) + #,(cg-expect-int clauses ((@@ (ice-9 peg codegen) baf) accum) #'str #'len #'pos))) + +;; Association list of functions to handle different expressions as PEGs +(define peg-compiler-alist '()) + +(define (add-peg-compiler! symbol function) + (set! peg-compiler-alist + (assq-set! peg-compiler-alist symbol function))) + +(add-peg-compiler! 'range cg-range) +(add-peg-compiler! 'ignore cg-ignore) +(add-peg-compiler! 'capture cg-capture) +(add-peg-compiler! 'and cg-and) +(add-peg-compiler! 'or cg-or) +(add-peg-compiler! '* cg-*) +(add-peg-compiler! '+ cg-+) +(add-peg-compiler! '? cg-?) +(add-peg-compiler! 'followed-by cg-followed-by) +(add-peg-compiler! 'not-followed-by cg-not-followed-by) +(add-peg-compiler! 'expect cg-expect) + +;; Takes an arbitrary expressions and accumulation variable, then parses it. +;; E.g.: (compile-peg-pattern syntax '(and "abc" (or "-" (range #\a #\z))) 'all) +(define (compile-peg-pattern pat accum) + (syntax-case pat (peg-any) + (peg-any + (cg-peg-any (baf accum))) + (sym (identifier? #'sym) ;; nonterminal + #'sym) + (str (string? (syntax->datum #'str)) ;; literal string + (cg-string (syntax->datum #'str) (baf accum))) + ((name . args) (let* ((nm (syntax->datum #'name)) + (entry (assq-ref peg-compiler-alist nm))) + (if entry + (entry #'args accum) + (error "Bad peg form" nm #'args + "Not one of" (map car peg-compiler-alist))))))) + +;; Packages the results of a parser + +(define indent 0) + +(define (trace? symbol) + (and #f (not (memq symbol '())))) + +(define (wrap-parser-for-users for-syntax parser accumsym s-syn) + #`(lambda (str strlen at) + (when (trace? '#,s-syn) + (format (current-error-port) "~a~a\n" + (make-string indent #\space) + '#,s-syn)) + (set! indent (+ indent 4)) + (let ((res (#,parser str strlen at))) + (set! indent (- indent 4)) + ;; Try to match the nonterminal. + (let ((pos (or (and res (car res)) 0))) + (when (and (trace? '#,s-syn) (< at pos)) + (format (current-error-port) "~a~a := ~s\tnext: ~s\n" + (make-string indent #\space) + '#,s-syn + (substring str at pos) + (substring str pos (min strlen (+ pos 10)))))) + (if res + ;; If we matched, do some post-processing to figure out + ;; what data to propagate upward. + (let ((at (car res)) + (body (cadr res))) + #,(cond + ((eq? accumsym 'name) + #`(list at '#,s-syn)) + ((eq? accumsym 'all) + #`(list (car res) + (cond + ((not (list? body)) + (list '#,s-syn body)) + ((null? body) '#,s-syn) + ((symbol? (car body)) + (list '#,s-syn body)) + (else (cons '#,s-syn body))))) + ((eq? accumsym 'none) #`(list (car res) '())) + (else #`(begin res)))) + ;; If we didn't match, just return false. + #f)))) diff --git a/gash/peg/simplify-tree.scm b/gash/peg/simplify-tree.scm new file mode 100644 index 0000000..264e29e --- /dev/null +++ b/gash/peg/simplify-tree.scm @@ -0,0 +1,97 @@ +;;;; simplify-tree.scm --- utility functions for the PEG parser +;;;; +;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (gash peg simplify-tree) + #:export (keyword-flatten context-flatten string-collapse) + #:use-module (system base pmatch)) + +(define-syntax single? + (syntax-rules () + "Return #t if X is a list of one element." + ((_ x) + (pmatch x + ((_) #t) + (else #f))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; POST-PROCESSING FUNCTIONS (TO CANONICALIZE MATCH TREES) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Is everything in LST true? +(define (andlst lst) + (or (null? lst) + (and (car lst) (andlst (cdr lst))))) + +;; Is LST a list of strings? +(define (string-list? lst) + (and (list? lst) (not (null? lst)) + (andlst (map string? lst)))) + +;; Groups all strings that are next to each other in LST. Used in +;; STRING-COLLAPSE. +(define (string-group lst) + (if (not (list? lst)) + lst + (if (null? lst) + '() + (let ((next (string-group (cdr lst)))) + (if (not (string? (car lst))) + (cons (car lst) next) + (if (and (not (null? next)) + (list? (car next)) + (string? (caar next))) + (cons (cons (car lst) (car next)) (cdr next)) + (cons (list (car lst)) next))))))) + + +;; Collapses all the string in LST. +;; ("a" "b" (c d) "e" "f") -> ("ab" (c d) "ef") +(define (string-collapse lst) + (if (list? lst) + (let ((res (map (lambda (x) (if (string-list? x) + (apply string-append x) + x)) + (string-group (map string-collapse lst))))) + (if (single? res) (car res) res)) + lst)) + +;; If LST is an atom, return (list LST), else return LST. +(define (mklst lst) + (if (not (list? lst)) (list lst) lst)) + +;; Takes a list and "flattens" it, using the predicate TST to know when to stop +;; instead of terminating on atoms (see tutorial). +(define (context-flatten tst lst) + (if (or (not (list? lst)) (null? lst)) + lst + (if (tst lst) + (list lst) + (apply append + (map (lambda (x) (mklst (context-flatten tst x))) + lst))))) + +;; Takes a list and "flattens" it, using the list of keywords KEYWORD-LST to +;; know when to stop at (see tutorial). +(define (keyword-flatten keyword-lst lst) + (context-flatten + (lambda (x) + (if (or (not (list? x)) (null? x)) + #t + (member (car x) keyword-lst))) + lst)) diff --git a/gash/peg/string-peg.scm b/gash/peg/string-peg.scm new file mode 100644 index 0000000..8797bec --- /dev/null +++ b/gash/peg/string-peg.scm @@ -0,0 +1,280 @@ +;;;; string-peg.scm --- representing PEG grammars as strings +;;;; +;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (gash peg string-peg) + #:export (peg-as-peg + define-peg-string-patterns + peg-grammar) + #:use-module (gash peg using-parsers) + #:use-module (gash peg codegen) + #:use-module (gash peg simplify-tree)) + +;; Gets the left-hand depth of a list. +(define (depth lst) + (if (or (not (list? lst)) (null? lst)) + 0 + (+ 1 (depth (car lst))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; Parse string PEGs using sexp PEGs. +;; See the variable PEG-AS-PEG for an easier-to-read syntax. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Grammar for PEGs in PEG grammar. +(define peg-as-peg +"grammar <-- (nonterminal ('<--' / '<-' / '<') sp pattern)+ +pattern <-- alternative (SLASH sp alternative)* +alternative <-- ([!&]? sp suffix)+ +suffix <-- primary ([*+?] sp)* +primary <-- secondary ([#] sp)? +secondary <-- '(' sp pattern ')' sp / '.' sp / literal / charclass / nonterminal !'<' +literal <-- ['] (!['] .)* ['] sp +charclass <-- LB (!']' (CCrange / CCsingle))* RB sp +CCrange <-- . '-' . +CCsingle <-- . +nonterminal <-- [a-zA-Z0-9-]+ sp +sp < [ \t\n]* +SLASH < '/' +LB < '[' +RB < ']' +") + +(define-syntax define-sexp-parser + (lambda (x) + (syntax-case x () + ((_ sym accum pat) + (let* ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum))) + (accumsym (syntax->datum #'accum)) + (syn (wrap-parser-for-users x matchf accumsym #'sym))) + #`(define sym #,syn)))))) + +(define-sexp-parser peg-grammar all + (+ (and peg-nonterminal (or "<--" "<-" "<") peg-sp peg-pattern))) +(define-sexp-parser peg-pattern all + (and peg-alternative + (* (and (ignore "/") peg-sp peg-alternative)))) +(define-sexp-parser peg-alternative all + (+ (and (? (or "!" "&")) peg-sp peg-suffix))) +(define-sexp-parser peg-suffix all + (and peg-primary (* (and (or "*" "+" "?") peg-sp)))) +(define-sexp-parser peg-primary all + (and peg-secondary (? (and "#" peg-sp)))) +(define-sexp-parser peg-secondary all + (or (and "(" peg-sp peg-pattern ")" peg-sp) + (and "." peg-sp) + peg-literal + peg-charclass + (and peg-nonterminal (not-followed-by "<")))) +(define-sexp-parser peg-literal all + (and "'" (* (and (not-followed-by "'") peg-any)) "'" peg-sp)) +(define-sexp-parser peg-charclass all + (and (ignore "[") + (* (and (not-followed-by "]") + (or charclass-range charclass-single))) + (ignore "]") + peg-sp)) +(define-sexp-parser charclass-range all (and peg-any "-" peg-any)) +(define-sexp-parser charclass-single all peg-any) +(define-sexp-parser peg-nonterminal all + (and (+ (or (range #\a #\z) (range #\A #\Z) (range #\0 #\9) "-")) peg-sp)) +(define-sexp-parser peg-sp none + (* (or " " "\t" "\n"))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; PARSE STRING PEGS +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Takes a string representing a PEG grammar and returns syntax that +;; will define all of the nonterminals in the grammar with equivalent +;; PEG s-expressions. +(define (peg-parser str for-syntax) + (let ((parsed (match-pattern peg-grammar str))) + (if (not parsed) + (begin + ;; (display "Invalid PEG grammar!\n") + #f) + (let ((lst (peg:tree parsed))) + (cond + ((or (not (list? lst)) (null? lst)) + lst) + ((eq? (car lst) 'peg-grammar) + #`(begin + #,@(map (lambda (x) (peg-nonterm->defn x for-syntax)) + (context-flatten (lambda (lst) (<= (depth lst) 2)) + (cdr lst)))))))))) + +;; Macro wrapper for PEG-PARSER. Parses PEG grammars expressed as strings and +;; defines all the appropriate nonterminals. +(define-syntax define-peg-string-patterns + (lambda (x) + (syntax-case x () + ((_ str) + (peg-parser (syntax->datum #'str) x))))) + +;; lst has format (nonterm grabber pattern), where +;; nonterm is a symbol (the name of the nonterminal), +;; grabber is a string (either "<", "<-" or "<--"), and +;; pattern is the parse of a PEG pattern expressed as as string. +(define (peg-nonterm->defn lst for-syntax) + (let* ((nonterm (car lst)) + (grabber (cadr lst)) + (pattern (caddr lst)) + (nonterm-name (datum->syntax for-syntax + (string->symbol (cadr nonterm))))) + #`(define-peg-pattern #,nonterm-name + #,(cond + ((string=? grabber "<--") (datum->syntax for-syntax 'all)) + ((string=? grabber "<-") (datum->syntax for-syntax 'body)) + (else (datum->syntax for-syntax 'none))) + #,(compressor (peg-pattern->defn pattern for-syntax) for-syntax)))) + +;; lst has format ('peg-pattern ...). +;; After the context-flatten, (cdr lst) has format +;; (('peg-alternative ...) ...), where the outer list is a collection +;; of elements from a '/' alternative. +(define (peg-pattern->defn lst for-syntax) + #`(or #,@(map (lambda (x) (peg-alternative->defn x for-syntax)) + (context-flatten (lambda (x) (eq? (car x) 'peg-alternative)) + (cdr lst))))) + +;; lst has format ('peg-alternative ...). +;; After the context-flatten, (cdr lst) has the format +;; (item ...), where each item has format either ("!" ...), ("&" ...), +;; or ('peg-suffix ...). +(define (peg-alternative->defn lst for-syntax) + #`(and #,@(map (lambda (x) (peg-body->defn x for-syntax)) + (context-flatten (lambda (x) (or (string? (car x)) + (eq? (car x) 'peg-suffix))) + (cdr lst))))) + +;; lst has the format either +;; ("!" ('peg-suffix ...)), ("&" ('peg-suffix ...)), or +;; ('peg-suffix ...). +(define (peg-body->defn lst for-syntax) + (cond + ((equal? (car lst) "&") + #`(followed-by #,(peg-suffix->defn (cadr lst) for-syntax))) + ((equal? (car lst) "!") + #`(not-followed-by #,(peg-suffix->defn (cadr lst) for-syntax))) + ((eq? (car lst) 'peg-suffix) + (peg-suffix->defn lst for-syntax)) + (else `(peg-parse-body-fail ,lst)))) + +;; lst has format ('peg-suffix (? (/ "*" "?" "+"))) +(define (peg-suffix->defn lst for-syntax) + (let ((inner-defn (peg-primary->defn (cadr lst) for-syntax))) + (cond + ((null? (cddr lst)) + inner-defn) + ((equal? (caddr lst) "*") + #`(* #,inner-defn)) + ((equal? (caddr lst) "?") + #`(? #,inner-defn)) + ((equal? (caddr lst) "+") + #`(+ #,inner-defn))))) + +;; Parse a primary. +(define (peg-primary->defn lst for-syntax) + (let ((inner-defn (peg-secondary->defn (cadr lst) for-syntax))) + (if (and (pair? (cddr lst)) (equal? (caddr lst) "#")) #`(expect #,inner-defn) + inner-defn))) + +(define (peg-secondary->defn lst for-syntax) + (let ((el (cadr lst))) + (cond + ((list? el) + (cond + ((eq? (car el) 'peg-literal) + (peg-literal->defn el for-syntax)) + ((eq? (car el) 'peg-charclass) + (peg-charclass->defn el for-syntax)) + ((eq? (car el) 'peg-nonterminal) + (datum->syntax for-syntax (string->symbol (cadr el)))))) + ((string? el) + (cond + ((equal? el "(") + (peg-pattern->defn (caddr lst) for-syntax)) + ((equal? el ".") + (datum->syntax for-syntax 'peg-any)) + (else (datum->syntax for-syntax + `(peg-parse-any unknown-string ,lst))))) + (else (datum->syntax for-syntax + `(peg-parse-any unknown-el ,lst)))))) + +;; Trims characters off the front and end of STR. +;; (trim-1chars "'ab'") -> "ab" +(define (trim-1chars str) (substring str 1 (- (string-length str) 1))) + +;; Parses a literal. +(define (peg-literal->defn lst for-syntax) + (datum->syntax for-syntax (trim-1chars (cadr lst)))) + +;; Parses a charclass. +(define (peg-charclass->defn lst for-syntax) + #`(or + #,@(map + (lambda (cc) + (cond + ((eq? (car cc) 'charclass-range) + #`(range #,(datum->syntax + for-syntax + (string-ref (cadr cc) 0)) + #,(datum->syntax + for-syntax + (string-ref (cadr cc) 2)))) + ((eq? (car cc) 'charclass-single) + (datum->syntax for-syntax (cadr cc))))) + (context-flatten + (lambda (x) (or (eq? (car x) 'charclass-range) + (eq? (car x) 'charclass-single))) + (cdr lst))))) + +;; Compresses a list to save the optimizer work. +;; e.g. (or (and a)) -> a +(define (compressor-core lst) + (if (or (not (list? lst)) (null? lst)) + lst + (cond + ((and (or (eq? (car lst) 'or) (eq? (car lst) 'and)) + (null? (cddr lst))) + (compressor-core (cadr lst))) + ((and (eq? (car lst) 'body) + (eq? (cadr lst) 'lit) + (eq? (cadddr lst) 1)) + (compressor-core (caddr lst))) + (else (map compressor-core lst))))) + +(define (compressor syn for-syntax) + (datum->syntax for-syntax + (compressor-core (syntax->datum syn)))) + +;; Builds a lambda-expressions for the pattern STR using accum. +(define (peg-string-compile args accum) + (syntax-case args () + ((str-stx) (string? (syntax->datum #'str-stx)) + (let ((string (syntax->datum #'str-stx))) + (compile-peg-pattern + (compressor + (peg-pattern->defn + (peg:tree (match-pattern peg-pattern string)) #'str-stx) + #'str-stx) + (if (eq? accum 'all) 'body accum)))) + (else (error "Bad embedded PEG string" args)))) + +(add-peg-compiler! 'peg peg-string-compile) diff --git a/gash/peg/using-parsers.scm b/gash/peg/using-parsers.scm new file mode 100644 index 0000000..fb8d736 --- /dev/null +++ b/gash/peg/using-parsers.scm @@ -0,0 +1,116 @@ +;;;; using-parsers.scm --- utilities to make using parsers easier +;;;; +;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (gash peg using-parsers) + #:use-module (gash peg simplify-tree) + #:use-module (gash peg codegen) + #:use-module (gash peg cache) + #:export (match-pattern define-peg-pattern search-for-pattern + prec make-prec peg:start peg:end peg:string + peg:tree peg:substring peg-record?)) + +;;; +;;; Helper Macros +;;; + +(define-syntax until + (syntax-rules () + "Evaluate TEST. If it is true, return its value. Otherwise, +execute the STMTs and try again." + ((_ test stmt stmt* ...) + (let lp () + (or test + (begin stmt stmt* ... (lp))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; FOR DEFINING AND USING NONTERMINALS +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Parses STRING using NONTERM +(define (match-pattern nonterm string) + ;; We copy the string before using it because it might have been modified + ;; in-place since the last time it was parsed, which would invalidate the + ;; cache. Guile uses copy-on-write for strings, so this is fast. + (let ((res (nonterm (string-copy string) (string-length string) 0))) + (if (not res) + #f + (make-prec 0 (car res) string (string-collapse (cadr res)))))) + +;; Defines a new nonterminal symbol accumulating with ACCUM. +(define-syntax define-peg-pattern + (lambda (x) + (syntax-case x () + ((_ sym accum pat) + (let ((matchf (compile-peg-pattern #'pat (syntax->datum #'accum))) + (accumsym (syntax->datum #'accum))) + ;; CODE is the code to parse the string if the result isn't cached. + (let ((syn (wrap-parser-for-users x matchf accumsym #'sym))) + #`(define sym #,(cg-cached-parser syn)))))))) + +(define (peg-like->peg pat) + (syntax-case pat () + (str (string? (syntax->datum #'str)) #'(peg str)) + (else pat))) + +;; Searches through STRING for something that parses to PEG-MATCHER. Think +;; regexp search. +(define-syntax search-for-pattern + (lambda (x) + (syntax-case x () + ((_ pattern string-uncopied) + (let ((pmsym (syntax->datum #'pattern))) + (let ((matcher (compile-peg-pattern (peg-like->peg #'pattern) 'body))) + ;; We copy the string before using it because it might have been + ;; modified in-place since the last time it was parsed, which would + ;; invalidate the cache. Guile uses copy-on-write for strings, so + ;; this is fast. + #`(let ((string (string-copy string-uncopied)) + (strlen (string-length string-uncopied)) + (at 0)) + (let ((ret (until (or (>= at strlen) + (#,matcher string strlen at)) + (set! at (+ at 1))))) + (if (eq? ret #t) ;; (>= at strlen) succeeded + #f + (let ((end (car ret)) + (match (cadr ret))) + (make-prec + at end string + (string-collapse match)))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; PMATCH STRUCTURE MUNGING +;; Pretty self-explanatory. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define prec + (make-record-type "peg" '(start end string tree))) +(define make-prec + (record-constructor prec '(start end string tree))) +(define (peg:start pm) + (if pm ((record-accessor prec 'start) pm) #f)) +(define (peg:end pm) + (if pm ((record-accessor prec 'end) pm) #f)) +(define (peg:string pm) + (if pm ((record-accessor prec 'string) pm) #f)) +(define (peg:tree pm) + (if pm ((record-accessor prec 'tree) pm) #f)) +(define (peg:substring pm) + (if pm (substring (peg:string pm) (peg:start pm) (peg:end pm)) #f)) +(define peg-record? (record-predicate prec)) diff --git a/gash/pipe.scm b/gash/pipe.scm new file mode 100644 index 0000000..4b7b85c --- /dev/null +++ b/gash/pipe.scm @@ -0,0 +1,191 @@ +(define-module (gash pipe) + + #:use-module (ice-9 curried-definitions) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + + #:use-module (gash gash) + #:use-module (gash job) + #:use-module (gash io) + + #:export (handle-error pipeline+ pipeline->string substitute)) + +(define (handle-error job error) + (let ((status (wait job))) + (when (not (zero? status)) + (format (current-error-port) "ERROR: exit: ~a: ~s" status error) + (exit status)) + status)) + +(define (pipe*) + (let ((p (pipe))) + (values (car p) (cdr p)))) + +;; lhs rhs +;; [source] w[1] -> r[0] [filter] w[1] -> r[0] [sink] +;; w[2] -> r[3] [sink] + +(define (exec* command) ;; list of strings + (catch #t (lambda () (apply execlp (cons (car command) command))) + (lambda (key . args) (format (current-error-port) "~a\n" (caaddr args)) + (exit #f)))) + +(define ((tee-n file-names) inputs outputs) + (let* ((files (map open-output-file file-names)) + (tees (zip files inputs outputs))) + (let loop ((tees tees)) + (loop (filter-map (lambda (tee) + (let ((file (first tee)) + (input (second tee)) + (output (third tee))) + (when (char-ready? input) + (let ((char (read-char input))) + (if (not (eof-object? char)) + (begin (display char file) + (display char output) + (list file input output)) + #f))))) + tees))) + (map close outputs))) + +(define* (spawn fg? job command #:optional (input '())) + (let* ((ofd '(1 2)) ;; output file descriptors 1 & 2 + (ifd (cond + ((null? input) '()) + (#t '(0)))) ;;support no input or 1 input, TODO multiple inputs + (pipes (map (lambda (. _) (pipe)) ofd)) + (r (map car pipes)) + (w (map cdr pipes)) + (pid (primitive-fork))) + (cond ((= 0 pid) + (job-setup-process fg? job) + (map close r) + (if (procedure? command) + (begin + (when (pair? input) + (close-port (current-input-port)) + (set-current-input-port (car input))) + (when (pair? w) + (close-port (current-output-port)) + (set-current-output-port (car w)) + (set-current-error-port (cadr w))) + (let ((status (if (thunk? command) (command) + (command input w)))) + (exit (cond ((number? status) status) + ((boolean? status) (if status 0 1)) + (else 0))))) + (begin + (map dup->fdes w ofd) + (map dup->fdes input ifd) + (exec* command)))) + (#t + (job-add-process fg? job pid command) + (map close w) + r)))) + +(define (pipeline+ fg? . commands) + (when (> %debug-level 0) + (format (current-error-port) "pipeline+[~a]: COMMANDS: ~s\n" fg? commands)) + (receive (r w) + (pipe*) + (move->fdes w 2) + (let* ((error-port (set-current-error-port w)) + (job (new-job)) + (debug-id (job-debug-id job)) + (commands + (if (< %debug-level 3) commands + (fold-right (lambda (command id lst) + (let ((file (string-append debug-id "." id))) + (cons* command `("tee" ,file) lst))) + '() commands (map number->string (iota (length commands)))))) + (foo (when (> %debug-level 1) (with-output-to-file debug-id (cut format #t "COMMANDS: ~s\n" commands)))) + (ports (if (> (length commands) 1) + (let loop ((input (spawn fg? job (car commands) '())) ;; spawn-source + (commands (cdr commands))) + (if (null? (cdr commands)) + (spawn fg? job (car commands) input) ;; spawn-sink + (loop (spawn fg? job (car commands) input) ;; spawn-filter + (cdr commands)))) + (spawn fg? job (car commands) '())))) ;; spawn-sink + (when fg? + (let loop ((input ports) + (output (list (current-output-port) error-port))) + (let ((line (map (cut read-line <> 'concat) input))) + (let* ((input-available? (lambda (o ln) (and (not (eof-object? ln)) o))) + (line (filter-map input-available? line line)) + (output (filter-map input-available? output line)) + (input (filter-map input-available? input line))) + (when (pair? input) + (map display line output) + (map (cut force-output <>) output) + (loop input output))))) + (wait job)) + (move->fdes error-port 2) + (set-current-error-port error-port) + (close w) + (values job (append ports (list r)))))) + +(define (pipeline->string . commands) + (receive (job ports) + (apply pipeline+ #f commands) + (let ((output (read-string (car ports)))) + (wait job) + output))) + +;;(pipeline+ #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") (lambda () (display (read-string)))) +;;(pipeline+ #f '("head" "-c128" "/dev/urandom") '("tr" "-dc" "A-Z0-9") '("cat")) +;;(pipeline+ #f (lambda () (display 'foo)) '("grep" "o") '("tr" "o" "e")) + +;; (pipeline+ #f +;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar")) +;; '("tr" "u" "a") +;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) +;; '("cat") +;; (lambda () (display (read-string)))) + +;; (receive (job ports) +;; (pipeline+ #f +;; (lambda () +;; (display "foo") +;; (display "bar" (current-error-port))) +;; '("tr" "o" "e")) +;; (map (compose display read-string) ports)) + +;; _ +;; \ +;; - +;; _/ + +;; (display (pipeline->string +;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar")) +;; '("tr" "u" "a") +;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) +;; '("cat") +;; (lambda () (display (read-string)) (newline)))) + +;; _ +;; \ +;; - +;; _/ + +;; (display (pipeline->string +;; (lambda () (display "\nbin\nboot\nroot\nusr\nvar")) +;; '("tr" "u" "a") +;; (lambda () (display (string-map (lambda (c) (if (eq? c #\o) #\e c)) (read-string)))) +;; '("cat") +;; (lambda () (display (read-string)) (newline)))) + +(define (substitute . commands) + (string-trim-right + (string-map (lambda (c) + (if (eq? #\newline c) #\space c)) + (apply pipeline->string commands)) + #\space)) + +;; (display (pipeline->string '("ls") '("cat"))) (newline) +;; (display (substitute '("ls") '("cat"))) (newline) diff --git a/gash/readline.scm b/gash/readline.scm new file mode 100644 index 0000000..df6aecc --- /dev/null +++ b/gash/readline.scm @@ -0,0 +1,41 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; This is a fallback module for the bootstrap guile where (ice-9 +;;; readline) is not available. + +;;; Code: + +(define-module (gash readline) + #:use-module (ice-9 rdelim) + #:export (add-history + clear-history + read-history + readline + with-readline-completion-function + write-history)) + +(define (add-history x) #t) +(define (clear-history) #t) +(define (read-history x) #t) +(define (readline prompt) (display prompt) (read-line)) +(define (with-readline-completion-function completion thunk) (thunk)) +(define (write-history x) #t) + diff --git a/gash/script.scm b/gash/script.scm new file mode 100644 index 0000000..6bc44ad --- /dev/null +++ b/gash/script.scm @@ -0,0 +1,440 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash script) + #:use-module (ice-9 ftw) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 local-eval) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + + #: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) + #:use-module (gash gash) + #:use-module (gash io) + #:use-module (gash job) + #:use-module (gash pipe) + #:use-module (gash util) + + #:export ( + and-terms + background + brace-group + builtin + command + delim + doublequotes + file-name + for-clause + do-group + expression + glob + ignore-error + literal + or-terms + pipeline + run + script-status + sequence + singlequotes + source + splice + split + substitution + word + xtrace + )) + +(define (background term) + (format (current-error-port) "background: ~s\n" term) + (match (pke 'background-term term) + (('pipeline command) (pke 'background: `(pipeline+ #f ,command))) + (_ term))) + +(define (source file-name) + (let* ((string (with-input-from-file file-name read-string)) + (ast (parse-string string))) + (run ast))) + +(define (command . args) + (define (flatten o) + (match o + ((h t ...) (append (flatten h) (append-map flatten t))) + (_ (list o)))) + (define (exec command) + (cond ((procedure? command) command) + ((assoc-ref %functions (car command)) + => + (lambda (function) + (parameterize ((%command-line args)) + (last (apply function args))))) + ((every string? command) + (let* ((program (car command)) + (escape-builtin? (and (string? program) (string-prefix? "\\" program))) + (program (if escape-builtin? (string-drop program 1) program)) + (command (cons program (cdr command)))) + (or (builtin command #:prefer-builtin? (or %prefer-builtins? + escape-builtin?)) + (lambda _ (status:exit-val (apply system* command)))))) + (else (lambda () #t)))) + (when (> %debug-level 1) + (format (current-error-port) "command: ~s\n" args)) + (let ((args (flatten args))) + (match args + (((or "." "source") file-name) + (let* ((string (with-input-from-file file-name read-string)) + (ast (parse-string string))) + (run ast) + 0)) + (((? string?) ..1) (exec (append-map glob args))) + (_ (exec (append-map glob args)))))) + +(define (glob? pattern) + (and (string? pattern) (string-match "\\?|\\*" pattern))) + +(define* (glob->regex pattern #:key (begin "^") (end "$")) + (let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post)) + (pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post)) + (pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post))) + (make-regexp (string-append begin pattern end)))) + +(define (glob pattern) + (define (glob-match regex path) ;; pattern path -> bool + (regexp-match? (regexp-exec regex path))) + (define (glob- pattern file-names) + (map (lambda (file-name) + (if (string-prefix? "./" file-name) (string-drop file-name 2) file-name)) + (append-map (lambda (file-name) + (map (cut string-append (if (string=? "/" file-name) "" file-name) "/" <>) + (filter (conjoin (negate (cut string-prefix? "." <>)) + (cute glob-match (glob->regex pattern) <>)) + (or (scandir file-name) '())))) + file-names))) + (cond + ((not pattern) '("")) + ((glob? pattern) (let ((absolute? (string-prefix? "/" pattern))) + (let loop ((patterns (filter (negate string-null?) (string-split pattern #\/))) + (file-names (if absolute? '("/") '(".")))) + (if (null? patterns) + file-names + (begin + (loop (cdr patterns) (glob- (car patterns) file-names))))))) + (#t (list pattern)))) + +(define (singlequotes . o) + (string-join o "")) + +(define (doublequotes . o) + (string-join (append-map glob o) "")) + +(define (sequence . args) + (let ((glob (append-map glob (apply append args)))) + glob)) + +(define (run script) + ;; fixme: work towards simple eval -- must remove begin for now + (match script + (('begin script ...) + (last (map (cut local-eval <> (the-environment)) script))) + (_ (local-eval script (the-environment))))) + +(define (script-status) + ((compose string->number variable) "?")) + +(define (for-clause name sequence body) + (for-each (lambda (value) + (assignment name value) + (body)) + sequence)) + +(define (split o) + ((compose string-tokenize string-trim-right) o)) + +(define (xtrace o) + (o)) + +(define (literal o) + o) + +(define (word . o) + (define (flatten o) + (match o + ((h t ...) (append (flatten h) (append-map flatten t))) + (_ (list o)))) + (match o + (((? string?) ...) (string-join (flatten o) "")) + ((((? string?) ...)) (flatten (car o))) + (_ o))) + +(define-syntax-rule (substitution commands) + (string-trim-right (with-output-to-string (lambda _ commands)))) + +(define-syntax-rule (ignore-error o) + (let ((errexit (shell-opt? "errexit"))) + (when errexit + (set-shell-opt! "errexit" #f)) + (let ((r o)) + (assignment "?" "0") + (when errexit + (set-shell-opt! " errexit" #t)) + r))) + +(define-syntax true? + (lambda (x) + (syntax-case x () + ((_ pipeline) + (with-syntax ((it (datum->syntax x 'it))) + #'(let ((it (ignore-error pipeline))) + (status->bool it))))))) + +(define (status->bool o) + (match o + (#t #t) + ((? number?) (zero? o)) + (_ #f))) + +(define-syntax expression + (lambda (x) + (syntax-case x () + ((_ (command word ...)) + #'(list word ...))))) + +(define-syntax do-group + (lambda (x) + (syntax-case x () + ((_ term ...) + #'(lambda _ term ...))))) + +(define-syntax and-terms + (lambda (x) + (syntax-case x () + ((_ left right) + (with-syntax ((it (datum->syntax x 'it))) + #'(let ((it left)) + (if (zero? it) right it))))))) + +(define-syntax or-terms + (lambda (x) + (syntax-case x () + ((_ left right) + (with-syntax ((it (datum->syntax x 'it))) + #'(let ((it (ignore-error left))) + (if (zero? it) it right))))))) + +(define (pipeline . commands) + (define (handle job) + (when (> %debug-level 1) + (format (current-error-port) "job=~s\n" job)) + (let* ((stati (cond ((job? job) (map status:exit-val (job-status job))) + ((boolean? job) (list (if job 0 1))) + ((number? job) (list job)) + (else (list 0)))) + (foo (when (> %debug-level 1) + (format (current-error-port) "stati=~s\n" stati))) + (status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0) + (car stati))) + (pipestatus (string-append + "(" + (string-join + (map (lambda (s i) + (format #f "[~a]=\"~a\"" s i)) + stati + (iota (length stati)))) + ")"))) + (assignment "PIPESTATUS" pipestatus) + (assignment "?" (number->string status)) + (when (and (not (zero? status)) + (shell-opt? "errexit")) + (when (> %debug-level 0) + (format (current-error-port) "set -e: exiting\n")) + (exit status)) + (status->bool status))) + (let ((commands (filter (lambda (x) (not (eq? x *unspecified*))) commands))) + (when (> %debug-level 1) + (format (current-error-port) "pijp: commands=~s\n" commands)) + ;; FIXME: after running a builtin, we still end up here with the builtin's result + ;; that should probably not happen, however, cater for it here for now + (match commands + (((and (? boolean?) boolean)) + (handle boolean)) + (((and (? number?) number)) + (handle number)) + (((? unspecified?)) + (handle #t)) + (((? unspecified?) t ... #t) + #t) + (_ (handle (apply pipeline+ #t commands)))))) + +(define* (builtin ast #:key prefer-builtin?) + ;; FIXME: distinguish between POSIX compliant builtins and + ;; `best-effort'/`fallback'? + "Possibly modify command to use a builtin." + (when (> %debug-level 0) + (format (current-error-port) "builtin ast=~s\n" ast)) + (receive (command args) + (match ast + (((and (? string?) command) args ...) (values command args)) + (_ (values #f #f))) + (let ((program (and command + (cond ((string-prefix? "/" command) + (when (not (file-exists? command)) + (format (current-error-port) "gash: ~a: no such file or directory\n" command)) + command) + (else (PATH-search-path command)))))) + ;; FIXME: find some generic strerror/errno way: what about permissions and stuff? + ;; after calling system* we're too late for that? + (when (> %debug-level 0) + (format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args)) + (cond ((and program (not prefer-builtin?)) + (when (not program) + (format (current-error-port) "gash: ~a: command not found\n" command)) + (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))) + => + (lambda (command) + (if args + (apply command (map (cut local-eval <> (the-environment)) args)) + (command)))) + (else #f))))) + +(define (brace-group . o) + o) + +(define (file-name o) + o) + +(define (regexp-exec-non-greedy regexp string) + (let ((max (string-length string))) + (let loop ((size 1)) + (and (<= size max) + (or (regexp-exec regexp (substring string 0 size)) + (loop (1+ size))))))) + +(define (regexp-exec-non-greedy-reverse regexp string) + (let ((max (string-length string))) + (let loop ((start (1- max))) + (and (>= start 0) + (or (regexp-exec regexp (substring string start)) + (loop (1- start))))))) + +(define (variable-regex name sep pattern) + (match sep + ("##" (variable-hash-hash name pattern)) + ("#" (variable-hash name pattern)) + ("%%" (variable-percent-percent name pattern)) + ("%" (variable-percent name pattern)) + ("/" (variable-replace name pattern)))) + +(define (variable-replace name pattern) + (let* ((value (variable name)) + (at (string-index pattern #\/)) + (regex (if at (substring pattern 0 at) pattern)) + (subst (if at (substring pattern (1+ at)) ""))) + (regexp-substitute/global #f regex value 'pre subst 'post))) + +(define (variable-hash name pattern) + (let ((value (variable name)) + (glob? (glob? pattern))) + (if glob? (let* ((regexp (glob->regex pattern #:end "")) + (match (regexp-exec-non-greedy regexp value))) + (if match (string-drop value (match:end match)) + value)) + (if (string-prefix? pattern value) (string-drop value (string-length pattern)) + value)))) + +(define (variable-hash-hash name pattern) + (let ((value (variable name)) + (glob? (glob? pattern))) + (if glob? (let* ((regexp (glob->regex pattern #:end "")) + (match (regexp-exec regexp value))) + (if match (string-drop value (match:end match)) + value)) + (if (string-prefix? pattern value) (string-drop value (string-length pattern)) + value)))) + +(define (variable-percent name pattern) + (let ((value (variable name)) + (glob? (glob? pattern))) + (if glob? (let* ((regexp (glob->regex pattern #:begin "")) + (match (regexp-exec-non-greedy-reverse regexp value))) + (if match (substring value 0 (- (string-length value) (match:end match))) + value)) + (if (string-suffix? pattern value) (substring value 0 (string-length pattern)) + value)))) + +(define (variable-percent-percent name pattern) + (let ((value (variable name)) + (glob? (glob? pattern))) + (if glob? (let* ((regexp (glob->regex pattern #:begin "")) + (match (regexp-exec regexp value))) + (if match (substring value 0 (match:start match)) + value)) + (if (string-suffix? pattern value) (substring value 0 (string-length pattern)) + value)))) + +(define (number o) + o) + +(define (pat o) + o) + +(define (str o) + o) + +(define* (variable-slash name pattern #:optional (replace "")) + (let ((value (variable name)) + (glob? (glob? pattern))) + (let ((match (if glob? (let ((regexp (glob->regex pattern #:begin "" #:end ""))) + (regexp-exec regexp value)) + (string-match pattern value)))) + (if match (string-append + (substring value 0 (match:start match)) + replace + (substring value (match:end match))) + value)))) + +(define (compound . o) + (match o + ((h ... t) t) + (_ o))) + +(define (delim o . rest) + (match rest + (() o) + (((? string?) ...) (string-append o (string-join rest ""))) + ((((? string?) ...)) (string-append o (string-join (car rest) ""))))) + +(define (name o) + o) + +(define (regex-sep o) + o) + +(define (shift . o) + (apply (shift-command) o)) diff --git a/gash/shell-utils.scm b/gash/shell-utils.scm new file mode 100644 index 0000000..4c27624 --- /dev/null +++ b/gash/shell-utils.scm @@ -0,0 +1,541 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2015, 2018 Mark H Weaver +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial guix-build-utils.scm was taken from Guix. + +;;; Code: + +(define-module (gash shell-utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 rdelim) + + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (gash util) + #:export ( + delete-file-recursively + display-tabulated + display-file + dump-port + executable-path + file-name-predicate + find-files + file-exists?* + + + make-chmodifier + chmodifier-users + chmodifier-operation + chmodifier-permissions + make-numeric-chmodifier + chmodifier->mode + chmodifiers->mode + apply-chmodifiers + parse-chmodifiers + + + grep* + grep+ + grep-match-file-name + grep-match-string + grep-match-line + grep-match-column + grep-match-end-column + mkdir-p + rmdir-p + multi-opt + + directory-exists? + executable-file? + regular-file? + symbolic-link? + substitute* + substitute-port + with-atomic-file-replacement + let-matches + )) + +;;; Commentary: + +;;; This code is taken from (guix build utils) + + +;;; +;;; Directories. +;;; + +(define (directory-exists? dir) + "Return #t if DIR exists and is a directory." + (let ((s (stat dir #f))) + (and s + (eq? 'directory (stat:type s))))) + +(define (executable-file? file) + "Return #t if FILE exists and is executable." + (let ((s (stat file #f))) + (and s + (not (zero? (logand (stat:mode s) #o100)))))) + +(define (regular-file? file) + "Return #t if FILE is a regular file." + (let ((s (stat file #f))) + (and s + (eq? (stat:type s) 'regular)))) + +(define (symbolic-link? file) + "Return #t if FILE is a symbolic link (aka. \"symlink\".)" + (let ((s (lstat file))) + (and s + (eq? (stat:type s) 'symlink)))) + +(define (file-name-predicate regexp) + "Return a predicate that returns true when passed a file name whose base +name matches REGEXP." + (let ((file-rx (if (regexp? regexp) + regexp + (make-regexp regexp)))) + (lambda (file stat) + (regexp-exec file-rx (basename file))))) + +(define* (find-files dir #:optional (pred (const #t)) + #:key (stat lstat) + directories? + fail-on-error?) + "Return the lexicographically sorted list of files under DIR for which PRED +returns true. PRED is passed two arguments: the absolute file name, and its +stat buffer; the default predicate always returns true. PRED can also be a +regular expression, in which case it is equivalent to (file-name-predicate +PRED). STAT is used to obtain file information; using 'lstat' means that +symlinks are not followed. If DIRECTORIES? is true, then directories will +also be included. If FAIL-ON-ERROR? is true, raise an exception upon error." + (let ((pred (if (procedure? pred) + pred + (file-name-predicate pred)))) + ;; Sort the result to get deterministic results. + (sort (file-system-fold (const #t) + (lambda (file stat result) ; leaf + (if (pred file stat) + (cons file result) + result)) + (lambda (dir stat result) ; down + (if (and directories? + (pred dir stat)) + (cons dir result) + result)) + (lambda (dir stat result) ; up + result) + (lambda (file stat result) ; skip + result) + (lambda (file stat errno result) + (format (current-error-port) "find-files: ~a: ~a~%" + file (strerror errno)) + (when fail-on-error? + (error "find-files failed")) + result) + '() + dir + stat) + string + (make-grep-match file-name string line column end-column) + grep-match? + (file-name grep-match-file-name) + (string grep-match-string) + (line grep-match-line) + (column grep-match-column) + (end-column grep-match-end-column)) + +(define* (grep* pattern #:key (port (current-input-port)) (file-name "")) + ;; FIXME: collect later? for scripting usage implicit collect is + ;; nice; for pipeline usage not so much + (let loop ((line (read-line port)) (ln 1) (matches '())) + (if (eof-object? line) (reverse matches) + (let* ((m (list-matches pattern line)) + (m (and (pair? m) (car m)))) + (loop (read-line port) (1+ ln) + (if m (cons (make-grep-match file-name + (match:string m) + ln + (match:start m) + (match:end m)) matches) + matches)))))) + +(define (grep+ pattern file) + (cond ((and (string? file) + (not (equal? file "-"))) (call-with-input-file file + (lambda (in) + (grep* pattern #:port in #:file-name file)))) + (else (grep* pattern)))) + +(define (mkdir-p dir) + "Create directory DIR and all its ancestors." + (define absolute? + (string-prefix? "/" dir)) + + (define not-slash + (char-set-complement (char-set #\/))) + + (let loop ((components (string-tokenize dir not-slash)) + (root (if absolute? + "" + "."))) + (match components + ((head tail ...) + (let ((path (string-append root "/" head))) + (catch 'system-error + (lambda () + (mkdir path) + (loop tail path)) + (lambda args + (if (= EEXIST (system-error-errno args)) + (loop tail path) + (apply throw args)))))) + (() #t)))) + +(define (rmdir-p dir) + "Remove directory DIR and all its ancestors." + (rmdir dir) + (let loop ((dir (dirname dir))) + (when (not (equal? dir ".")) + (rmdir dir) + (loop (dirname dir))))) + +(define (file-exists?* file) + "Like 'file-exists?' but emits a warning if FILE is not accessible." + (catch 'system-error + (lambda () + (stat file)) + (lambda args + (let ((errno (system-error-errno args))) + (format (current-error-port) "~a: ~a~%" + file (strerror errno)) + #f)))) + +(define* (display-tabulated lst + #:key + (terminal-width 80) + (column-gap 2)) + "Display the list of string LST in as many columns as needed given +TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns." + (define len (length lst)) + (define column-width + ;; The width of a column. Assume all the columns have the same width + ;; (GNU ls is smarter than that.) + (+ column-gap (reduce max 0 (map string-length lst)))) + (define columns + (max 1 + (quotient terminal-width column-width))) + (define pad + (if (zero? (modulo len columns)) + 0 + columns)) + (define items-per-column + (quotient (+ len pad) columns)) + (define items (list->vector lst)) + + (let loop ((indexes (unfold (cut >= <> columns) + (cut * <> items-per-column) + 1+ + 0))) + (unless (>= (first indexes) items-per-column) + (for-each (lambda (index) + (let ((item (if (< index len) + (vector-ref items index) + ""))) + (display (string-pad-right item column-width)))) + indexes) + (newline) + (loop (map 1+ indexes))))) + +(define* (display-file file-name #:optional st) + (define (display-rwx perm sticky) + (display (if (zero? (logand perm 4)) "-" "r")) + (display (if (zero? (logand perm 2)) "-" "w")) + (display (let ((x (logand perm 1))) + (if (zero? sticky) (if (zero? x) "-" "x") + (if (= sticky 1) (if (zero? x) "T" "t") + (if (zero? x) "S" "s")))))) + (define (display-bcdfsl type) + (display + (case type + ((block-special) "b") + ((char-special) "c") + ((directory) "d") + ((fifo) "p") + ((regular) "-") + ((socket) "s") + ((symlink) "l") + (else "?")))) + (let* ((st (or st (lstat file-name))) + (mode (stat:mode st)) + (uid (stat:uid st)) + (gid (stat:gid st)) + (size (stat:size st)) + (date (strftime "%c" (localtime (stat:mtime st)))) + (sticky (ash mode -9))) + (display-bcdfsl (stat:type st)) + (display-rwx (ash mode -6) (logand sticky 4)) + (display-rwx (ash (logand mode #o70) -3) (logand sticky 2)) + (display-rwx (logand mode #o7) (logand sticky 1)) + (display " ") + (let ((ent (catch #t (compose passwd:name (cut getpwuid uid)) (const uid)))) + (format #t "~8a" ent)) + (display " ") + (let ((ent (catch #t (compose group:name (cut getgrgid gid)) (const gid)))) + (format #t "~8a" ent)) + (format #t "~8d" size) + (display " ") + (display date) + (display " ") + (display file-name) + (when (eq? (stat:type st) 'symlink) + (display " -> ") + (display (readlink file-name))))) + +(define (multi-opt options name) + (let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o))))) + (filter-map opt? (reverse options)))) + +(define %not-colon (char-set-complement (char-set #\:))) +(define (executable-path) + "Return the search path for programs as a list." + (match (getenv "PATH") + (#f '()) + (str (string-tokenize str %not-colon)))) + + +;;; +;;; Text substitution (aka. sed). +;;; + +(define (with-atomic-file-replacement file proc) + "Call PROC with two arguments: an input port for FILE, and an output +port for the file that is going to replace FILE. Upon success, FILE is +atomically replaced by what has been written to the output port, and +PROC's result is returned." + (let* ((template (string-append file ".XXXXXX")) + (out (mkstemp! template)) + (mode (stat:mode (stat file)))) + (with-throw-handler #t + (lambda () + (call-with-input-file file + (lambda (in) + (let ((result (proc in out))) + (close out) + (chmod template mode) + (rename-file template file) + result)))) + (lambda (key . args) + (false-if-exception (delete-file template)))))) + +(define (substitute* file pattern+procs) + "PATTERN+PROCS is a list of regexp/two-argument-procedure pairs. For each +line of FILE, and for each PATTERN that it matches, call the corresponding +PROC as (PROC LINE MATCHES); PROC must return the line that will be written as +a substitution of the original line. Be careful about using '$' to match the +end of a line; by itself it won't match the terminating newline of a line." + (let ((rx+proc (map (match-lambda + ;; (((? regexp? pattern) . proc) + ;; (cons pattern proc)) + (((pattern . flags) . proc) + (cons (apply make-regexp pattern flags) + proc))) + pattern+procs))) + (with-atomic-file-replacement file + (lambda (in out) + (let loop ((line (read-line in 'concat))) + (if (eof-object? line) + #t + (let ((line (fold (lambda (r+p line) + (match r+p + ((regexp . proc) + (match (list-matches regexp line) + ((and m+ (_ _ ...)) + (proc line m+)) + (_ line))))) + line + rx+proc))) + (display line out) + (loop (read-line in 'concat))))))))) + +(define (substitute-port pattern+procs) + (let ((rx+proc (map (match-lambda + ;; (((? regexp? pattern) . proc) + ;; (cons pattern proc)) + (((pattern . flags) . proc) + (cons (apply make-regexp pattern flags) + proc))) + pattern+procs)) + (in (current-input-port)) + (out (current-output-port))) + (let loop ((line (read-line in 'concat))) + (if (eof-object? line) + #t + (let ((line (fold (lambda (r+p line) + (match r+p + ((regexp . proc) + (match (list-matches regexp line) + ((and m+ (_ _ ...)) + (proc line m+)) + (_ line))))) + line + rx+proc))) + (display line out) + (loop (read-line in 'concat))))))) + + +;;; +;;; Permissions. +;;; +(define-immutable-record-type + (make-chmodifier users operation permissions) + chmodifier? + (users chmodifier-users) + (operation chmodifier-operation) + (permissions chmodifier-permissions)) + +(define (parse-chmodifier o) + (let* ((c (string->symbol (substring o 0 1))) + (o (if (memq c '(- + =)) (string-append "a" o) o)) + (users (string->symbol (substring o 0 1))) + (program (car (command-line)))) + (when (not (memq users '(u g o a))) + (error (format #f "~a: no such user: ~a" program users))) + (let ((operation (string->symbol (substring o 1 2)))) + (when (not (memq operation '(- + =))) + (error (format #f "~a: no such operation: ~a" program operation))) + (let* ((perm-string (substring o 2)) + (perm (string->number perm-string 8))) + (if perm (make-numeric-chmodifier perm) + (let ((perms (map string->symbol (string->string-list perm-string)))) + (make-chmodifier users operation perms))))))) + +(define (parse-chmodifiers o) + (or (and=> (string->number o 8) (compose list (cut make-numeric-chmodifier <>))) + (map parse-chmodifier (string-split o #\,)))) + +(define (make-numeric-chmodifier o) + (make-chmodifier 'o '= (list o))) + +(define* (chmodifiers->mode modifiers #:optional (mode 0)) + (let loop ((modifiers modifiers) (mode mode)) + (if (null? modifiers) mode + (loop (cdr modifiers) + (chmodifier->mode (car modifiers) mode))))) + +(define* (chmodifier->mode modifier #:optional (mode 0)) + (let* ((executable? (if (zero? (logand mode #o111)) 0 1)) + (n (chmodifier-numeric-mode modifier executable?)) + (o (chmodifier-operation modifier)) + (program (car (command-line)))) + (case o + ((=) n) + ((+) (logior mode n)) + ((-) (logand mode (logxor n -1))) + (else (error + (format #f + "~a: operation not supported: ~s\n" + program o)))))) + +(define (apply-chmodifiers file modifiers) + (let ((mode (chmodifiers->mode modifiers (stat:mode (lstat file))))) + ((@ (guile) chmod) file mode))) + +(define (chmodifier-numeric-mode o executable?) + (let* ((permissions (chmodifier-permissions o)) + (users (chmodifier-users o))) + (let loop ((permissions permissions)) + (if (null? permissions) 0 + (+ (let* ((p (car permissions)) + (base (cond ((number? p) p) + ((symbol? p) + (case p + ((r) 4) + ((w) 2) + ((x) 1) + ((X) executable?)))))) + (case users + ((a) (+ base (ash base 3) (ash base 6))) + ((o) base) + ((g) (ash base 3)) + ((u) (ash base 6)))) + (loop (cdr permissions))))))) diff --git a/gash/ustar.scm b/gash/ustar.scm new file mode 100644 index 0000000..a590a9d --- /dev/null +++ b/gash/ustar.scm @@ -0,0 +1,570 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2013 Mark H Weaver +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial 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 + (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: diff --git a/gash/util.scm b/gash/util.scm new file mode 100644 index 0000000..908725e --- /dev/null +++ b/gash/util.scm @@ -0,0 +1,52 @@ +;;; Gash --- Guile As SHell +;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +(define-module (gash util) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + + #:export ( + conjoin + disjoin + wrap-command + char->string + string->string-list + string-replace-string + )) + +(define (disjoin . predicates) + (lambda (. arguments) + (any (cut apply <> arguments) predicates))) + +(define (conjoin . predicates) + (lambda (. arguments) + (every (cut apply <> arguments) predicates))) + +(define (string->string-list string) + (map char->string (string->list string))) + +(define (char->string c) + (make-string 1 c)) + +(define (string-replace-string string from to) + (cond ((string-contains string from) + => + (lambda (i) + (string-replace string to i (+ i (string-length from))))) + (else string))) diff --git a/makefile b/makefile new file mode 100644 index 0000000..6b866c2 --- /dev/null +++ b/makefile @@ -0,0 +1,94 @@ +.PHONY: all all-go check clean install +-include .config.make + +default: all + +.config.make: makefile + +bin/gash: bin/gash.in + $(MAKE) do-configure + +gash/config.scm: + $(MAKE) do-configure + +do-configure: + ./configure --prefix=$(prefix) + +all: all-go + +all-go: | gash/config.scm + build-aux/build-guile.sh + +clean: + git clean -fdx + +clean-go: + rm -f $(shell find . -name '*.go') + +check: all check-bash check-gash + +check-bash: all +ifneq ($(BASH),) + PATH=$(PATH):bin SHELL=$(BASH) ./check.sh +endif + +check-gash: all + SHELL=bin/gash ./check.sh + +check-parse: all + SHELL='bin/gash -p' PARSE=1 ./check.sh + +check-geesh: all + SHELL='bin/gash --geesh' ./check.sh + +install: all + mkdir -p $(DESTDIR)$(bindir) + cp bin/gash $(DESTDIR)$(bindir)/gash + mkdir -p $(DESTDIR)$(guile_site_dir) + tar -cf- gash/*.scm | tar -C $(DESTDIR)$(guile_site_dir) -xf- + mkdir -p $(DESTDIR)$(guile_site_ccache_dir) + cp bin/gash.go $(DESTDIR)$(guile_site_ccache_dir) + tar -cf- gash/*.go | tar -C $(DESTDIR)$(guile_site_ccache_dir) -xf- + mkdir -p $(DESTDIR)$(docdir) + cp -f COPYING README TODO $(docdir) + $(MAKE) install-info + +install-info: info + mkdir -p $(DESTDIR)$(prefix)/share/info + tar -cf- doc/gash.info* | tar -xf- --strip-components=1 -C $(DESTDIR)$(prefix)/share/info + install-info --info-dir=$(DESTDIR)$(prefix)/share/info doc/gash.info + +doc/version.texi: doc/gash.texi makefile + (set `LANG= date -r $< +'%d %B %Y'`;\ + echo "@set UPDATED $$1 $$2 $$3"; \ + echo "@set UPDATED-MONTH $$2 $$3"; \ + echo "@set EDITION $(VERSION)"; \ + echo "@set VERSION $(VERSION)") > $@ + +info: doc/gash.info + +doc/gash.info: doc/gash.texi doc/version.texi makefile + $(MAKEINFO) -o $@ -I doc $< + +define HELP_TOP +Usage: make [OPTION]... [TARGET]... + +Targets: + all update everything + all-go update .go files + check run ./test.sh + clean run git clean -dfx + clean-go clean .go files + install install in $(PREFIX) +endef +export HELP_TOP +help: + @echo "$$HELP_TOP" + +export BUILD_DEBUG +export GUILE +export GUILE_TOOLS +export guile_load_path +export guile_load_compiled_path + + diff --git a/sh.bnf b/sh.bnf new file mode 100644 index 0000000..b69a5e1 --- /dev/null +++ b/sh.bnf @@ -0,0 +1,205 @@ +/* ------------------------------------------------------- + The grammar symbols + ------------------------------------------------------- */ +%token WORD +%token ASSIGNMENT_WORD +%token NAME +%token NEWLINE +%token IO_NUMBER + + +/* The following are the operators mentioned above. */ + + +%token AND_IF OR_IF DSEMI +/* '&&' '||' ';;' */ + + +%token DLESS DGREAT LESSAND GREATAND LESSGREAT DLESSDASH +/* '<<' '>>' '<&' '>&' '<>' '<<-' */ + + +%token CLOBBER +/* '>|' */ + + +/* The following are the reserved words. */ + + +%token If Then Else Elif Fi Do Done +/* 'if' 'then' 'else' 'elif' 'fi' 'do' 'done' */ + + +%token Case Esac While Until For +/* 'case' 'esac' 'while' 'until' 'for' */ + + +/* These are reserved words, not operator tokens, and are + recognized when reserved words are recognized. */ + + +%token Lbrace Rbrace Bang +/* '{' '}' '!' */ + + +%token In +/* 'in' */ + +/* ------------------------------------------------------- + The Grammar + ------------------------------------------------------- */ +%start complete_command +%% +complete_command : list separator + | list + ; +list : list separator_op and_or + | and_or + ; +and_or : pipeline + | and_or AND_IF linebreak pipeline + | and_or OR_IF linebreak pipeline + ; +pipeline : pipe_sequence + | Bang pipe_sequence + ; +pipe_sequence : command + | pipe_sequence '|' linebreak command + ; +command : simple_command + | compound_command + | compound_command redirect_list + | function_definition + ; +compound_command : brace_group + | subshell + | for_clause + | case_clause + | if_clause + | while_clause + | until_clause + ; +subshell : '(' compound_list ')' + ; +compound_list : term + | newline_list term + | term separator + | newline_list term separator + ; +term : term separator and_or + | and_or + ; +for_clause : For name linebreak do_group + | For name linebreak in sequential_sep do_group + | For name linebreak in wordlist sequential_sep do_group + ; +name : NAME /* Apply rule 5 */ + ; +in : In /* Apply rule 6 */ + ; +wordlist : wordlist WORD + | WORD + ; +case_clause : Case WORD linebreak in linebreak case_list Esac + | Case WORD linebreak in linebreak case_list_ns Esac + | Case WORD linebreak in linebreak Esac + ; +case_list_ns : case_list case_item_ns + | case_item_ns + ; +case_list : case_list case_item + | case_item + ; +case_item_ns : pattern ')' linebreak + | pattern ')' compound_list linebreak + | '(' pattern ')' linebreak + | '(' pattern ')' compound_list linebreak + ; +case_item : pattern ')' linebreak DSEMI linebreak + | pattern ')' compound_list DSEMI linebreak + | '(' pattern ')' linebreak DSEMI linebreak + | '(' pattern ')' compound_list DSEMI linebreak + ; +pattern : WORD /* Apply rule 4 */ + | pattern '|' WORD /* Do not apply rule 4 */ + ; +if_clause : If compound_list Then compound_list else_part Fi + | If compound_list Then compound_list Fi + ; +else_part : Elif compound_list Then compound_list + | Elif compound_list Then compound_list else_part + | Else compound_list + ; +while_clause : While compound_list do_group + ; +until_clause : Until compound_list do_group + ; +function_definition : fname '(' ')' linebreak function_body + ; +function_body : compound_command /* Apply rule 9 */ + | compound_command redirect_list /* Apply rule 9 */ + ; +fname : NAME /* Apply rule 8 */ + ; +brace_group : Lbrace compound_list Rbrace + ; +do_group : Do compound_list Done /* Apply rule 6 */ + ; +simple_command : cmd_prefix cmd_word cmd_suffix + | cmd_prefix cmd_word + | cmd_prefix + | cmd_name cmd_suffix + | cmd_name + ; +cmd_name : WORD /* Apply rule 7a */ + ; +cmd_word : WORD /* Apply rule 7b */ + ; +cmd_prefix : io_redirect + | cmd_prefix io_redirect + | ASSIGNMENT_WORD + | cmd_prefix ASSIGNMENT_WORD + ; +cmd_suffix : io_redirect + | cmd_suffix io_redirect + | WORD + | cmd_suffix WORD + ; +redirect_list : io_redirect + | redirect_list io_redirect + ; +io_redirect : io_file + | IO_NUMBER io_file + | io_here + | IO_NUMBER io_here + ; +io_file : '<' filename + | LESSAND filename + | '>' filename + | GREATAND filename + | DGREAT filename + | LESSGREAT filename + | CLOBBER filename + ; +filename : WORD /* Apply rule 2 */ + ; +io_here : DLESS here_end + | DLESSDASH here_end + ; +here_end : WORD /* Apply rule 3 */ + ; +newline_list : NEWLINE + | newline_list NEWLINE + ; +linebreak : newline_list + | /* empty */ + ; +separator_op : '&' + | ';' + ; +separator : separator_op linebreak + | newline_list + ; +sequential_sep : ';' linebreak + | newline_list + ; diff --git a/test.sh b/test.sh new file mode 100755 index 0000000..c1c7591 --- /dev/null +++ b/test.sh @@ -0,0 +1,25 @@ +set -e +if [ -n "$V" ]; then + set -x +fi +DIFF=${DIFF-diff} +SHELL=${SHELL-bin/gash} + +t="$1" +b=test/$(basename "$t" .sh) +set +e +timeout 1 $SHELL -e "$b".sh -s --long file0 file1 > "$b".1 2> "$b".2 +r=$? +set -e +if [ -f "$b".exit ]; then + e=$(cat "$b".exit) +else + e=0 +fi +[ $r = $e ] || exit 1 +if [ -f "$b".stdout ]; then + $DIFF -u "$b".stdout $b.1 +fi +if [ -f "$b".stderr ]; then + $DIFF -u "$b".stderr "$b".2 +fi diff --git a/test/00-exit-0.sh b/test/00-exit-0.sh new file mode 100644 index 0000000..eec2061 --- /dev/null +++ b/test/00-exit-0.sh @@ -0,0 +1 @@ +exit 0 \ No newline at end of file diff --git a/test/00-exit-1.exit b/test/00-exit-1.exit new file mode 100644 index 0000000..d00491f --- /dev/null +++ b/test/00-exit-1.exit @@ -0,0 +1 @@ +1 diff --git a/test/00-exit-1.sh b/test/00-exit-1.sh new file mode 100644 index 0000000..6dedc57 --- /dev/null +++ b/test/00-exit-1.sh @@ -0,0 +1 @@ +exit 1 \ No newline at end of file diff --git a/test/00-exit-2.exit b/test/00-exit-2.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/00-exit-2.exit @@ -0,0 +1 @@ +2 diff --git a/test/00-exit-2.sh b/test/00-exit-2.sh new file mode 100644 index 0000000..6b0593e --- /dev/null +++ b/test/00-exit-2.sh @@ -0,0 +1 @@ +exit 2 diff --git a/test/00-exit-error.exit b/test/00-exit-error.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/00-exit-error.exit @@ -0,0 +1 @@ +2 diff --git a/test/00-exit-error.sh b/test/00-exit-error.sh new file mode 100644 index 0000000..aabd2d2 --- /dev/null +++ b/test/00-exit-error.sh @@ -0,0 +1,2 @@ +set +e +ls /foo diff --git a/test/00-exit-var.exit b/test/00-exit-var.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/00-exit-var.exit @@ -0,0 +1 @@ +2 diff --git a/test/00-exit-var.sh b/test/00-exit-var.sh new file mode 100644 index 0000000..47b099a --- /dev/null +++ b/test/00-exit-var.sh @@ -0,0 +1,3 @@ +set +e +ls /foo +exit $? diff --git a/test/00-exit.sh b/test/00-exit.sh new file mode 100644 index 0000000..ae3bc0a --- /dev/null +++ b/test/00-exit.sh @@ -0,0 +1 @@ +exit \ No newline at end of file diff --git a/test/01-script-$#.sh b/test/01-script-$#.sh new file mode 100644 index 0000000..bb03f7a --- /dev/null +++ b/test/01-script-$#.sh @@ -0,0 +1 @@ +echo $# diff --git a/test/01-script-$#.stdout b/test/01-script-$#.stdout new file mode 100644 index 0000000..b8626c4 --- /dev/null +++ b/test/01-script-$#.stdout @@ -0,0 +1 @@ +4 diff --git a/test/01-script-$0.sh b/test/01-script-$0.sh new file mode 100644 index 0000000..afb2377 --- /dev/null +++ b/test/01-script-$0.sh @@ -0,0 +1,2 @@ +echo $0 + diff --git a/test/01-script-$@.sh b/test/01-script-$@.sh new file mode 100644 index 0000000..46445d8 --- /dev/null +++ b/test/01-script-$@.sh @@ -0,0 +1 @@ +echo $@ diff --git a/test/01-script-$@.stdout b/test/01-script-$@.stdout new file mode 100644 index 0000000..48c3024 --- /dev/null +++ b/test/01-script-$@.stdout @@ -0,0 +1 @@ +-s --long file0 file1 diff --git a/test/01-script-backslash-space.sh b/test/01-script-backslash-space.sh new file mode 100644 index 0000000..872a36a --- /dev/null +++ b/test/01-script-backslash-space.sh @@ -0,0 +1,4 @@ +echo foo\ + bar baz\ + bla +echo diff --git a/test/01-script-backslash-twice.exit b/test/01-script-backslash-twice.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/01-script-backslash-twice.exit @@ -0,0 +1 @@ +2 diff --git a/test/01-script-backslash-twice.sh b/test/01-script-backslash-twice.sh new file mode 100644 index 0000000..d6058cf --- /dev/null +++ b/test/01-script-backslash-twice.sh @@ -0,0 +1,3 @@ +exit \ +\ + 2 diff --git a/test/01-script-backslash.exit b/test/01-script-backslash.exit new file mode 100644 index 0000000..573541a --- /dev/null +++ b/test/01-script-backslash.exit @@ -0,0 +1 @@ +0 diff --git a/test/01-script-backslash.sh b/test/01-script-backslash.sh new file mode 100644 index 0000000..0e662fd --- /dev/null +++ b/test/01-script-backslash.sh @@ -0,0 +1,2 @@ +exit\ + 0 diff --git a/test/01-script-newline.exit b/test/01-script-newline.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/01-script-newline.exit @@ -0,0 +1 @@ +2 diff --git a/test/01-script-newline.sh b/test/01-script-newline.sh new file mode 100644 index 0000000..b8d906f --- /dev/null +++ b/test/01-script-newline.sh @@ -0,0 +1,2 @@ +true +exit 2 diff --git a/test/01-script-semi.exit b/test/01-script-semi.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/01-script-semi.exit @@ -0,0 +1 @@ +2 diff --git a/test/01-script-semi.sh b/test/01-script-semi.sh new file mode 100644 index 0000000..41b351d --- /dev/null +++ b/test/01-script-semi.sh @@ -0,0 +1 @@ +true; exit 2 diff --git a/test/01-script-shift.sh b/test/01-script-shift.sh new file mode 100644 index 0000000..216dc45 --- /dev/null +++ b/test/01-script-shift.sh @@ -0,0 +1,9 @@ +echo $@ +shift +echo $@ +shift +echo $@ +shift +echo $@ +shift +echo $@ diff --git a/test/01-script-shift.stdout b/test/01-script-shift.stdout new file mode 100644 index 0000000..2abb895 --- /dev/null +++ b/test/01-script-shift.stdout @@ -0,0 +1,5 @@ +-s --long file0 file1 +--long file0 file1 +file0 file1 +file1 + diff --git a/test/03-echo-brace.sh b/test/03-echo-brace.sh new file mode 100644 index 0000000..5e11003 --- /dev/null +++ b/test/03-echo-brace.sh @@ -0,0 +1 @@ +echo foo:{bar} diff --git a/test/03-echo-brace.stdout b/test/03-echo-brace.stdout new file mode 100644 index 0000000..4f1b6f1 --- /dev/null +++ b/test/03-echo-brace.stdout @@ -0,0 +1 @@ +foo:{bar} diff --git a/test/03-echo-doublequotes.sh b/test/03-echo-doublequotes.sh new file mode 100644 index 0000000..9236003 --- /dev/null +++ b/test/03-echo-doublequotes.sh @@ -0,0 +1 @@ +echo "foo" b"ar" diff --git a/test/03-echo-doublequotes.stdout b/test/03-echo-doublequotes.stdout new file mode 100644 index 0000000..d675fa4 --- /dev/null +++ b/test/03-echo-doublequotes.stdout @@ -0,0 +1 @@ +foo bar diff --git a/test/03-echo-escaped-doublequotes.sh b/test/03-echo-escaped-doublequotes.sh new file mode 100644 index 0000000..125a6e5 --- /dev/null +++ b/test/03-echo-escaped-doublequotes.sh @@ -0,0 +1 @@ +echo foo "bar" \"baz\" diff --git a/test/03-echo-escaped-doublequotes.stdout b/test/03-echo-escaped-doublequotes.stdout new file mode 100644 index 0000000..80a5f14 --- /dev/null +++ b/test/03-echo-escaped-doublequotes.stdout @@ -0,0 +1 @@ +foo bar "baz" diff --git a/test/03-echo-nesting.sh b/test/03-echo-nesting.sh new file mode 100644 index 0000000..efe83b8 --- /dev/null +++ b/test/03-echo-nesting.sh @@ -0,0 +1 @@ +echo 'foo "bar"' diff --git a/test/03-echo-nesting.stdout b/test/03-echo-nesting.stdout new file mode 100644 index 0000000..5635c74 --- /dev/null +++ b/test/03-echo-nesting.stdout @@ -0,0 +1 @@ +foo "bar" diff --git a/test/03-echo-quoted-doublequotes.sh b/test/03-echo-quoted-doublequotes.sh new file mode 100644 index 0000000..3e4148a --- /dev/null +++ b/test/03-echo-quoted-doublequotes.sh @@ -0,0 +1 @@ +echo foo "bar" '"baz"' diff --git a/test/03-echo-quoted-doublequotes.stdout b/test/03-echo-quoted-doublequotes.stdout new file mode 100644 index 0000000..80a5f14 --- /dev/null +++ b/test/03-echo-quoted-doublequotes.stdout @@ -0,0 +1 @@ +foo bar "baz" diff --git a/test/03-echo.sh b/test/03-echo.sh new file mode 100644 index 0000000..dccbe8e --- /dev/null +++ b/test/03-echo.sh @@ -0,0 +1 @@ +echo \ No newline at end of file diff --git a/test/04-echo-equal.sh b/test/04-echo-equal.sh new file mode 100644 index 0000000..86d3494 --- /dev/null +++ b/test/04-echo-equal.sh @@ -0,0 +1 @@ +echo a=$a diff --git a/test/04-echo-equal.stdout b/test/04-echo-equal.stdout new file mode 100644 index 0000000..2afe6dc --- /dev/null +++ b/test/04-echo-equal.stdout @@ -0,0 +1 @@ +a= diff --git a/test/04-echo-var.sh b/test/04-echo-var.sh new file mode 100644 index 0000000..e93c00f --- /dev/null +++ b/test/04-echo-var.sh @@ -0,0 +1 @@ +echo $SHELL \ No newline at end of file diff --git a/test/04-echo-word-at-word.sh b/test/04-echo-word-at-word.sh new file mode 100644 index 0000000..9f90b61 --- /dev/null +++ b/test/04-echo-word-at-word.sh @@ -0,0 +1 @@ +echo command $@ plus diff --git a/test/04-echo-word-at-word.stdout b/test/04-echo-word-at-word.stdout new file mode 100644 index 0000000..802f789 --- /dev/null +++ b/test/04-echo-word-at-word.stdout @@ -0,0 +1 @@ +command -s --long file0 file1 plus diff --git a/test/04-echo-word-at.sh b/test/04-echo-word-at.sh new file mode 100644 index 0000000..b3ba18e --- /dev/null +++ b/test/04-echo-word-at.sh @@ -0,0 +1 @@ +echo command $@ diff --git a/test/04-echo-word-at.stdout b/test/04-echo-word-at.stdout new file mode 100644 index 0000000..6253d76 --- /dev/null +++ b/test/04-echo-word-at.stdout @@ -0,0 +1 @@ +command -s --long file0 file1 diff --git a/test/05-assignment-backtick.sh b/test/05-assignment-backtick.sh new file mode 100644 index 0000000..51c6bf6 --- /dev/null +++ b/test/05-assignment-backtick.sh @@ -0,0 +1,3 @@ +obj=ar.o +objs="$objs `basename $obj`" +echo "objs:>$objs<" diff --git a/test/05-assignment-backtick.stdout b/test/05-assignment-backtick.stdout new file mode 100644 index 0000000..2cde7c4 --- /dev/null +++ b/test/05-assignment-backtick.stdout @@ -0,0 +1 @@ +objs:> ar.o< diff --git a/test/05-assignment-double-quote.sh b/test/05-assignment-double-quote.sh new file mode 100644 index 0000000..6b03911 --- /dev/null +++ b/test/05-assignment-double-quote.sh @@ -0,0 +1 @@ +srcdir="." diff --git a/test/05-assignment-doublequoted-doublequotes.sh b/test/05-assignment-doublequoted-doublequotes.sh new file mode 100644 index 0000000..173a49a --- /dev/null +++ b/test/05-assignment-doublequoted-doublequotes.sh @@ -0,0 +1,4 @@ +aliaspath=alias +localedir=locale +defines="-DALIASPATH=\"${aliaspath}\" -DLOCALEDIR=\"${localedir}\"" +echo cc $defines diff --git a/test/05-assignment-doublequoted-doublequotes.stdout b/test/05-assignment-doublequoted-doublequotes.stdout new file mode 100644 index 0000000..4ea0763 --- /dev/null +++ b/test/05-assignment-doublequoted-doublequotes.stdout @@ -0,0 +1 @@ +cc -DALIASPATH="alias" -DLOCALEDIR="locale" diff --git a/test/05-assignment-echo.sh b/test/05-assignment-echo.sh new file mode 100644 index 0000000..eef32cd --- /dev/null +++ b/test/05-assignment-echo.sh @@ -0,0 +1,2 @@ +SHELL=/bin/bash +echo $SHELL diff --git a/test/05-assignment-echo.stdout b/test/05-assignment-echo.stdout new file mode 100644 index 0000000..01dca2d --- /dev/null +++ b/test/05-assignment-echo.stdout @@ -0,0 +1 @@ +/bin/bash diff --git a/test/05-assignment-empty.sh b/test/05-assignment-empty.sh new file mode 100644 index 0000000..049544d --- /dev/null +++ b/test/05-assignment-empty.sh @@ -0,0 +1,2 @@ +a= +echo a:$a diff --git a/test/05-assignment-empty.stdout b/test/05-assignment-empty.stdout new file mode 100644 index 0000000..46568d8 --- /dev/null +++ b/test/05-assignment-empty.stdout @@ -0,0 +1 @@ +a: diff --git a/test/05-assignment-singlequote.sh b/test/05-assignment-singlequote.sh new file mode 100644 index 0000000..77f0bb1 --- /dev/null +++ b/test/05-assignment-singlequote.sh @@ -0,0 +1 @@ +srcdir='.' diff --git a/test/05-assignment-variable-word.sh b/test/05-assignment-variable-word.sh new file mode 100644 index 0000000..dbc2719 --- /dev/null +++ b/test/05-assignment-variable-word.sh @@ -0,0 +1,3 @@ +SHELL=gash +bin=${SHELL}/bin +echo $bin diff --git a/test/05-assignment-variable-word.stdout b/test/05-assignment-variable-word.stdout new file mode 100644 index 0000000..567d244 --- /dev/null +++ b/test/05-assignment-variable-word.stdout @@ -0,0 +1 @@ +gash/bin diff --git a/test/05-assignment-word-variable.sh b/test/05-assignment-word-variable.sh new file mode 100644 index 0000000..95d0e68 --- /dev/null +++ b/test/05-assignment-word-variable.sh @@ -0,0 +1,3 @@ +SHELL=gash +PATH=bin:${SHELL} +echo $PATH diff --git a/test/05-assignment-word-variable.stdout b/test/05-assignment-word-variable.stdout new file mode 100644 index 0000000..62036dd --- /dev/null +++ b/test/05-assignment-word-variable.stdout @@ -0,0 +1 @@ +bin:gash diff --git a/test/05-assignment.sh b/test/05-assignment.sh new file mode 100644 index 0000000..835e1dc --- /dev/null +++ b/test/05-assignment.sh @@ -0,0 +1 @@ +SHELL=/bin/bash diff --git a/test/06-command-compound-word.sh b/test/06-command-compound-word.sh new file mode 100644 index 0000000..224bcd8 --- /dev/null +++ b/test/06-command-compound-word.sh @@ -0,0 +1,3 @@ +CC=echo +file=ar.o +$CC -I${srcdir} $file diff --git a/test/06-command-compound-word.stdout b/test/06-command-compound-word.stdout new file mode 100644 index 0000000..366e732 --- /dev/null +++ b/test/06-command-compound-word.stdout @@ -0,0 +1 @@ +-I ar.o diff --git a/test/06-compound-word.sh b/test/06-compound-word.sh new file mode 100644 index 0000000..e806293 --- /dev/null +++ b/test/06-compound-word.sh @@ -0,0 +1,2 @@ +srcdir=. +echo cc -c ${srcdir}/$file diff --git a/test/06-compound-word.stdout b/test/06-compound-word.stdout new file mode 100644 index 0000000..81f5a26 --- /dev/null +++ b/test/06-compound-word.stdout @@ -0,0 +1 @@ +cc -c ./ diff --git a/test/07-variable-not-or.sh b/test/07-variable-not-or.sh new file mode 100644 index 0000000..a52d13b --- /dev/null +++ b/test/07-variable-not-or.sh @@ -0,0 +1,2 @@ +foo=baz +echo ${foo-bar} diff --git a/test/07-variable-not-or.stdout b/test/07-variable-not-or.stdout new file mode 100644 index 0000000..7601807 --- /dev/null +++ b/test/07-variable-not-or.stdout @@ -0,0 +1 @@ +baz diff --git a/test/07-variable-or-doublequote.sh b/test/07-variable-or-doublequote.sh new file mode 100644 index 0000000..04af4f2 --- /dev/null +++ b/test/07-variable-or-doublequote.sh @@ -0,0 +1,4 @@ +CPPFLAGS=${CPPFLAGS-" +-I ${srcdest}src +"} +echo $CPPFLAGS diff --git a/test/07-variable-or-doublequote.stdout b/test/07-variable-or-doublequote.stdout new file mode 100644 index 0000000..3bb5bf4 --- /dev/null +++ b/test/07-variable-or-doublequote.stdout @@ -0,0 +1 @@ +-I src diff --git a/test/07-variable-or-empty.sh b/test/07-variable-or-empty.sh new file mode 100644 index 0000000..ba4f900 --- /dev/null +++ b/test/07-variable-or-empty.sh @@ -0,0 +1 @@ +echo ${bindir-} diff --git a/test/07-variable-or-empty.stdout b/test/07-variable-or-empty.stdout new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/test/07-variable-or-empty.stdout @@ -0,0 +1 @@ + diff --git a/test/07-variable-or-slash.sh b/test/07-variable-or-slash.sh new file mode 100644 index 0000000..4ac2f60 --- /dev/null +++ b/test/07-variable-or-slash.sh @@ -0,0 +1 @@ +echo ${foo-bar/} diff --git a/test/07-variable-or-variable.sh b/test/07-variable-or-variable.sh new file mode 100644 index 0000000..3fe8df8 --- /dev/null +++ b/test/07-variable-or-variable.sh @@ -0,0 +1,2 @@ +prefix=/usr +echo ${bindir-$prefix/bin} diff --git a/test/07-variable-or-variable.stdout b/test/07-variable-or-variable.stdout new file mode 100644 index 0000000..415f082 --- /dev/null +++ b/test/07-variable-or-variable.stdout @@ -0,0 +1 @@ +/usr/bin diff --git a/test/07-variable-or.sh b/test/07-variable-or.sh new file mode 100644 index 0000000..4a2da2a --- /dev/null +++ b/test/07-variable-or.sh @@ -0,0 +1 @@ +echo ${foo-bar} diff --git a/test/07-variable-or.stdout b/test/07-variable-or.stdout new file mode 100644 index 0000000..5716ca5 --- /dev/null +++ b/test/07-variable-or.stdout @@ -0,0 +1 @@ +bar diff --git a/test/08-variable-and.sh b/test/08-variable-and.sh new file mode 100644 index 0000000..3c5da46 --- /dev/null +++ b/test/08-variable-and.sh @@ -0,0 +1,2 @@ +foo=baz +echo ${foo+bar} diff --git a/test/08-variable-and.stdout b/test/08-variable-and.stdout new file mode 100644 index 0000000..5716ca5 --- /dev/null +++ b/test/08-variable-and.stdout @@ -0,0 +1 @@ +bar diff --git a/test/08-variable-not-and.sh b/test/08-variable-not-and.sh new file mode 100644 index 0000000..af44487 --- /dev/null +++ b/test/08-variable-not-and.sh @@ -0,0 +1 @@ +echo ${foo+bar} diff --git a/test/08-variable-not-and.stdout b/test/08-variable-not-and.stdout new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/test/08-variable-not-and.stdout @@ -0,0 +1 @@ + diff --git a/test/10-else-multiple.sh b/test/10-else-multiple.sh new file mode 100644 index 0000000..4e36fb9 --- /dev/null +++ b/test/10-else-multiple.sh @@ -0,0 +1,6 @@ +if false; then + : +else + echo one + echo two +fi diff --git a/test/10-else.multiple.stdout b/test/10-else.multiple.stdout new file mode 100644 index 0000000..814f4a4 --- /dev/null +++ b/test/10-else.multiple.stdout @@ -0,0 +1,2 @@ +one +two diff --git a/test/10-if-bracket-false.sh b/test/10-if-bracket-false.sh new file mode 100644 index 0000000..1833999 --- /dev/null +++ b/test/10-if-bracket-false.sh @@ -0,0 +1,4 @@ +if \[ 0 = 1 ]; then + exit 1 +fi +exit 0 diff --git a/test/10-if-bracket.sh b/test/10-if-bracket.sh new file mode 100644 index 0000000..e16309c --- /dev/null +++ b/test/10-if-bracket.sh @@ -0,0 +1,4 @@ +if \[ 1 = 1 ]; then + exit 0 +fi +exit 1 diff --git a/test/10-if-elif.sh b/test/10-if-elif.sh new file mode 100644 index 0000000..8ec1e4e --- /dev/null +++ b/test/10-if-elif.sh @@ -0,0 +1,8 @@ +if false; then + exit 1 +elif false; then + exit 2 +else + exit 0 +fi +exit 1 diff --git a/test/10-if-else.sh b/test/10-if-else.sh new file mode 100644 index 0000000..9b34a0b --- /dev/null +++ b/test/10-if-else.sh @@ -0,0 +1,6 @@ +if false; then + exit 1 +else + exit 0 +fi +exit 1 diff --git a/test/10-if-false.sh b/test/10-if-false.sh new file mode 100644 index 0000000..04581c1 --- /dev/null +++ b/test/10-if-false.sh @@ -0,0 +1,4 @@ +if false; then + exit 1 +fi +exit 0 diff --git a/test/10-if-line.sh b/test/10-if-line.sh new file mode 100644 index 0000000..da0e6d8 --- /dev/null +++ b/test/10-if-line.sh @@ -0,0 +1 @@ +if true; then echo yay; fi \ No newline at end of file diff --git a/test/10-if-multiple.sh b/test/10-if-multiple.sh new file mode 100644 index 0000000..4f46034 --- /dev/null +++ b/test/10-if-multiple.sh @@ -0,0 +1,4 @@ +if true; then + echo one + echo two +fi diff --git a/test/10-if-multiple.stdout b/test/10-if-multiple.stdout new file mode 100644 index 0000000..814f4a4 --- /dev/null +++ b/test/10-if-multiple.stdout @@ -0,0 +1,2 @@ +one +two diff --git a/test/10-if-redirect.sh b/test/10-if-redirect.sh new file mode 100644 index 0000000..9b269f6 --- /dev/null +++ b/test/10-if-redirect.sh @@ -0,0 +1,5 @@ +if $SHELL --version | grep foobar 2>/dev/null; then + exit 1 +else + exit 0 +fi diff --git a/test/10-if-test-false.sh b/test/10-if-test-false.sh new file mode 100644 index 0000000..220020b --- /dev/null +++ b/test/10-if-test-false.sh @@ -0,0 +1,4 @@ +if test 0 = 1; then + exit 1 +fi +exit 0 diff --git a/test/10-if-test.sh b/test/10-if-test.sh new file mode 100644 index 0000000..8a93e47 --- /dev/null +++ b/test/10-if-test.sh @@ -0,0 +1,4 @@ +if test 1 = 1; then + exit 0 +fi +exit 1 diff --git a/test/10-if-word-variable.sh b/test/10-if-word-variable.sh new file mode 100644 index 0000000..cc347dc --- /dev/null +++ b/test/10-if-word-variable.sh @@ -0,0 +1,4 @@ +if \[ x"$y" = x ]; then + exit 0 +fi +exit 1 diff --git a/test/10-if.sh b/test/10-if.sh new file mode 100644 index 0000000..f61cd14 --- /dev/null +++ b/test/10-if.sh @@ -0,0 +1,4 @@ +if true; then + exit 0 +fi +exit 1 diff --git a/test/100-basename-autoconf.sh b/test/100-basename-autoconf.sh new file mode 100644 index 0000000..74a383a --- /dev/null +++ b/test/100-basename-autoconf.sh @@ -0,0 +1,6 @@ +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 diff --git a/test/100-basename-autoconf.stdout b/test/100-basename-autoconf.stdout new file mode 100644 index 0000000..d6dbd76 --- /dev/null +++ b/test/100-basename-autoconf.stdout @@ -0,0 +1 @@ +as_basename:basename diff --git a/test/100-basename-root.sh b/test/100-basename-root.sh new file mode 100644 index 0000000..72182c6 --- /dev/null +++ b/test/100-basename-root.sh @@ -0,0 +1,2 @@ +\basename /root +\basename / diff --git a/test/100-basename-root.stdout b/test/100-basename-root.stdout new file mode 100644 index 0000000..7c86684 --- /dev/null +++ b/test/100-basename-root.stdout @@ -0,0 +1,2 @@ +root +/ diff --git a/test/100-bracket-file.sh b/test/100-bracket-file.sh new file mode 100644 index 0000000..556197d --- /dev/null +++ b/test/100-bracket-file.sh @@ -0,0 +1,4 @@ +if \[ -f foo-bar ]; then + exit 1 +fi + diff --git a/test/100-cd-foo.exit b/test/100-cd-foo.exit new file mode 100644 index 0000000..d00491f --- /dev/null +++ b/test/100-cd-foo.exit @@ -0,0 +1 @@ +1 diff --git a/test/100-cd-foo.sh b/test/100-cd-foo.sh new file mode 100644 index 0000000..92a9b5c --- /dev/null +++ b/test/100-cd-foo.sh @@ -0,0 +1 @@ +cd /foo diff --git a/test/100-cd.sh b/test/100-cd.sh new file mode 100644 index 0000000..16911ea --- /dev/null +++ b/test/100-cd.sh @@ -0,0 +1,2 @@ +cd /bin +pwd diff --git a/test/100-cd.stdout b/test/100-cd.stdout new file mode 100644 index 0000000..5e56e04 --- /dev/null +++ b/test/100-cd.stdout @@ -0,0 +1 @@ +/bin diff --git a/test/100-dirname-autoconf.sh b/test/100-dirname-autoconf.sh new file mode 100644 index 0000000..c2597c0 --- /dev/null +++ b/test/100-dirname-autoconf.sh @@ -0,0 +1,6 @@ +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 diff --git a/test/100-dirname-autoconf.stdout b/test/100-dirname-autoconf.stdout new file mode 100644 index 0000000..547ed0e --- /dev/null +++ b/test/100-dirname-autoconf.stdout @@ -0,0 +1 @@ +as_dirname:dirname diff --git a/test/100-dirname-root.sh b/test/100-dirname-root.sh new file mode 100644 index 0000000..11a7935 --- /dev/null +++ b/test/100-dirname-root.sh @@ -0,0 +1,2 @@ +\dirname /root +\dirname / diff --git a/test/100-dirname-root.stdout b/test/100-dirname-root.stdout new file mode 100644 index 0000000..9ba960f --- /dev/null +++ b/test/100-dirname-root.stdout @@ -0,0 +1,2 @@ +/ +/ diff --git a/test/100-sed-autoconf-basename.sh b/test/100-sed-autoconf-basename.sh new file mode 100644 index 0000000..a69a94b --- /dev/null +++ b/test/100-sed-autoconf-basename.sh @@ -0,0 +1 @@ +echo 'X/foo/bar' | \sed -f test/data/basename.sed diff --git a/test/100-sed-autoconf-basename.stdout b/test/100-sed-autoconf-basename.stdout new file mode 100644 index 0000000..5716ca5 --- /dev/null +++ b/test/100-sed-autoconf-basename.stdout @@ -0,0 +1 @@ +bar diff --git a/test/100-sed-case.sh b/test/100-sed-case.sh new file mode 100644 index 0000000..9e78665 --- /dev/null +++ b/test/100-sed-case.sh @@ -0,0 +1 @@ +echo ooO | \sed s,o,O,i diff --git a/test/100-sed-case.stdout b/test/100-sed-case.stdout new file mode 100644 index 0000000..327d153 --- /dev/null +++ b/test/100-sed-case.stdout @@ -0,0 +1 @@ +OoO diff --git a/test/100-sed-command-list.sh b/test/100-sed-command-list.sh new file mode 100644 index 0000000..b3d918e --- /dev/null +++ b/test/100-sed-command-list.sh @@ -0,0 +1,4 @@ +input='foo +bar' + +echo "$input" | \sed '/foo/ { s/foo/baz/ s/baz/bar/ } s/bar/baz/' diff --git a/test/100-sed-command-list.stdout b/test/100-sed-command-list.stdout new file mode 100644 index 0000000..1f55335 --- /dev/null +++ b/test/100-sed-command-list.stdout @@ -0,0 +1,2 @@ +baz +baz diff --git a/test/100-sed-file.sh b/test/100-sed-file.sh new file mode 100644 index 0000000..635bcdb --- /dev/null +++ b/test/100-sed-file.sh @@ -0,0 +1 @@ +\sed s,foo,bar, test/data/foo diff --git a/test/100-sed-file.stdout b/test/100-sed-file.stdout new file mode 100644 index 0000000..52d6430 --- /dev/null +++ b/test/100-sed-file.stdout @@ -0,0 +1,3 @@ +bar +bar +baz diff --git a/test/100-sed-fooRbar.sh b/test/100-sed-fooRbar.sh new file mode 100644 index 0000000..3e31a92 --- /dev/null +++ b/test/100-sed-fooRbar.sh @@ -0,0 +1 @@ +\sed s",\r,\n," < test/data/fooRbar diff --git a/test/100-sed-fooRbar.stdout b/test/100-sed-fooRbar.stdout new file mode 100644 index 0000000..c38c3d6 --- /dev/null +++ b/test/100-sed-fooRbar.stdout @@ -0,0 +1,3 @@ +foo\rbar +foo +bar diff --git a/test/100-sed-global.sh b/test/100-sed-global.sh new file mode 100644 index 0000000..d3f53bd --- /dev/null +++ b/test/100-sed-global.sh @@ -0,0 +1 @@ +echo 001 | \sed s,0,1,g diff --git a/test/100-sed-global.stdout b/test/100-sed-global.stdout new file mode 100644 index 0000000..58c9bdf --- /dev/null +++ b/test/100-sed-global.stdout @@ -0,0 +1 @@ +111 diff --git a/test/100-sed-group-extended.sh b/test/100-sed-group-extended.sh new file mode 100644 index 0000000..ece581c --- /dev/null +++ b/test/100-sed-group-extended.sh @@ -0,0 +1 @@ +echo 012 | \sed -r 's,(0)1(2),\21\1,' diff --git a/test/100-sed-group-extended.stdout b/test/100-sed-group-extended.stdout new file mode 100644 index 0000000..cd7da05 --- /dev/null +++ b/test/100-sed-group-extended.stdout @@ -0,0 +1 @@ +210 diff --git a/test/100-sed-group.sh b/test/100-sed-group.sh new file mode 100644 index 0000000..f5bff3e --- /dev/null +++ b/test/100-sed-group.sh @@ -0,0 +1 @@ +echo 012 | \sed 's,\(0\)1\(2\),\21\1,' diff --git a/test/100-sed-group.stdout b/test/100-sed-group.stdout new file mode 100644 index 0000000..cd7da05 --- /dev/null +++ b/test/100-sed-group.stdout @@ -0,0 +1 @@ +210 diff --git a/test/100-sed-once.sh b/test/100-sed-once.sh new file mode 100644 index 0000000..f133d0e --- /dev/null +++ b/test/100-sed-once.sh @@ -0,0 +1 @@ +echo 001 | \sed s,0,1, diff --git a/test/100-sed-once.stdout b/test/100-sed-once.stdout new file mode 100644 index 0000000..398050c --- /dev/null +++ b/test/100-sed-once.stdout @@ -0,0 +1 @@ +101 diff --git a/test/100-sed-pattern-address.sh b/test/100-sed-pattern-address.sh new file mode 100644 index 0000000..a58cb9b --- /dev/null +++ b/test/100-sed-pattern-address.sh @@ -0,0 +1,5 @@ +input='bar +baz +bam' + +echo "$input" | \sed '/baz/ s/a/i/' diff --git a/test/100-sed-pattern-address.stdout b/test/100-sed-pattern-address.stdout new file mode 100644 index 0000000..cd6aa0e --- /dev/null +++ b/test/100-sed-pattern-address.stdout @@ -0,0 +1,3 @@ +bar +biz +bam diff --git a/test/100-sed-quit.sh b/test/100-sed-quit.sh new file mode 100644 index 0000000..df41e6d --- /dev/null +++ b/test/100-sed-quit.sh @@ -0,0 +1,4 @@ +input='foo +bar' + +echo "$input" | \sed 's/foo/baz/ ; q ; s/baz/foo/' diff --git a/test/100-sed-quit.stdout b/test/100-sed-quit.stdout new file mode 100644 index 0000000..7601807 --- /dev/null +++ b/test/100-sed-quit.stdout @@ -0,0 +1 @@ +baz diff --git a/test/100-sed-twice.sh b/test/100-sed-twice.sh new file mode 100644 index 0000000..fe13896 --- /dev/null +++ b/test/100-sed-twice.sh @@ -0,0 +1 @@ +echo 0001 | \sed -e s,0,1, -e s,0,1, diff --git a/test/100-sed-twice.stdout b/test/100-sed-twice.stdout new file mode 100644 index 0000000..4f1e6aa --- /dev/null +++ b/test/100-sed-twice.stdout @@ -0,0 +1 @@ +1101 diff --git a/test/100-sed-undo.sh b/test/100-sed-undo.sh new file mode 100644 index 0000000..cd50810 --- /dev/null +++ b/test/100-sed-undo.sh @@ -0,0 +1 @@ +echo 001 | \sed -e s,0,1, -e s,1,0, diff --git a/test/100-sed-undo.stdout b/test/100-sed-undo.stdout new file mode 100644 index 0000000..5325a8d --- /dev/null +++ b/test/100-sed-undo.stdout @@ -0,0 +1 @@ +001 diff --git a/test/100-sed.sh b/test/100-sed.sh new file mode 100644 index 0000000..50f862c --- /dev/null +++ b/test/100-sed.sh @@ -0,0 +1 @@ +\sed --help diff --git a/test/100-sed.stdout b/test/100-sed.stdout new file mode 100644 index 0000000..b041df2 --- /dev/null +++ b/test/100-sed.stdout @@ -0,0 +1,7 @@ +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 diff --git a/test/100-tar-Z-old.sh b/test/100-tar-Z-old.sh new file mode 100644 index 0000000..ba72f78 --- /dev/null +++ b/test/100-tar-Z-old.sh @@ -0,0 +1,2 @@ +\tar cZf tmp.tar --sort=name test/data/star +\tar tZf tmp.tar diff --git a/test/100-tar-Z-old.stdout b/test/100-tar-Z-old.stdout new file mode 100644 index 0000000..7f14d75 --- /dev/null +++ b/test/100-tar-Z-old.stdout @@ -0,0 +1,5 @@ +test/data/star/ +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 diff --git a/test/100-tar-Z-pipe.sh b/test/100-tar-Z-pipe.sh new file mode 100644 index 0000000..8b308d4 --- /dev/null +++ b/test/100-tar-Z-pipe.sh @@ -0,0 +1 @@ +\tar -cZf- --sort=name test/data/star | \tar -tZf- diff --git a/test/100-tar-Z-pipe.stdout b/test/100-tar-Z-pipe.stdout new file mode 100644 index 0000000..7f14d75 --- /dev/null +++ b/test/100-tar-Z-pipe.stdout @@ -0,0 +1,5 @@ +test/data/star/ +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 diff --git a/test/100-tar-Z.sh b/test/100-tar-Z.sh new file mode 100644 index 0000000..d5c043e --- /dev/null +++ b/test/100-tar-Z.sh @@ -0,0 +1,3 @@ +\tar -cZf tmp.tar --sort=name test/data/star +\tar -tZf tmp.tar + diff --git a/test/100-tar-Z.stdout b/test/100-tar-Z.stdout new file mode 100644 index 0000000..7f14d75 --- /dev/null +++ b/test/100-tar-Z.stdout @@ -0,0 +1,5 @@ +test/data/star/ +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 diff --git a/test/100-tar-ro.sh b/test/100-tar-ro.sh new file mode 100644 index 0000000..dde8b10 --- /dev/null +++ b/test/100-tar-ro.sh @@ -0,0 +1,3 @@ +\tar -xvf test/data/ro.tar +\chmod -R +w foo +\rm -r foo diff --git a/test/100-tar-ro.stdout b/test/100-tar-ro.stdout new file mode 100644 index 0000000..3d84aa0 --- /dev/null +++ b/test/100-tar-ro.stdout @@ -0,0 +1,3 @@ +foo/ +foo/bar/ +foo/bar/baz diff --git a/test/100-tar.sh b/test/100-tar.sh new file mode 100644 index 0000000..445fc3a --- /dev/null +++ b/test/100-tar.sh @@ -0,0 +1 @@ +\tar -cf- --sort=name test/data/star | \tar -tf- diff --git a/test/100-tar.stdout b/test/100-tar.stdout new file mode 100644 index 0000000..7f14d75 --- /dev/null +++ b/test/100-tar.stdout @@ -0,0 +1,5 @@ +test/data/star/ +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 diff --git a/test/100-test-file.sh b/test/100-test-file.sh new file mode 100644 index 0000000..ebf0f4c --- /dev/null +++ b/test/100-test-file.sh @@ -0,0 +1,4 @@ +if test -f foo-bar; then + exit 1 +fi + diff --git a/test/100-test.sh b/test/100-test.sh new file mode 100644 index 0000000..6e513ec --- /dev/null +++ b/test/100-test.sh @@ -0,0 +1,3 @@ +if test a = b; then + exit 1; +fi diff --git a/test/100-tr.sh b/test/100-tr.sh new file mode 100644 index 0000000..70a5b38 --- /dev/null +++ b/test/100-tr.sh @@ -0,0 +1 @@ +\tr -d o < test/data/foo diff --git a/test/100-tr.stdout b/test/100-tr.stdout new file mode 100644 index 0000000..5c2d6f2 --- /dev/null +++ b/test/100-tr.stdout @@ -0,0 +1,3 @@ +f +bar +baz diff --git a/test/11-for-done-subshell.sh b/test/11-for-done-subshell.sh new file mode 100644 index 0000000..08ffa46 --- /dev/null +++ b/test/11-for-done-subshell.sh @@ -0,0 +1 @@ +(for i in 0; do echo $i; done) diff --git a/test/11-for-split-sequence.sh b/test/11-for-split-sequence.sh new file mode 100644 index 0000000..1ef55e4 --- /dev/null +++ b/test/11-for-split-sequence.sh @@ -0,0 +1,4 @@ +one=1 +for i in 0 $one 2 $two_n_halve $two_n_quaaar and 3 ""; do + echo $i; +done diff --git a/test/11-for-split-sequence.stdout b/test/11-for-split-sequence.stdout new file mode 100644 index 0000000..b1fc8b4 --- /dev/null +++ b/test/11-for-split-sequence.stdout @@ -0,0 +1,6 @@ +0 +1 +2 +and +3 + diff --git a/test/11-for.sh b/test/11-for.sh new file mode 100644 index 0000000..a647d4e --- /dev/null +++ b/test/11-for.sh @@ -0,0 +1,3 @@ +for i in 0 1 2; do + echo $i; +done diff --git a/test/11-for.stdout b/test/11-for.stdout new file mode 100644 index 0000000..4539bbf --- /dev/null +++ b/test/11-for.stdout @@ -0,0 +1,3 @@ +0 +1 +2 diff --git a/test/20-and.exit b/test/20-and.exit new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/20-and.exit @@ -0,0 +1 @@ +2 diff --git a/test/20-and.sh b/test/20-and.sh new file mode 100644 index 0000000..495cfe4 --- /dev/null +++ b/test/20-and.sh @@ -0,0 +1 @@ +true && exit 2 diff --git a/test/20-exec.sh b/test/20-exec.sh new file mode 100644 index 0000000..8bd0061 --- /dev/null +++ b/test/20-exec.sh @@ -0,0 +1,2 @@ +exec true +false diff --git a/test/20-or.sh b/test/20-or.sh new file mode 100644 index 0000000..84ffdd6 --- /dev/null +++ b/test/20-or.sh @@ -0,0 +1 @@ +false || true diff --git a/test/20-pipe-exit-0.sh b/test/20-pipe-exit-0.sh new file mode 100644 index 0000000..d09faab --- /dev/null +++ b/test/20-pipe-exit-0.sh @@ -0,0 +1 @@ +false | true diff --git a/test/20-pipe-exit-1.exit b/test/20-pipe-exit-1.exit new file mode 100644 index 0000000..56a6051 --- /dev/null +++ b/test/20-pipe-exit-1.exit @@ -0,0 +1 @@ +1 \ No newline at end of file diff --git a/test/20-pipe-exit-1.sh b/test/20-pipe-exit-1.sh new file mode 100644 index 0000000..8bfc37e --- /dev/null +++ b/test/20-pipe-exit-1.sh @@ -0,0 +1 @@ +true | false diff --git a/test/20-pipe-sed-cat.sh b/test/20-pipe-sed-cat.sh new file mode 100644 index 0000000..0c1fb4a --- /dev/null +++ b/test/20-pipe-sed-cat.sh @@ -0,0 +1 @@ +echo -e 'a\nb\nc' test/data/star/* | sed 's, ,\n,g' | cat diff --git a/test/20-pipe-sed-cat.stdout b/test/20-pipe-sed-cat.stdout new file mode 100644 index 0000000..36c2abd --- /dev/null +++ b/test/20-pipe-sed-cat.stdout @@ -0,0 +1,7 @@ +a +b +c +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 diff --git a/test/20-pipe-sed.sh b/test/20-pipe-sed.sh new file mode 100644 index 0000000..5fb2d9e --- /dev/null +++ b/test/20-pipe-sed.sh @@ -0,0 +1 @@ +echo -e 'a\nb\nc' test/data/star/* | \sed 's, ,\n,g' diff --git a/test/20-pipe-sed.stdout b/test/20-pipe-sed.stdout new file mode 100644 index 0000000..36c2abd --- /dev/null +++ b/test/20-pipe-sed.stdout @@ -0,0 +1,7 @@ +a +b +c +test/data/star/0 +test/data/star/1 +test/data/star/2 +test/data/star/3 diff --git a/test/20-semi.exit b/test/20-semi.exit new file mode 100644 index 0000000..d00491f --- /dev/null +++ b/test/20-semi.exit @@ -0,0 +1 @@ +1 diff --git a/test/20-semi.sh b/test/20-semi.sh new file mode 100644 index 0000000..67bf325 --- /dev/null +++ b/test/20-semi.sh @@ -0,0 +1,2 @@ +# gash makes this into a pipeline, then uses `true''s exit status +false ; true diff --git a/test/30-for-substitution.sh b/test/30-for-substitution.sh new file mode 100644 index 0000000..a216a82 --- /dev/null +++ b/test/30-for-substitution.sh @@ -0,0 +1,3 @@ +for file in `echo foo.o bar.o`; do + echo compiling $file... +done diff --git a/test/30-for-substitution.stdout b/test/30-for-substitution.stdout new file mode 100644 index 0000000..aff4123 --- /dev/null +++ b/test/30-for-substitution.stdout @@ -0,0 +1,2 @@ +compiling foo.o... +compiling bar.o... diff --git a/test/30-substitution-assignment-at.sh b/test/30-substitution-assignment-at.sh new file mode 100644 index 0000000..a888fd0 --- /dev/null +++ b/test/30-substitution-assignment-at.sh @@ -0,0 +1,2 @@ +cmdline=$(echo " $@") +echo cmdline:$cmdline diff --git a/test/30-substitution-assignment-at.stdout b/test/30-substitution-assignment-at.stdout new file mode 100644 index 0000000..0f794c3 --- /dev/null +++ b/test/30-substitution-assignment-at.stdout @@ -0,0 +1 @@ +cmdline: -s --long file0 file1 diff --git a/test/30-substitution-assignment.sh b/test/30-substitution-assignment.sh new file mode 100644 index 0000000..816efa7 --- /dev/null +++ b/test/30-substitution-assignment.sh @@ -0,0 +1,2 @@ +echo=$(echo 1 2 3) +echo echo=$echo diff --git a/test/30-substitution-assignment.stdout b/test/30-substitution-assignment.stdout new file mode 100644 index 0000000..7e6732e --- /dev/null +++ b/test/30-substitution-assignment.stdout @@ -0,0 +1 @@ +echo=1 2 3 diff --git a/test/30-substitution-backtick.sh b/test/30-substitution-backtick.sh new file mode 100644 index 0000000..f196ae2 --- /dev/null +++ b/test/30-substitution-backtick.sh @@ -0,0 +1 @@ +echo `echo 1 2 3` diff --git a/test/30-substitution-backtick.stdout b/test/30-substitution-backtick.stdout new file mode 100644 index 0000000..b85905e --- /dev/null +++ b/test/30-substitution-backtick.stdout @@ -0,0 +1 @@ +1 2 3 diff --git a/test/30-substitution-redirect.sh b/test/30-substitution-redirect.sh new file mode 100644 index 0000000..9bdbc0f --- /dev/null +++ b/test/30-substitution-redirect.sh @@ -0,0 +1 @@ +echo $(echo foo bar baz 2>/dev/null) diff --git a/test/30-substitution-redirect.stdout b/test/30-substitution-redirect.stdout new file mode 100644 index 0000000..1aeaedb --- /dev/null +++ b/test/30-substitution-redirect.stdout @@ -0,0 +1 @@ +foo bar baz diff --git a/test/30-substitution-word.sh b/test/30-substitution-word.sh new file mode 100644 index 0000000..69467ab --- /dev/null +++ b/test/30-substitution-word.sh @@ -0,0 +1,2 @@ +echo foo $(echo bar)/baz + diff --git a/test/30-substitution-word.stdout b/test/30-substitution-word.stdout new file mode 100644 index 0000000..1a1c7ad --- /dev/null +++ b/test/30-substitution-word.stdout @@ -0,0 +1 @@ +foo bar/baz diff --git a/test/30-substitution.sh b/test/30-substitution.sh new file mode 100644 index 0000000..a5c0e5c --- /dev/null +++ b/test/30-substitution.sh @@ -0,0 +1 @@ +echo $(echo 1 2 3) diff --git a/test/30-substitution.stdout b/test/30-substitution.stdout new file mode 100644 index 0000000..b85905e --- /dev/null +++ b/test/30-substitution.stdout @@ -0,0 +1 @@ +1 2 3 diff --git a/test/40-assignment-eval-echo.sh b/test/40-assignment-eval-echo.sh new file mode 100644 index 0000000..0bad8d8 --- /dev/null +++ b/test/40-assignment-eval-echo.sh @@ -0,0 +1,3 @@ +foo=bar +baz=`eval echo ${foo}` +echo $baz diff --git a/test/40-assignment-eval-echo.stdout b/test/40-assignment-eval-echo.stdout new file mode 100644 index 0000000..5716ca5 --- /dev/null +++ b/test/40-assignment-eval-echo.stdout @@ -0,0 +1 @@ +bar diff --git a/test/40-eval-echo-variable.sh b/test/40-eval-echo-variable.sh new file mode 100644 index 0000000..1d4916d --- /dev/null +++ b/test/40-eval-echo-variable.sh @@ -0,0 +1,3 @@ +foo=baz +bar=foo +eval echo '$'$bar diff --git a/test/40-eval-echo-variable.stdout b/test/40-eval-echo-variable.stdout new file mode 100644 index 0000000..7601807 --- /dev/null +++ b/test/40-eval-echo-variable.stdout @@ -0,0 +1 @@ +baz diff --git a/test/40-eval.sh b/test/40-eval.sh new file mode 100644 index 0000000..c5f9af1 --- /dev/null +++ b/test/40-eval.sh @@ -0,0 +1 @@ +eval echo 0 diff --git a/test/40-eval.stdout b/test/40-eval.stdout new file mode 100644 index 0000000..573541a --- /dev/null +++ b/test/40-eval.stdout @@ -0,0 +1 @@ +0 diff --git a/test/41-dot.sh b/test/41-dot.sh new file mode 100644 index 0000000..efd157e --- /dev/null +++ b/test/41-dot.sh @@ -0,0 +1,2 @@ +. test/data/script.sh +echo $foo diff --git a/test/41-dot.stdout b/test/41-dot.stdout new file mode 100644 index 0000000..60839a9 --- /dev/null +++ b/test/41-dot.stdout @@ -0,0 +1,3 @@ +foo:bar +bar: +bar diff --git a/test/42-sh-export.sh b/test/42-sh-export.sh new file mode 100644 index 0000000..fe5449b --- /dev/null +++ b/test/42-sh-export.sh @@ -0,0 +1,3 @@ +bar=baz +export baz +sh test/data/script.sh diff --git a/test/42-sh-export.stdout b/test/42-sh-export.stdout new file mode 100644 index 0000000..1d269f3 --- /dev/null +++ b/test/42-sh-export.stdout @@ -0,0 +1,2 @@ +foo:bar +bar: diff --git a/test/42-sh.sh b/test/42-sh.sh new file mode 100644 index 0000000..aeb1a25 --- /dev/null +++ b/test/42-sh.sh @@ -0,0 +1,2 @@ +sh test/data/script.sh +echo $foo diff --git a/test/42-sh.stdout b/test/42-sh.stdout new file mode 100644 index 0000000..3b93b9c --- /dev/null +++ b/test/42-sh.stdout @@ -0,0 +1,3 @@ +foo:bar +bar: + diff --git a/test/50-iohere-builtin.sh b/test/50-iohere-builtin.sh new file mode 100644 index 0000000..c6c1126 --- /dev/null +++ b/test/50-iohere-builtin.sh @@ -0,0 +1,3 @@ +\cat < bar +echo foo >> bar +cat bar +rm bar diff --git a/test/50-redirect-append.stdout b/test/50-redirect-append.stdout new file mode 100644 index 0000000..0d55bed --- /dev/null +++ b/test/50-redirect-append.stdout @@ -0,0 +1,2 @@ +foo +foo diff --git a/test/50-redirect-in-out.sh b/test/50-redirect-in-out.sh new file mode 100644 index 0000000..bf2c1ec --- /dev/null +++ b/test/50-redirect-in-out.sh @@ -0,0 +1,3 @@ +cat < test/data/foo > bar +cat bar +rm bar diff --git a/test/50-redirect-in-out.stdout b/test/50-redirect-in-out.stdout new file mode 100644 index 0000000..86e041d --- /dev/null +++ b/test/50-redirect-in-out.stdout @@ -0,0 +1,3 @@ +foo +bar +baz diff --git a/test/50-redirect-in.sh b/test/50-redirect-in.sh new file mode 100644 index 0000000..9e18426 --- /dev/null +++ b/test/50-redirect-in.sh @@ -0,0 +1 @@ +\cat < test/data/foo diff --git a/test/50-redirect-merge.sh b/test/50-redirect-merge.sh new file mode 100644 index 0000000..79e7a7c --- /dev/null +++ b/test/50-redirect-merge.sh @@ -0,0 +1,5 @@ +set +e +ls /bin/sh /bin/foo > bar 2>&1 +echo foo +cat bar +rm bar diff --git a/test/50-redirect-merge.stdout b/test/50-redirect-merge.stdout new file mode 100644 index 0000000..4e95736 --- /dev/null +++ b/test/50-redirect-merge.stdout @@ -0,0 +1,3 @@ +foo +ls: cannot access '/bin/foo': No such file or directory +/bin/sh diff --git a/test/50-redirect-pipe.sh b/test/50-redirect-pipe.sh new file mode 100644 index 0000000..8c809e4 --- /dev/null +++ b/test/50-redirect-pipe.sh @@ -0,0 +1 @@ +echo foo | grep foo 2>/dev/null diff --git a/test/50-redirect-pipe.stdout b/test/50-redirect-pipe.stdout new file mode 100644 index 0000000..257cc56 --- /dev/null +++ b/test/50-redirect-pipe.stdout @@ -0,0 +1 @@ +foo diff --git a/test/50-redirect-sed.sh b/test/50-redirect-sed.sh new file mode 100644 index 0000000..754d581 --- /dev/null +++ b/test/50-redirect-sed.sh @@ -0,0 +1,5 @@ +sed \ + -e "s,^#! /bin/sh,#! /bin/gash," \ + test/data/diff.scm > $DESTDIR/tmp/diff.scm +cat $DESTDIR/tmp/diff.scm +rm $DESTDIR/tmp/diff.scm diff --git a/test/50-redirect-sed.stdout b/test/50-redirect-sed.stdout new file mode 100644 index 0000000..800bdd8 --- /dev/null +++ b/test/50-redirect-sed.stdout @@ -0,0 +1,3 @@ +#! /bin/gash +!# + diff --git a/test/50-redirect-space.sh b/test/50-redirect-space.sh new file mode 100644 index 0000000..fe40da0 --- /dev/null +++ b/test/50-redirect-space.sh @@ -0,0 +1,3 @@ +echo foo > bar +cat bar +rm bar diff --git a/test/50-redirect-space.stdout b/test/50-redirect-space.stdout new file mode 100644 index 0000000..257cc56 --- /dev/null +++ b/test/50-redirect-space.stdout @@ -0,0 +1 @@ +foo diff --git a/test/50-redirect.sh b/test/50-redirect.sh new file mode 100644 index 0000000..da5cff4 --- /dev/null +++ b/test/50-redirect.sh @@ -0,0 +1,3 @@ +echo foo 1>./bar +cat bar +rm bar diff --git a/test/50-redirect.stdout b/test/50-redirect.stdout new file mode 100644 index 0000000..257cc56 --- /dev/null +++ b/test/50-redirect.stdout @@ -0,0 +1 @@ +foo diff --git a/test/60-function-at.sh b/test/60-function-at.sh new file mode 100644 index 0000000..e16cc62 --- /dev/null +++ b/test/60-function-at.sh @@ -0,0 +1,8 @@ +foo () { + echo $#:$@ + echo 0:$0 + echo 1:$1 + echo 2:$2 +} + +foo -v $@ diff --git a/test/60-function-at.stdout b/test/60-function-at.stdout new file mode 100644 index 0000000..4c6f217 --- /dev/null +++ b/test/60-function-at.stdout @@ -0,0 +1,4 @@ +5:-v -s --long file0 file1 +0:test/60-function-at.sh +1:-v +2:-s diff --git a/test/60-function.sh b/test/60-function.sh new file mode 100644 index 0000000..4b0ef4b --- /dev/null +++ b/test/60-function.sh @@ -0,0 +1,8 @@ +foo () { + echo $1 +} + +echo before +foo bar +foo baz +echo after diff --git a/test/60-function.stdout b/test/60-function.stdout new file mode 100644 index 0000000..1de9ad8 --- /dev/null +++ b/test/60-function.stdout @@ -0,0 +1,4 @@ +before +bar +baz +after diff --git a/test/60-subst.sh b/test/60-subst.sh new file mode 100644 index 0000000..8d220d8 --- /dev/null +++ b/test/60-subst.sh @@ -0,0 +1,9 @@ +subst () { + sed \ + -e s",foo,bar,"\ + $1 > $2 +} + +subst test/data/foo foo.tmp +cat foo.tmp +rm foo.tmp diff --git a/test/70-hash-hash.sh b/test/70-hash-hash.sh new file mode 100644 index 0000000..bdbec5c --- /dev/null +++ b/test/70-hash-hash.sh @@ -0,0 +1,2 @@ +file=dir/sub/name.ext +echo ${file##*/} diff --git a/test/70-hash-hash.stdout b/test/70-hash-hash.stdout new file mode 100644 index 0000000..a6726fb --- /dev/null +++ b/test/70-hash-hash.stdout @@ -0,0 +1 @@ +name.ext diff --git a/test/70-hash.sh b/test/70-hash.sh new file mode 100644 index 0000000..b4b9c02 --- /dev/null +++ b/test/70-hash.sh @@ -0,0 +1,2 @@ +file=dir/sub/name.ext +echo ${file#*/} diff --git a/test/70-hash.stdout b/test/70-hash.stdout new file mode 100644 index 0000000..2d658b6 --- /dev/null +++ b/test/70-hash.stdout @@ -0,0 +1 @@ +sub/name.ext diff --git a/test/70-percent-percent.sh b/test/70-percent-percent.sh new file mode 100644 index 0000000..47dcc3c --- /dev/null +++ b/test/70-percent-percent.sh @@ -0,0 +1,2 @@ +file=dir/sub/name.ext +echo ${file%%/*} diff --git a/test/70-percent-percent.stdout b/test/70-percent-percent.stdout new file mode 100644 index 0000000..0d2ecd7 --- /dev/null +++ b/test/70-percent-percent.stdout @@ -0,0 +1 @@ +dir diff --git a/test/70-percent-space.sh b/test/70-percent-space.sh new file mode 100644 index 0000000..512072d --- /dev/null +++ b/test/70-percent-space.sh @@ -0,0 +1,2 @@ +args="--prefix=/usr " +echo ${args% *}/ diff --git a/test/70-percent-space.stdout b/test/70-percent-space.stdout new file mode 100644 index 0000000..bc89cc9 --- /dev/null +++ b/test/70-percent-space.stdout @@ -0,0 +1 @@ +--prefix=/usr/ diff --git a/test/70-percent.sh b/test/70-percent.sh new file mode 100644 index 0000000..af50281 --- /dev/null +++ b/test/70-percent.sh @@ -0,0 +1,2 @@ +file=dir/sub/name.ext +echo ${file%/*} diff --git a/test/70-percent.stdout b/test/70-percent.stdout new file mode 100644 index 0000000..86da852 --- /dev/null +++ b/test/70-percent.stdout @@ -0,0 +1 @@ +dir/sub diff --git a/test/70-slash-string-slash.sh b/test/70-slash-string-slash.sh new file mode 100644 index 0000000..4b4c961 --- /dev/null +++ b/test/70-slash-string-slash.sh @@ -0,0 +1,2 @@ +var='xxfooxx' +echo "${var/foo/bar/}" diff --git a/test/70-slash-string.sh b/test/70-slash-string.sh new file mode 100644 index 0000000..731949c --- /dev/null +++ b/test/70-slash-string.sh @@ -0,0 +1,2 @@ +var='xxfooxx' +echo "${var/foo/bar}" diff --git a/test/70-slash-string.stdout b/test/70-slash-string.stdout new file mode 100644 index 0000000..354f98b --- /dev/null +++ b/test/70-slash-string.stdout @@ -0,0 +1 @@ +xxbarxx diff --git a/test/70-slash.sh b/test/70-slash.sh new file mode 100644 index 0000000..717a26c --- /dev/null +++ b/test/70-slash.sh @@ -0,0 +1,2 @@ +var='xxfooxx' +echo "${var/foo}" diff --git a/test/70-slash.stdout b/test/70-slash.stdout new file mode 100644 index 0000000..63fc813 --- /dev/null +++ b/test/70-slash.stdout @@ -0,0 +1 @@ +xxxx diff --git a/test/data/basename.sed b/test/data/basename.sed new file mode 100644 index 0000000..86b8772 --- /dev/null +++ b/test/data/basename.sed @@ -0,0 +1,13 @@ +/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q diff --git a/test/data/diff.scm b/test/data/diff.scm new file mode 100644 index 0000000..c7efd07 --- /dev/null +++ b/test/data/diff.scm @@ -0,0 +1,3 @@ +#! /bin/sh +!# + diff --git a/test/data/foo b/test/data/foo new file mode 100644 index 0000000..86e041d --- /dev/null +++ b/test/data/foo @@ -0,0 +1,3 @@ +foo +bar +baz diff --git a/test/data/fooRbar b/test/data/fooRbar new file mode 100644 index 0000000..6bb06cc --- /dev/null +++ b/test/data/fooRbar @@ -0,0 +1,2 @@ +foo\rbar +foo bar diff --git a/test/data/ro.tar b/test/data/ro.tar new file mode 100644 index 0000000..82ff88a Binary files /dev/null and b/test/data/ro.tar differ diff --git a/test/data/script.sh b/test/data/script.sh new file mode 100644 index 0000000..ffcb69c --- /dev/null +++ b/test/data/script.sh @@ -0,0 +1,3 @@ +foo=bar +echo foo:$foo +echo bar:$bar diff --git a/test/data/star/0 b/test/data/star/0 new file mode 100644 index 0000000..573541a --- /dev/null +++ b/test/data/star/0 @@ -0,0 +1 @@ +0 diff --git a/test/data/star/1 b/test/data/star/1 new file mode 100644 index 0000000..d00491f --- /dev/null +++ b/test/data/star/1 @@ -0,0 +1 @@ +1 diff --git a/test/data/star/2 b/test/data/star/2 new file mode 100644 index 0000000..0cfbf08 --- /dev/null +++ b/test/data/star/2 @@ -0,0 +1 @@ +2 diff --git a/test/data/star/3 b/test/data/star/3 new file mode 100644 index 0000000..00750ed --- /dev/null +++ b/test/data/star/3 @@ -0,0 +1 @@ +3 diff --git a/test/for-done-subshell.stdout b/test/for-done-subshell.stdout new file mode 100644 index 0000000..573541a --- /dev/null +++ b/test/for-done-subshell.stdout @@ -0,0 +1 @@ +0 diff --git a/todo/case b/todo/case new file mode 100644 index 0000000..0cfeb5a --- /dev/null +++ b/todo/case @@ -0,0 +1,4 @@ +case "$1" in + 1) echo foo;; + *) echo bar;; +esac diff --git a/todo/for.sh b/todo/for.sh new file mode 100644 index 0000000..5789d8d --- /dev/null +++ b/todo/for.sh @@ -0,0 +1 @@ +for f in test/*.sh; do echo "$f:" | grep '.sh' ; done diff --git a/todo/ifthen.sh b/todo/ifthen.sh new file mode 100644 index 0000000..b70af03 --- /dev/null +++ b/todo/ifthen.sh @@ -0,0 +1 @@ +if test -e TODO; then echo exists; echo I think; fi diff --git a/todo/ifthenelse.sh b/todo/ifthenelse.sh new file mode 100644 index 0000000..38e5a8c --- /dev/null +++ b/todo/ifthenelse.sh @@ -0,0 +1 @@ +if test -e TOD; then echo exists; else echo "nope it don't"; fi diff --git a/todo/iohere b/todo/iohere new file mode 100644 index 0000000..15ff922 --- /dev/null +++ b/todo/iohere @@ -0,0 +1,3 @@ +cat <