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

Merge branch 'gash' 

This commit brings in the entire history of the Gash project.  There
are a few conflicts, which are explained below.

* .dir-locals.el: Combine both files.
* .gitignore: Combine both files.
* COPYING: Use the Geesh version with HTTPS URLs.
* README: Use the Gash README.
* guix.scm: Use the Geesh package definition (the Gash one is
preserved in gash.guix.scm).
This commit is contained in:
Timothy Sample 2018-12-13 13:42:21 -05:00
parent 110167674e 1cda08dd4a
commit 23e53f4e49
317 changed files with 9921 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
.dir-locals.el
View File

@ -1,6 +1,17 @@
((scheme-mode
((nil
.
((eval . (put '<sh-case> '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 '<sh-case> 'scheme-indent-function 1))
(eval . (put '<sh-defun> 'scheme-indent-function 1))
(eval . (put '<sh-exec-let> 'scheme-indent-function 1))
(eval . (put '<sh-for> 'scheme-indent-function 1))

43
.gitignore vendored
View File

@ -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

1
07-variable-or-slash.stdout Normal file
View File

@ -0,0 +1 @@
bar/

1
70-slash-string-slash.stdout Normal file
View File

@ -0,0 +1 @@
xxbar/xx

15
AUTHORS Normal file
View File

@ -0,0 +1,15 @@
Rutger EW van Beusekom <rutger.van.beusekom@gmail.com>
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

23
HACKING Normal file
View File

@ -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'

29
INSTALL Normal file
View File

@ -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

21
README
View File

@ -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

14
TODO Normal file
View File

@ -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:

24
bin/builtin.in Normal file
View File

@ -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 <rutger.van.beusekom@gmail.com>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define (main args)
(apply (@@ (gash commands @builtin@) main) args))

25
bin/gash.in Normal file
View File

@ -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 <rutger.van.beusekom@gmail.com>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define (main args)
(setenv "SHELL" ((compose canonicalize-path car command-line)))
((@ (gash gash) main) (command-line)))

134
build-aux/build-guile.sh Executable file
View File

@ -0,0 +1,134 @@
#! /bin/sh
# Gash --- Guile As SHell
# Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Gash.
#
# Gash is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Gash is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License
# along with Gash. If not, see <http://www.gnu.org/licenses/>.
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

45
build-aux/pre-inst-env.in Normal file
View File

@ -0,0 +1,45 @@
#! @BASH@
# Gash --- Guile As SHell
# Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Gash.
#
# Gash is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Gash is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License
# along with Gash. If not, see <http://www.gnu.org/licenses/>.
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 "$@"

41
build-aux/trace.sh Normal file
View File

@ -0,0 +1,41 @@
# Gash --- Guile As SHell
# Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
#
# This file is part of Gash.
#
# Gash is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Gash is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License
# along with Gash. If not, see <http://www.gnu.org/licenses/>.
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

202
check.sh Executable file
View File

@ -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

129
configure vendored Executable file
View File

@ -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 <<EOF
BASH=$BASH
GUILE=$GUILE
GUILD=$GUILD
prefix=$PREFIX
bindir=$PREFIX/bin
docdir=$PREFIX/share/doc/gash
guile_effective_version=$guile_effective_version
guile_site_dir=$guile_site_dir
guile_site_ccache_dir=$guile_site_ccache_dir
MAKEINFO=$MAKEINFO
SHELL=$BASH
VERSION=$VERSION
EOF
BZIP2=$(command -v bzip2)
COMPRESS=$(command -v compress)
[ -z "$COMPRESS" ] && COMPRESS=$PWD/bin/compress
GZIP=$(command -v gzip)
XZ=$(command -v xz)
subst () {
sed \
-e s,"@srcdest@,$srcdest,"\
-e s,"@srcdir@,$srcdir,"\
-e s,"@abs_top_srcdir@,$abs_top_srcdir,"\
-e s,"@abs_top_builddir@,$abs_top_builddir,"\
-e s,"@top_builddir@,$top_builddir,"\
-e s",@BASH@,$BASH,"\
-e s",@GUILE@,$GUILE,"\
-e s,"@prefix@,$prefix,"\
-e s",@guile_site_dir@,$guile_site_dir,"\
-e s",@guile_site_ccache_dir@,$guile_site_ccache_dir,"\
-e s",@BZIP2@,$BZIP2,"\
-e s",@COMPRESS@,$COMPRESS,"\
-e s",@GZIP@,$GZIP,"\
-e s",@XZ@,$XZ,"\
-e s",@VERSION@,$VERSION,"\
-e s",@guile_site_dir@,$guile_site_dir,"\
-e s",@guile_site_ccache_dir@,$guile_site_ccache_dir,"\
-e s",@builtin@,$builtin,"\
$1 > $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 <<EOF
Run:
make to build gash
make help for help on other targets
EOF

505
doc/fdl-1.3.texi Normal file
View File

@ -0,0 +1,505 @@
@c The GNU Free Documentation License.
@center Version 1.3, 3 November 2008
@c This file is intended to be included within another document,
@c hence no sectioning command or @node.
@display
Copyright @copyright{} 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc.
@uref{http://fsf.org/}
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
@end display
@enumerate 0
@item
PREAMBLE
The purpose of this License is to make a manual, textbook, or other
functional and useful document @dfn{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.
@item
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, La@TeX{} 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.
@item
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.
@item
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.
@item
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:
@enumerate A
@item
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.
@item
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.
@item
State on the Title page the name of the publisher of the
Modified Version, as the publisher.
@item
Preserve all the copyright notices of the Document.
@item
Add an appropriate copyright notice for your modifications
adjacent to the other copyright notices.
@item
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.
@item
Preserve in that license notice the full lists of Invariant Sections
and required Cover Texts given in the Document's license notice.
@item
Include an unaltered copy of this License.
@item
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.
@item
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.
@item
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.
@item
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.
@item
Delete any section Entitled ``Endorsements''. Such a section
may not be included in the Modified Version.
@item
Do not retitle any existing section to be Entitled ``Endorsements'' or
to conflict in title with any Invariant Section.
@item
Preserve any Warranty Disclaimers.
@end enumerate
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.
@item
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.''
@item
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.
@item
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.
@item
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.
@item
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.
@item
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
@uref{http://www.gnu.org/copyleft/}.
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.
@item
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.
@end enumerate
@page
@heading 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:
@smallexample
@group
Copyright (C) @var{year} @var{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''.
@end group
@end smallexample
If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
replace the ``with@dots{}Texts.''@: line with this:
@smallexample
@group
with the Invariant Sections being @var{list their titles}, with
the Front-Cover Texts being @var{list}, and with the Back-Cover Texts
being @var{list}.
@end group
@end smallexample
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.
@c Local Variables:
@c ispell-local-pdict: "ispell-dict"
@c End:

588
doc/gash.info Normal file
View File

@ -0,0 +1,588 @@
This is gash.info, produced by makeinfo version 6.5 from gash.texi.
Copyright © 2018 Rutger EW van Beusekom
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”.
INFO-DIR-SECTION Basics
START-INFO-DIR-ENTRY
* Gash: (gash). Guile As SHell.
* gash: (gash)Invoking gash. Running Gash, a minimalist Bash lookalike.
END-INFO-DIR-ENTRY

File: gash.info, Node: Top, Next: Introduction, Up: (dir)
Gash
****
This document describes Gash version 0.1, 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.
— The Detailed Node Listing —
Introduction
* Invoking Gash::

File: gash.info, Node: Introduction, Next: GNU Free Documentation License, Prev: Top, Up: Top
1 Introduction
**************
* Menu:
* Invoking Gash::

File: gash.info, Node: Invoking Gash, Up: Introduction
1.1 Invoking Gash
=================
The ‘gash’ command is the sh interpreter.
gash OPTION... FILE
The OPTIONs can be among the following:
‘-c STRING’
By default, Gash will read a file named on the command line as a
script.
‘-h, --help’
Display help on invoking Gash, and then exit.
‘-v, --version’
Display the current version of Gash, and then exit.

File: gash.info, Node: GNU Free Documentation License, Next: Concept Index, Prev: Introduction, Up: Top
Appendix A GNU Free Documentation License
*****************************************
Version 1.3, 3 November 2008
Copyright © 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc.
<http://fsf.org/>
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
<http://www.gnu.org/copyleft/>.
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:

122
doc/gash.texi Normal file
View File

@ -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:

195
gash.guix.scm Normal file
View File

@ -0,0 +1,195 @@
;;; guix.scm -- Guix package definition
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2017,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Also borrowing code from:
;;; guile-sdl2 --- FFI bindings for SDL2
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
;;; 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

128
gash/bournish-commands.scm Normal file
View File

@ -0,0 +1,128 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial bournish.scm was taken from Guix.
;;; Code:
(define-module (gash bournish-commands)
#:use-module (srfi srfi-26)
#:use-module (gash io)
#:use-module (gash config)
#:use-module (gash shell-utils)
#:use-module ((gash commands basename) #:prefix gash:)
#:use-module (gash commands cat)
#:use-module (gash commands compress)
#:use-module (gash commands cp)
#:use-module ((gash commands dirname) #:prefix gash:)
#:use-module (gash commands find)
#:use-module (gash commands grep)
#:use-module (gash commands ls)
#:use-module (gash commands mkdir)
#:use-module (gash commands mv)
#:use-module (gash commands reboot)
#:use-module (gash commands rm)
#:use-module (gash commands sed)
#:use-module (gash commands tar)
#:use-module (gash commands touch)
#:use-module (gash commands tr)
#:use-module (gash commands wc)
#:use-module (gash commands which)
#:export (
%bournish-commands
basename-command
cat-command
compress-command
cp-command
dirname-command
find-command
grep-command
ls-command
mkdir-command
mv-command
reboot-command
rm-command
sed-command
tar-command
touch-command
tr-command
rm-command
wc-command
which-command
))
(define (wrap-command name command)
(lambda args
(lambda _
(catch #t
(cut apply command (cons name args))
(lambda (key . args)
(format (current-error-port) "~a: ~a ~a\n" name key args)
(case key
((quit) (car args))
(else 1)))))))
(define basename-command (wrap-command "basename" gash:basename))
(define cat-command (wrap-command "cat" cat))
(define compress-command (wrap-command "compress" compress))
(define cp-command (wrap-command "cp" cp))
(define dirname-command (wrap-command "dirname" gash:dirname))
(define find-command (wrap-command "find" find))
(define grep-command (wrap-command "grep" grep))
(define ls-command (wrap-command "ls" ls))
(define mkdir-command (wrap-command "mkdir" mkdir'))
(define mv-command (wrap-command "mv" mv))
(define reboot-command (wrap-command "reboot" reboot'))
(define rm-command (wrap-command "rm" rm))
(define rmdir-command (wrap-command "rmdir" rmdir))
(define sed-command (wrap-command "sed" sed))
(define tar-command (wrap-command "tar" tar))
(define touch-command (wrap-command "touch" touch))
(define tr-command (wrap-command "tr" tr))
(define wc-command (wrap-command "wc" wc))
(define which-command (wrap-command "which" which))
(define (%bournish-commands)
`(
("basename" . ,basename-command)
("cat" . ,cat-command)
("compress" . ,compress-command)
("cp" . ,cp-command)
("dirname" . ,dirname-command)
("find" . ,find-command)
("grep" . ,grep-command)
("ls" . ,ls-command)
("mkdir" . ,mkdir-command)
("mv" . ,mv-command)
("reboot" . ,reboot-command)
("rm" . ,rm-command)
("rmdir" . ,rmdir-command)
("sed" . ,sed-command)
("tar" . ,tar-command)
("touch" . ,touch-command)
("tr" . ,tr-command)
("wc" . ,wc-command)
("which" . ,which-command)
))

396
gash/builtins.scm Normal file
View File

@ -0,0 +1,396 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash 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 <FIXME>\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)
))

77
gash/commands/basename.scm Normal file
View File

@ -0,0 +1,77 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (gash commands basename)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 receive)
#:use-module (gash config)
#:export (
basename
))
(define (basename . args)
(let* ((option-spec
'((multiple (single-char #\a))
(help (single-char #\h))
(version (single-char #\V))
(suffix (single-char #\s) (value #t))
(zero (single-char #\z))))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(suffix (option-ref options 'suffix #f))
(mutliple? (or suffix (option-ref options 'multiple #f)))
(zero? (option-ref options 'zero #f))
(files (option-ref options '() '()))
(usage? (and (not help?) (null? files))))
(cond (version? (format #t "basename (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: basename NAME [SUFFIX]
or: basename OPTION... NAME...
Options:
-a, --multiple support multiple arguments and treat each as a NAME
--help display this help and exit
-s, --suffix=SUFFIX remove a trailing SUFFIX; implies -a
--version output version information and exit
-z, --zero end each output line with NUL, not newline
")
(exit (if usage? 2 0)))
(else
(receive (files suffix)
(if suffix (values files suffix)
(values (list-head files 1) (and (pair? (cdr files)) (cadr files))))
(for-each (lambda (file)
(let ((file
(if (and (> (string-length file) 1)
(string-suffix? "/" file)) (string-drop-right file 1)
file)))
(cond ((string=? file "/") (display "/"))
(suffix (display ((@ (guile) basename) file suffix)))
(else (display ((@ (guile) basename) file)))))
(if zero? (display #\nul) (newline)))
files))))))
(define main basename)

41
gash/commands/cat.scm Normal file
View File

@ -0,0 +1,41 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands cat)
#:use-module (srfi srfi-1)
#:use-module (gash shell-utils)
#:export (cat))
(define (cat name . args)
(fold (lambda (file p)
(if (string=? file "-") (dump-port (current-input-port) (current-output-port))
(call-with-input-file file
(lambda (port)
(dump-port port (current-output-port))))))
0 (if (null? args) '("-") args)))
(define main cat)

99
gash/commands/chmod.scm Normal file
View File

@ -0,0 +1,99 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (gash commands chmod)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash guix-utils)
#:use-module (gash shell-utils)
#:export (
chmod
))
(define (chmod . args)
(let* ((option-spec
'((reference (value #t))
(recursive (single-char #\R))
(help (single-char #\h))
(version (single-char #\V))
(writable (single-char #\w))
(readable (single-char #\r))
(executable (single-char #\x))
(xecutable (single-char #\X))))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(reference (option-ref options 'reference #f))
(readable? (option-ref options 'readable #f))
(writable? (option-ref options 'writable #f))
(executable? (option-ref options 'executable? #f))
(xecutable? (option-ref options 'xecutable? #f))
(usage? (and (not help?)
(< (length files) (if (or reference
readable?
writable?
executable?
xecutable?) 1 2)))))
(cond (version? (format #t "chmod (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: chmod [OPTION]... {MODE | --reference=REF_FILE} FILE...
Change the mode of each FILE to MODE.
With --reference, change the mode of each FILE to that of RFILE.
Options:
--help display this help and exit
-R, --recursive change files and directories recursively
--reference=FILE use FILE's mode instead of MODE values
--version output version information and exit
Each MODE is of the form '[ugoa]*([-+=]([rwxXst]*|[ugo]))+|[-+=][0-7]+'.
")
(exit (if usage? 2 0)))
(else
(receive (modifiers files)
(cond
(reference (values (list (make-numeric-chmodifier
(stat:mode (stat reference)))) files))
((or readable? writable? executable? xecutable?)
(let* ((m '())
(m (if readable? (cons (make-chmodifier 'o '- '(r)) m) m))
(m (if writable? (cons (make-chmodifier 'o '- '(w)) m) m))
(m (if executable? (cons (make-chmodifier 'o '- '(x)) m) m))
(m (if xecutable? (cons (make-chmodifier 'o '- '(X)) m) m)))
(values m files)))
(else (values (parse-chmodifiers (car files)) (cdr files))))
(let ((files (if (not (option-ref options 'recursive #f)) files
(append-map (cut find-files <> #:directories? #t) files))))
(for-each (cut apply-chmodifiers <> modifiers) (reverse files))))))))
(define main chmod)

68
gash/commands/compress.scm Normal file
View File

@ -0,0 +1,68 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (gash commands compress)
#:use-module (ice-9 getopt-long)
#:use-module (srfi srfi-1)
#:use-module (gash config)
#:use-module (gash compress)
#:use-module (gash guix-utils)
#:export (
compress
))
(define (compress . args)
(let* ((option-spec
'((bits (single-char #\b) (value #t))
(decompress (single-char #\d))
(help (single-char #\h))
(stdout (single-char #\c))
(verbose (single-char #\v))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(bits (string->number (option-ref options 'bits "16")))
(decompress? (option-ref options 'decompress #f))
(stdout? (option-ref options 'stdout #f))
(files (option-ref options '() '()))
(help? (option-ref options 'help #f))
(usage? (and (not help?) (or (and (null? files) (isatty? (current-input-port))))))
(verbose? (option-ref options 'verbose #f))
(version? (option-ref options 'version #f)))
(cond (version? (format #t "compress (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: compress [OPTION]... [FILE]...
-b, --bits=BITS use a maximum of BITS bits per code [16]
-c, --stdout write on standard output, keep original files unchanged
-d, --decompress decompress
-h, --help display this help
-v, --verbose show compression ratio
-V, --version display version
")
(exit (if usage? 2 0)))
(decompress? (if (pair? files) (uncompress-file (car files) verbose?)
(uncompress-port (current-input-port) (current-output-port) verbose?)))
(else (if (pair? files) (compress-file (car files) bits verbose?)
(compress-port (current-input-port) (current-output-port) bits verbose?))))))
(define main compress)

84
gash/commands/cp.scm Normal file
View File

@ -0,0 +1,84 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands cp)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash shell-utils)
#:export (
cp
))
(define (copy-file-force? force?)
(lambda (src dest)
(if (not force?) (copy-file src dest)
(catch 'system-error
(lambda _
(copy-file src dest))
(lambda (key func fmt msg errno . rest)
(format #t "errno:~s\n" (car errno))
(match errno
((13)
(delete-file dest)
(copy-file src dest))
(_ (throw key func fmt msg errno))))))))
(define (cp name . args)
(define (usage port)
(display "Usage: cp [OPTION]... SOURCE... DEST
Options:
-f, --force if an existing destination file cannot be opened,
remove it and try again
-h, --help display this help and exit
-V, --version display version information and exit
" port))
(match args
(((or "-f" "--force") args ...)
(apply cp (cons 'force args)))
(((or "-h" "--help") t ...)
(usage (current-output-port))
(exit 0))
(((or "-V" "--version") t ...)
(format #t "cp (GASH) ~a\n" %version) (exit 0))
((source (and (? directory-exists?) dir))
((copy-file-force? (eq? name 'force))
source (string-append dir "/" (basename source))))
((source dest)
((copy-file-force? (eq? name 'force)) source dest))
((sources ... dir)
(unless (directory-exists? dir)
(error (format #f "mv: target `~a' is not a directory\n" dir)))
(for-each
(copy-file-force? (eq? name 'force))
sources
(map (compose (cute string-append dir "/" <>) basename)
sources)))
(_ (usage (current-error-port)) (exit 2))))
(define main cp)

62
gash/commands/dirname.scm Normal file
View File

@ -0,0 +1,62 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (gash commands dirname)
#:use-module (ice-9 getopt-long)
#:use-module (gash config)
#:export (
dirname
))
(define (dirname . args)
(let* ((option-spec
'((help (single-char #\h))
(version (single-char #\V))
(zero (single-char #\z))))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(zero? (option-ref options 'zero #f))
(usage? (and (not help?) (null? files))))
(cond (version? (format #t "dirname (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: dirname [OPTION] NAME...
Output each NAME with its last non-slash component and trailing slashes
removed; if NAME contains no /'s, output '.' (meaning the current directory).
Options:
--help display this help and exit
--version output version information and exit
-z, --zero end each output line with NUL, not newline
")
(exit (if usage? 2 0)))
(else
(for-each (lambda (file)
(display ((@ (guile) dirname) file))
(if zero? (display #\nul) (newline)))
files)))))
(define main dirname)

65
gash/commands/find.scm Normal file
View File

@ -0,0 +1,65 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands find)
#:use-module (ice-9 getopt-long)
#:use-module (gash config)
#:use-module (gash io)
#:use-module (gash shell-utils)
#:export (
find
))
(define (find . args)
(let* ((option-spec
'((help)
(version)))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(files (if (null? files) '(".") files))
(file (car files)))
(when (> (length files) 1)
(format (current-error-port) "find: too many FILEs: ~s\n" files)
(error "find failed"))
;; TODO: find [OPTION]... [FILE]... [EXPRESSION]...
;; and options: esp: -x, -L
(cond (version? (format #t "find (GASH) ~a\n" %version))
(help? (display "Usage: find [OPTION]... [FILE]
Options:
--help display this help and exit
--version display version information and exit
"))
(else
(let* ((files (find-files file #:directories? #t #:fail-on-error? #t)))
(for-each stdout files))))))
(define main find)

109
gash/commands/grep.scm Normal file
View File

@ -0,0 +1,109 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (gash commands grep)
#:use-module (ice-9 ftw)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (gash guix-utils)
#:use-module (gash compress)
#:use-module (gash config)
#:use-module (gash io)
#:use-module (gash ustar)
#:use-module (gash util)
#:use-module (gash shell-utils)
#:export (
grep
))
(define (grep . args)
(let* ((option-spec
'((help)
(line-number (single-char #\n))
(files-with-matches (single-char #\l))
(files-without-match (single-char #\L))
(with-file-name (single-char #\H))
(no-file-name (single-char #\h))
(only-matching (single-char #\o))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (version? (format #t "grep (GASH) ~a\n" %version))
(help? (display "Usage: grep [OPTION]... PATTERN [FILE]...
Options:
--help display this help and exit
-h, --no-filename suppress the file name prefix on output
-H, --with-filename print file name with output lines
-l, --files-with-matches print only names of FILEs with selected lines
-L, --files-without-match print only names of FILEs with no selected lines
-n, --line-number print line number with output lines
-o, --only-matching show only the part of a line matching PATTERN
-V, --version display version information and exit
"))
((null? files) #t)
(else
(let* ((pattern (car files))
(files (if (pair? (cdr files)) (cdr files)
(list "-")))
(matches (append-map (cut grep+ pattern <>) files)))
(define (display-match o)
(let* ((s (grep-match-string o))
(s (if (option-ref options 'only-matching #f)
(substring s (grep-match-column o) (grep-match-end-column o))
s))
(s (if (option-ref options 'line-number #f)
(string-append (number->string (grep-match-line o)) ":" s)
s))
(s (if (option-ref options 'with-file-name #f)
(string-append (grep-match-file-name o) ":" s)
s)))
(stdout s)))
(define (files-with-matches)
(delete-duplicates (map grep-match-file-name matches)))
(cond ((option-ref options 'files-with-matches #f)
(let ((result (files-with-matches)))
(and (pair? result)
(for-each stdout result)
0)))
((option-ref options 'files-without-match #f)
(let* ((result (files-with-matches))
(result (filter (negate (cut member <> result)) files)))
(and (pair? result)
(for-each stdout result)
0)))
(else
(and (pair? matches)
(for-each display-match matches)
0))))))))
(define main grep)

106
gash/commands/ls.scm Normal file
View File

@ -0,0 +1,106 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands ls)
#:use-module (ice-9 ftw)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash io)
#:use-module (gash shell-utils)
#:export (
ls
))
(cond-expand
(guile
;; Support -1, see https://lists.gnu.org/archive/html/bug-guile/2018-07/msg00009.html
(module-define! (resolve-module '(ice-9 getopt-long)) 'short-opt-rx (make-regexp "^-([a-zA-Z0-9]+)(.*)")))
(else))
(define (ls . args)
(let* ((option-spec
'((all (single-char #\a))
(help)
(long (single-char #\l))
(one-file-per-line (single-char #\1))
(version)))
(options (getopt-long args option-spec))
(all? (option-ref options 'all #f))
(help? (option-ref options 'help #f))
(long? (option-ref options 'long #f))
(one-file-per-line? (option-ref options 'one-file-per-line #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (version? (format #t "ls (GASH) ~a\n" %version))
(help? (display "Usage: ls [OPTION]... [FILE]...
Options:
-a, --all do not ignore entries starting with .
--help display this help and exit
-l, --long use a long listing format
--version display version information and exit
-1 list one file per line
"))
(else
(let* ((files (if (null? files) (scandir ".")
(append-map (lambda (file)
(catch 'system-error
(lambda ()
(match (stat:type (lstat file))
('directory
;; Like GNU ls, list the contents of
;; FILE rather than FILE itself.
(match (scandir file
(match-lambda
((or "." "..") #f)
(_ #t)))
(#f
(list file))
((files ...)
(map (cut string-append file "/" <>)
files))))
(_
(list file))))
(lambda args
(let ((errno (system-error-errno args)))
(format (current-error-port) "~a: ~a~%"
file (strerror errno))
'()))))
files)))
(files (if all? files
(filter (negate (cut string-prefix? "." <>)) files))))
(cond (long? (for-each (lambda (f) (display-file f) (newline)) files))
(one-file-per-line? (for-each stdout files))
(else (display-tabulated files))))))))
(define main ls)

74
gash/commands/mkdir.scm Normal file
View File

@ -0,0 +1,74 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (gash commands mkdir)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash guix-utils)
#:use-module (gash shell-utils)
#:export (
mkdir'
))
(define (mkdir' . args)
(let* ((option-spec
'((help (single-char #\h))
(mode (single-char #\m) (value #t))
(parents (single-char #\p))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(files (option-ref options '() '()))
(mode (option-ref options 'mode #f))
(parents? (option-ref options 'parents #f))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(usage? (and (not help?) (null? files))))
(cond (version? (format #t "mkdir (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: mkdir [OPTION]... DIRECTORY...
Create the DIRECTORY(ies), if they do not already exist.
Options:
--help display this help and exit
-m, --mode=MODE set file mode (as in chmod), not a=rwx - umask
-p, --parents no error if existing, make parent directories as needed
--version output version information and exit
")
(exit (if usage? 2 0)))
(else
(let ((mode (if mode (umask (chmodifiers->mode (parse-chmodifiers mode)))
#o755)))
(for-each (if parents? mkdir-p (@ (guile) mkdir)) files))))))
(define main mkdir')

63
gash/commands/mv.scm Normal file
View File

@ -0,0 +1,63 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (gash commands mv)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash shell-utils)
#:export (
mv
))
(define (mv name . args)
(define (usage port)
(display "Usage: mv [OPTION]... SOURCE... DEST
Options:
-f, --force ignored for compatibility
-h, --help display this help and exit
-V, --version display version information and exit
" port))
(match args
(((or "-f" "--force") args ...)
(apply mv (cons name args)))
(((or "-h" "--help") t ...)
(usage (current-output-port))
(exit 0))
(((or "-V" "--version") t ...)
(format #t "mv (GASH) ~a\n" %version) (exit 0))
((source (and (? directory-exists?) dir))
(rename-file source (string-append dir "/" (basename source))))
((source dest)
(rename-file source dest))
((sources ... dir)
(unless (directory-exists? dir)
(error (format #f "mv: target `~a' is not a directory\n" dir)))
(for-each
rename-file
sources
(map (compose (cute string-append dir "/" <>) basename)
sources)))
(_ (usage (current-error-port)) (exit 2))))
(define main mv)

44
gash/commands/reboot.scm Normal file
View File

@ -0,0 +1,44 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands reboot)
#:export (
reboot'
))
(define (reboot' name . args)
"Emit code for 'reboot'."
;; Normally Bournish is used in the initrd, where 'reboot' is provided
;; directly by (guile-user). In other cases, just bail out.
(if (defined? 'reboot)
(reboot)
(begin
(format (current-error-port)
"I don't know how to reboot, sorry about that!~%")
1)))
(define main reboot')

53
gash/commands/rm.scm Normal file
View File

@ -0,0 +1,53 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands rm)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (gash shell-utils)
#:export (
rm
))
(define (rm name . args)
(let ((recursive? (or (member "-r" args)
(member "-fr" args)
(member "-rf" args)))
(force? (or (member "-f" args)
(member "-rf" args)
(member "-fr" args)))
(files (filter (negate (cut string-prefix? "-" <>)) args)))
(catch #t
(lambda _
(if recursive? (for-each delete-file-recursively files)
(for-each delete-file files))
#t)
(lambda ( . rest)
(or force?
(apply throw rest))))))
(define main rm)

71
gash/commands/rmdir.scm Normal file
View File

@ -0,0 +1,71 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (gash commands rmdir)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash guix-utils)
#:use-module (gash shell-utils)
#:export (
rmdir
))
(define (rmdir . args)
(let* ((option-spec
'((help (single-char #\h))
(parents (single-char #\p))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(files (option-ref options '() '()))
(parents? (option-ref options 'parents #f))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(usage? (and (not help?) (null? files))))
(cond (version? (format #t "rmdir (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: rmdir [OPTION]... DIRECTORY...
Remove the DIRECTORY(ies), if they are empty.
Options:
--help display this help and exit
-p, --parents remove DIRECTORY and its ancestors; e.g., 'rmdir -p a/b/c' is
similar to 'rmdir a/b/c a/b a'
--version output version information and exit
")
(exit (if usage? 2 0)))
(else
(if parents? (for-each rmdir-p files)
(for-each rmdir files))))))
(define main rmdir)

233
gash/commands/sed.scm Normal file
View File

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

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

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

168
gash/commands/tar.scm Normal file
View File

@ -0,0 +1,168 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (gash commands tar)
#:use-module (ice-9 getopt-long)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash compress)
#:use-module (gash ustar)
#:use-module (gash guix-utils)
#:use-module (gash shell-utils)
#:export (
tar
))
(define (tar . args)
(let* ((option-spec
'((create (single-char #\c))
(compress (single-char #\Z))
(directory (single-char #\C) (value #t))
(gzip (single-char #\z))
(bzip2 (single-char #\j))
(xz (single-char #\J))
(group (value #t))
(extract (single-char #\x))
(file (single-char #\f) (value #t))
(help (single-char #\h))
(mtime (value #t))
(list (single-char #\t))
(numeric-owner?)
(owner (value #t))
(sort (value #t))
(strip (value #t))
(strip-components (value #t))
(verbose (single-char #\v))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(options (if (or (option-ref options 'create #f)
(option-ref options 'extract #f)
(option-ref options 'list #f)
(null? (cdr args))
(string-prefix? "-" (cadr args))) options
(let ((args (cons* (car args)
(string-append "-" (cadr args))
(cddr args))))
(getopt-long args option-spec))))
(create? (option-ref options 'create #f))
(list? (option-ref options 'list #f))
(extract? (option-ref options 'extract #f))
(file (option-ref options 'file "-"))
(files (option-ref options '() '()))
(compress? (option-ref options 'compress #f))
(bzip2? (option-ref options 'bzip2 #f))
(gzip? (option-ref options 'gzip #f))
(xz? (option-ref options 'xz #f))
(compression (cond (bzip2? 'bzip2)
(compress? 'compress)
(gzip? 'gzip)
(xz? 'xz)
(else (and (or extract? list? )
(cond ((string-suffix? ".Z" file) 'compress)
((string-suffix? ".bz2" file) 'bzip2)
((string-suffix? ".gz" file) 'gzip)
((string-suffix? ".xz" file) 'xz)
(else #f))))))
(directory (option-ref options 'directory #f))
(sort-order (and=> (option-ref options 'sort #f) string->symbol))
(strip (string->number
(or (option-ref options 'strip #f)
(option-ref options 'strip-components #f)
"0")))
(help? (option-ref options 'help #f))
(usage? (and (not help?) (not (or (and create? (pair? files))
extract? list?))))
(verbosity (length (multi-opt options 'verbose)))
(version? (option-ref options 'version #f))
(file (if (or (not directory) (string-prefix? "/" file) (equal? file "-")) file
(string-append (getcwd) "/" file))))
(when directory
(chdir directory))
(cond (version? (format #t "tar (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: tar [OPTION]... [FILE]...
-C, --directory=DIR change to directory DIR
-c, --create create a new archive
-f, --file=ARCHIVE use archive file or device ARCHIVE
--group=NAME force NAME as group for added files
-h, --help display this help
--mtime=DATE-OR-FILE set mtime for added files from DATE-OR-FILE
--numeric-owner always use numbers for user/group names
--owner=NAME force NAME as owner for added files
--sort=ORDER directory sorting order: none (default), name or
inode
--strip-components=NUM strip NUM leading components from file names
names on extraction
-t, --list list the contents of an archive
-V, --version display version
-v, --verbose verbosely list files processed
-x, --extract extract files from an archive
-z, --gzip filter the archive through gzip
-Z, --compress filter the archive through compress
")
(exit (if usage? 2 0)))
(create?
(let ((files (if (eq? sort-order 'name) (sort files string<)
files))
(group (and=> (option-ref options 'group #f) string->number))
(mtime (and=> (option-ref options 'mtime #f) string->number))
(numeric-owner? (option-ref options 'numeric-owner? #f))
(owner (and=> (option-ref options 'owner #f) string->number)))
(if (or compression (equal? file "-"))
(let ((port (if (equal? file "-") (current-output-port)
(open-file file "wb"))))
(call-with-compressed-output-port compression port
(cut apply write-ustar-port <>
`(,files
,@(if group `(#:group ,group) '())
,@(if mtime `(#:mtime ,mtime) '())
,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '())
,@(if owner `(#:owner ,owner) '())
,@(if sort-order `(#:sort-order ,sort-order) '())
#:verbosity ,verbosity))))
(apply write-ustar-archive
`(,file
,files
,@(if group `(#:group ,group) '())
,@(if mtime `(#:mtime ,mtime) '())
,@(if numeric-owner? `(#:numeric-owner? ,numeric-owner?) '())
,@(if owner `(#:owner ,owner) '())
,@(if sort-order `(#:sort-order ,sort-order) '())
#:verbosity ,verbosity)))))
(extract?
(if (or compression (equal? file "-"))
(let ((port (if (equal? file "-") (current-input-port)
(open-file file "rb"))))
(call-with-decompressed-port compression port
(cut read-ustar-port <> files #:strip strip #:verbosity verbosity)))
(read-ustar-archive file files #:verbosity verbosity)))
(list?
(if (or compression (equal? file "-"))
(let ((port (if (equal? file "-") (current-input-port)
(open-file file "rb"))))
(call-with-decompressed-port compression port
(cut list-ustar-port <> files #:strip strip #:verbosity (1+ verbosity))))
(list-ustar-archive file files #:strip strip #:verbosity (1+ verbosity)))))))
(define main tar)

85
gash/commands/touch.scm Normal file
View File

@ -0,0 +1,85 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (gash commands touch)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (gash config)
#:use-module (gash guix-utils)
#:use-module (gash shell-utils)
#:export (
touch
))
(define (create-or-touch file time)
(let ((exists? (file-exists? file)))
(when (not exists?) (with-output-to-file file (cut display "")))
(cond (time (utime file time time))
(exists? (let ((time (current-time)))
(utime file time time))))))
(define (parse-date string)
(if (string-prefix? "@" string)
(string->number (substring string 1))
(error (format #f "touch: cannot parse date:~a\n" string))))
(define (touch . args)
(let* ((option-spec
'((date (single-char #\d) (value #t))
(help (single-char #\h))
(reference (single-char #\r) (value #t))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(date (option-ref options 'date #f))
(reference (option-ref options 'reference #f))
(files (option-ref options '() '()))
(usage? (and (not help?) (null? files))))
(cond (version? (format #t "touch (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: touch [OPTION]... FILE...
Update the access and modification times of each FILE to the current time.
Options:
-d, --date=DATE parse DATE and use it instead of current time
--help display this help and exit
-r, --reference=FILE use FILE's times instead of current time
--version output version information and exit
Each MODE is of the form '[ugoa]*([-+=]([rwxXst]*|[ugo]))+|[-+=][0-7]+'.
")
(exit (if usage? 2 0)))
(else
(let ((time (and=> date parse-date)))
(for-each (cut create-or-touch <> time) files))))))
(define main touch)

69
gash/commands/tr.scm Normal file
View File

@ -0,0 +1,69 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(define-module (gash commands tr)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 rdelim)
#:use-module (gash config)
#:use-module (gash util)
#:export (
tr
))
(define (tr . args)
(let* ((option-spec
'((delete (single-char #\d))
(help (single-char #\h))
(version (single-char #\V))))
(options (getopt-long args option-spec))
(delete? (option-ref options 'delete #f))
(files (option-ref options '() '()))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(usage? (and (not help?) (not (or (and delete? (= (length files) 1))
(= (length files) 2))))))
(cond (version? (format #t "tr (GASH) ~a\n" %version) (exit 0))
((or help? usage?) (format (if usage? (current-error-port) #t)
"\
Usage: tr [OPTION]... SET1 [SET2]
Options:
-d, --delete delete characters in SET1, do not translate
-h, --help display this help and exit
-V, --version display version information and exit
")
(exit (if usage? 2 0)))
(delete?
(let* ((s (car files))
(s (string-replace-string s "\\n" "\n"))
(s (string-replace-string s "\\r" "\r"))
(s (string-replace-string s "\\t" "\t"))
(s (string->char-set s)))
(let loop ((line (read-line (current-input-port) 'concat)))
(if (eof-object? line) #t
(begin
(display (string-delete s line))
(loop (read-line (current-input-port) 'concat)))))))
(else
(format #t "TODO: TR A B\n")))))
(define main tr)

81
gash/commands/wc.scm Normal file
View File

@ -0,0 +1,81 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands wc)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (ice-9 match)
#:use-module (gash shell-utils)
#:export (
wc
))
(define (lines+chars port)
"Return the number of lines and number of chars read from PORT."
(let loop ((lines 0) (chars 0))
(match (read-char port)
((? eof-object?) ;done!
(values lines chars))
(#\newline ;recurse
(loop (1+ lines) (1+ chars)))
(_ ;recurse
(loop lines (1+ chars))))))
(define (wc-print file)
(let-values (((lines chars)
(call-with-input-file file lines+chars)))
(format #t "~a ~a ~a~%" lines chars file)))
(define (wc-l-print file)
(let-values (((lines chars)
(call-with-input-file file lines+chars)))
(format #t "~a ~a~%" lines file)))
(define (wc-c-print file)
(let-values (((lines chars)
(call-with-input-file file lines+chars)))
(format #t "~a ~a~%" chars file)))
(define (wc- . files)
(for-each wc-print (filter file-exists?* files)))
(define (wc-l . files)
(for-each wc-l-print (filter file-exists?* files)))
(define (wc-c . files)
(for-each wc-c-print (filter file-exists?* files)))
(define (wc name . args)
(cond ((member "-l" args)
(apply wc-l (delete "-l" args)))
((member "-c" args)
(apply wc-c (delete "-c" args)))
(else
(apply wc- args))))
(define main wc)

38
gash/commands/which.scm Normal file
View File

@ -0,0 +1,38 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial bournish.scm was taken from Guix.
;;; Code:
(define-module (gash commands which)
#:use-module (gash io)
#:use-module (gash shell-utils)
#:export (
which
))
(define (which name program . rest)
(stdout (search-path (executable-path) program)))
(define main which)

162
gash/compress.scm Normal file
View File

@ -0,0 +1,162 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2013 Daniel Hartwig <mandyke@gmail.com>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial lzw.scm was taken from the Guile100 challenge
;;; https://github.com/spk121/guile100 from a contribution by Daniel
;;; Hartwig.
;;; Code:
(define-module (gash compress)
#:use-module (gash lzw)
#:use-module (ice-9 control)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-37)
#:export (compress-file
compress-port
uncompress-file
uncompress-port))
(define *program-name* "compress (GASH)")
(define (_ msg . rest)
msg)
(define (error* status msg . args)
(force-output)
(let ((port (current-error-port)))
(when *program-name*
(display *program-name* port)
(display ": " port))
(apply format port msg args)
(newline port)
(unless (zero? status)
;; This call to 'abort' causes 'main' to immediately return the
;; specified status value. Similar to 'exit' but more
;; controlled, for example, when using the REPL to debug,
;; 'abort' will not cause the entire process to terminate.
;;
;; This is also handy to attempt processing every file, even
;; after an error has occured. To do this, establish another
;; prompt at an interesting place inside 'main'.
(abort (lambda (k)
status)))))
(define (make-file-error-handler filename)
(lambda args
(error* 1 (_ "~a: ~a")
filename
(strerror (system-error-errno args)))))
(define (system-error-handler key subr msg args rest)
(apply error* 1 msg args))
(define (compression-ratio nbytes-in nbytes-out)
(exact->inexact (/ (- nbytes-in nbytes-out) nbytes-in)))
(define (write-lzw-header port bits)
(put-bytevector port (u8-list->bytevector (list #x1F #x9D bits))))
(define (compress-port in out bits verbose?)
(set-port-encoding! in "ISO-8859-1")
(set-port-encoding! out "ISO-8859-1")
#;
(begin
(write-lzw-header out bits)
(%lzw-compress (cute get-u8 in)
(cute put-u16 out <>)
eof-object?
(expt 2 bits)))
(let* ((in-bv (get-bytevector-all in))
(out-bv (lzw-compress in-bv #:table-size (expt 2 bits))))
(write-lzw-header out bits)
(put-bytevector out out-bv)))
(define (compress-file infile bits verbose?)
(catch 'system-error
(lambda ()
(let ((outfile (string-append infile ".Z")))
(when (string-suffix? ".Z" infile)
(error* 1 (_ "~a: already has .Z suffix") infile))
(when (file-exists? outfile)
(error* 1 (_ "~a: already exists") outfile))
(let ((in (open-file infile "rb"))
(out (open-file outfile "wb")))
;; TODO: Keep original files ownership, modes, and access
;; and modification times.
(compress-port in out bits verbose?)
(when verbose?
(format #; (current-error-port)
(current-output-port)
(_ "~a: compression: ~1,2h%\n") ; '~h' is localized '~f'.
infile
(* 100 (compression-ratio (port-position in)
(port-position out)))))
(for-each close-port (list in out))
(delete-file infile))))
system-error-handler))
(define (read-lzw-header port)
(match (bytevector->u8-list (get-bytevector-n port 3))
((#x1F #x9D bits)
(and (<= 9 bits 16)
(values bits)))
(x #f)))
(define (uncompress-port in out verbose?)
(set-port-encoding! in "ISO-8859-1")
(set-port-encoding! out "ISO-8859-1")
(let ((bits (read-lzw-header in)))
(unless bits
(error* 1 (_ "incorrect header")))
#;
(%lzw-uncompress (cute get-u16 in)
(cute put-u8 out <>)
eof-object?
(expt 2 bits))
(let* ((in-bv (get-bytevector-all in))
(out-bv (lzw-uncompress in-bv #:table-size (expt 2 bits))))
(put-bytevector out out-bv))))
(define (uncompress-file infile verbose?)
(catch 'system-error
(lambda ()
(let ((outfile (string-drop-right infile 2)))
(when (not (string-suffix? ".Z" infile))
(error* 1 (_ "~a: does not have .Z suffix") infile))
(when (file-exists? outfile)
(error* 1 (_ "~a: already exists") outfile))
(let ((in (open-file infile "rb"))
(out (open-file outfile "wb")))
(uncompress-port in out verbose?)
(when verbose?
(format #; (current-error-port)
(current-output-port)
(_ "~a: compression: ~1,2h%\n") ; '~h is localized '~f'.
infile
(* 100 (compression-ratio (port-position out)
(port-position in)))))
(for-each close-port (list in out))
(delete-file infile))))
system-error-handler))

57
gash/config.scm.in Normal file
View File

@ -0,0 +1,57 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash 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@")

107
gash/environment.scm Normal file
View File

@ -0,0 +1,107 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(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)))

236
gash/gash.scm Normal file
View File

@ -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 <rutger.van.beusekom@gmail.com>
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<?)))
(define (complete prefix list)
(if (string-null? prefix) list
(filter (cut string-prefix? prefix <>) 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) string<?)))
(set! next->binary-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?)))

132
gash/geesh.scm Normal file
View File

@ -0,0 +1,132 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash 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
(('<sh-begin> body ...) `(begin ,@(map transform body)))
(('<sh-pipeline> (('<sh-pipeline> (left ...))) right)
`(pipeline ,@(map transform left) ,(transform right)))
(('<sh-pipeline> ('<sh-pipeline> (left ...) right))
`(pipeline ,@(map transform left) ,(transform right)))
(('<sh-pipeline> (left right))
`(pipeline ,(transform left) ,(transform right)))
(('<sh-exec> command) `(command ,(transform command)))
(('<sh-exec> command ...) `(command ,@(map transform command)))
(((and ref ('<sh-ref> _)) words ...)
`(word ,(transform ref) ,@(map transform words)))
(('<sh-ref> var) `(variable ,var))
(('<sh-set!> (var (and value ((? symbol?) _ ...))))
`(assignment ,(transform var) ,(transform value)))
(('<sh-set!> (var (value ...)))
`(assignment ,(transform var) (word ,@(map transform value))))
(('<sh-set!> (var value)) `(assignment ,(transform var) ,(transform value)))
(((and kwote ('<sh-quote> _)) word)
`(word ,(transform kwote) ,(transform word)))
(('<sh-quote>)
`(doublequotes ""))
(('<sh-quote> words ...)
`(doublequotes (word ,@(map transform words))))
(((and quote ('<sh-quote> _)) tail ...)
`(word ,(transform quote) ,@(map transform tail)))
(('<sh-cmd-sub> cmd) `(substitution ,(transform cmd)))
(('<sh-cond> (expression then)) `(if-clause ,(transform expression) ,(transform then)))
(('<sh-with-redirects> (('<< 0 string)) pipeline)
(let ((pipeline (transform pipeline)))
`(pipeline (display ,(transform string))
,@(match pipeline
(('command command ...) `(,pipeline))
(('pipeline commands ...) commands)))))
(('<sh-for> (name (sequence)) body)
`(for ,(transform name)
(lambda _ (split ,(transform sequence)))
(lambda _ ,(transform body))))
(('<sh-for> (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)))

301
gash/grammar.scm Normal file
View File

@ -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)))

202
gash/guix-utils.scm Normal file
View File

@ -0,0 +1,202 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial guix-utils.scm was taken from Guix.
;;; Code:
(define-module (gash guix-utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (ice-9 format)
#:autoload (ice-9 popen) (open-pipe*)
#:use-module ((gash shell-utils) #:select (dump-port))
#:use-module (ice-9 match)
#:use-module (gash config)
#:export (filtered-port
compressed-port
decompressed-port
call-with-decompressed-port
compressed-output-port
call-with-compressed-output-port))
;;;
;;; Filtering & pipes.
;;;
(define (filtered-port command input)
"Return an input port where data drained from INPUT is filtered through
COMMAND (a list). In addition, return a list of PIDs that the caller must
wait. When INPUT is a file port, it must be unbuffered; otherwise, any
buffered data is lost."
(let loop ((input input)
(pids '()))
(if (file-port? input)
(match (pipe)
((in . out)
(match (primitive-fork)
(0
(dynamic-wind
(const #f)
(lambda ()
(close-port in)
(close-port (current-input-port))
(dup2 (fileno input) 0)
(close-port (current-output-port))
(dup2 (fileno out) 1)
(catch 'system-error
(lambda ()
(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))))))

24
gash/io.scm Normal file
View File

@ -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)))

175
gash/job.scm Normal file
View File

@ -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 <process>
(make-process pid command status)
process?
(pid process-pid)
(command process-command)
(status process-status set-process-status!))
(define-record-type <job>
(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 <job>
(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)))))

151
gash/lzw.scm Normal file
View File

@ -0,0 +1,151 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2013 Daniel Hartwig <mandyke@gmail.com>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial lzw.scm was taken from the Guile100 challenge
;;; https://github.com/spk121/guile100 from a contribution by Daniel
;;; Hartwig.
;;; Code:
(define-module (gash lzw)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (lzw-compress
lzw-uncompress
%lzw-compress
%lzw-uncompress))
;; This procedure adapted from an example in the Guile Reference
;; Manual.
(define (make-serial-number-generator start end)
(let ((current-serial-number (- start 1)))
(lambda ()
(and (< current-serial-number end)
(set! current-serial-number (+ current-serial-number 1))
current-serial-number))))
(define (put-u16 port k)
;; Little endian.
(put-u8 port (logand k #xFF))
(put-u8 port (logand (ash k -8) #xFF)))
(define (get-u16 port)
;; Little endian. Order of evaluation is important, use 'let*'.
(let* ((a (get-u8 port))
(b (get-u8 port)))
(if (any eof-object? (list a b))
(eof-object)
(logior a (ash b 8)))))
(define (%lzw-compress in out done? table-size)
(let ((codes (make-hash-table table-size))
(next-code (make-serial-number-generator 0 table-size))
(universe (iota 256))
(eof-code #f))
;; Populate the initial dictionary with all one-element strings
;; from the universe.
(for-each (lambda (obj)
(hash-set! codes (list obj) (next-code)))
universe)
(set! eof-code (next-code))
(let loop ((cs '()))
(let ((c (in)))
(cond ((done? c)
(unless (null? cs)
(out (hash-ref codes cs)))
(out eof-code)
(values codes))
((hash-ref codes (cons c cs))
(loop (cons c cs)))
(else
(and=> (next-code)
(cut hash-set! codes (cons c cs) <>))
(out (hash-ref codes cs))
(loop (cons c '()))))))))
(define (ensure-bv-input-port bv-or-port)
(cond ((port? bv-or-port)
bv-or-port)
((bytevector? bv-or-port)
(open-bytevector-input-port bv-or-port))
(else
(scm-error 'wrong-type-arg "ensure-bv-input-port"
"Wrong type argument in position ~a: ~s"
(list 1 bv-or-port) (list bv-or-port)))))
(define (for-each-right proc lst)
(let loop ((lst lst))
(unless (null? lst)
(loop (cdr lst))
(proc (car lst)))))
(define (%lzw-uncompress in out done? table-size)
(let ((strings (make-hash-table table-size))
(next-code (make-serial-number-generator 0 table-size))
(universe (iota 256))
(eof-code #f))
(for-each (lambda (obj)
(hash-set! strings (next-code) (list obj)))
universe)
(set! eof-code (next-code))
(let loop ((previous-string '()))
(let ((code (in)))
(unless (or (done? code)
(= code eof-code))
(unless (hash-ref strings code)
(hash-set! strings
code
(cons (last previous-string) previous-string)))
(for-each-right out
(hash-ref strings code))
(let ((cs (hash-ref strings code)))
(and=> (and (not (null? previous-string))
(next-code))
(cut hash-set! strings <> (cons (last cs)
previous-string)))
(loop cs)))))))
(define* (lzw-compress bv #:key (table-size 65536) dictionary)
(call-with-values
(lambda ()
(open-bytevector-output-port))
(lambda (output-port get-result)
(let ((dict (%lzw-compress (cute get-u8 (ensure-bv-input-port bv))
(cute put-u16 output-port <>)
eof-object?
table-size)))
(if dictionary
(values (get-result) dict)
(get-result))))))
(define* (lzw-uncompress bv #:key (table-size 65536) dictionary)
(call-with-values
(lambda ()
(open-bytevector-output-port))
(lambda (output-port get-result)
(let ((dict (%lzw-uncompress (cute get-u16 (open-bytevector-input-port bv))
(cute put-u8 output-port <>)
eof-object?
table-size)))
(if dictionary
(values (get-result) dict)
(get-result))))))

41
gash/peg.scm Normal file
View File

@ -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?))

45
gash/peg/cache.scm Normal file
View File

@ -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))))))

390
gash/peg/codegen.scm Normal file
View File

@ -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))))

97
gash/peg/simplify-tree.scm Normal file
View File

@ -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))

280
gash/peg/string-peg.scm Normal file
View File

@ -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 <peg-primary> (? (/ "*" "?" "+")))
(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)

116
gash/peg/using-parsers.scm Normal file
View File

@ -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))

191
gash/pipe.scm Normal file
View File

@ -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)

41
gash/readline.scm Normal file
View File

@ -0,0 +1,41 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; 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)

440
gash/script.scm Normal file
View File

@ -0,0 +1,440 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash 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))

541
gash/shell-utils.scm Normal file
View File

@ -0,0 +1,541 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial 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?*
<chmodifier>
make-chmodifier
chmodifier-users
chmodifier-operation
chmodifier-permissions
make-numeric-chmodifier
chmodifier->mode
chmodifiers->mode
apply-chmodifiers
parse-chmodifiers
<grep-match>
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<?)))
(define* (delete-file-recursively dir
#:key follow-mounts?)
"Delete DIR recursively, like `rm -rf', without following symlinks. Don't
follow mount points either, unless FOLLOW-MOUNTS? is true. Report but ignore
errors."
(let ((dev (stat:dev (lstat dir))))
(file-system-fold (lambda (dir stat result) ; enter?
(or follow-mounts?
(= dev (stat:dev stat))))
(lambda (file stat result) ; leaf
(delete-file file))
(const #t) ; down
(lambda (dir stat result) ; up
(rmdir dir))
(const #t) ; skip
(lambda (file stat errno result)
(format (current-error-port)
"warning: failed to delete ~a: ~a~%"
file (strerror errno)))
#t
dir
;; Don't follow symlinks.
lstat)))
(define* (dump-port in out
#:key (buffer-size 16384)
(progress (lambda (t k) (k))))
"Read as much data as possible from IN and write it to OUT, using chunks of
BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
transferred and the continuation of the transfer as a thunk."
(define buffer
(make-bytevector buffer-size))
(define (loop total bytes)
(or (eof-object? bytes)
(let ((total (+ total bytes)))
(put-bytevector out buffer 0 bytes)
(progress total
(lambda ()
(loop total
(get-bytevector-n! in buffer 0 buffer-size)))))))
;; Make sure PROGRESS is called when we start so that it can measure
;; throughput.
(progress 0
(lambda ()
(loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))
(define-immutable-record-type <grep-match>
(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 "<stdin>"))
;; 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 <chmodifier>
(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)))))))

570
gash/ustar.scm Normal file
View File

@ -0,0 +1,570 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; The initial ustar.scm was taken from the Guile100 challenge
;;; https://github.com/spk121/guile100 from a contribution by Mark H
;;; Weaver.
;;; Code:
(define-module (gash ustar)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (gash shell-utils)
#:export (read-ustar-archive
read-ustar-port
write-ustar-archive
write-ustar-port
list-ustar-archive
list-ustar-port))
(define (fmt-error fmt . args)
(error (apply format #f fmt args)))
;; Like 'string-pad-right', but for bytevectors. However, unlike
;; 'string-pad-right', truncation is not allowed here.
(define* (bytevector-pad
bv len #:optional (byte 0) (start 0) (end (bytevector-length bv)))
(when (< len (- end start))
(fmt-error
"bytevector-pad: truncation would occur: len ~a, start ~a, end ~a, bv ~s"
len start end bv))
(let ((result (make-bytevector len byte)))
(bytevector-copy! bv start result 0 (- end start))
result))
(define (bytevector-append . bvs)
(let* ((lengths (map bytevector-length bvs))
(total (fold + 0 lengths))
(result (make-bytevector total)))
(fold (lambda (bv len pos)
(bytevector-copy! bv 0 result pos len)
(+ pos len))
0 bvs lengths)
result))
(define ustar-charset
#;
(char-set-union (ucs-range->char-set #x20 #x23)
(ucs-range->char-set #x25 #x40)
(ucs-range->char-set #x41 #x5B)
(ucs-range->char-set #x5F #x60)
(ucs-range->char-set #x61 #x7B))
char-set:ascii)
(define (valid-ustar-char? c)
(char-set-contains? ustar-charset c))
(define (ustar-string n str name)
(unless (>= n (string-length str))
(fmt-error "~a is too long (max ~a): ~a" name n str))
(unless (string-every valid-ustar-char? str)
(fmt-error "~a contains unsupported character(s): ~s in ~s"
name
(string-filter (negate valid-ustar-char?) str)
str))
(bytevector-pad (string->bytevector str (make-transcoder (latin-1-codec))) n))
(define (ustar-0string n str name)
(bytevector-pad (ustar-string (- n 1) str name)
n))
(define (ustar-number n num name)
(unless (and (integer? num)
(exact? num)
(not (negative? num)))
(fmt-error "~a is not a non-negative exact integer: ~a" name num))
(unless (< num (expt 8 (- n 1)))
(fmt-error "~a is too large (max ~a): ~a" name (expt 8 (- n 1)) num))
(bytevector-pad (string->bytevector (string-pad (number->string num 8)
(- n 1)
#\0)
(make-transcoder (latin-1-codec)))
n))
(define (checksum-bv bv)
(let ((len (bytevector-length bv)))
(let loop ((i 0) (sum 0))
(if (= i len) sum
(loop (+ i 1) (+ sum (bytevector-u8-ref bv i)))))))
(define (checksum . bvs)
(fold + 0 (map checksum-bv bvs)))
(define nuls (make-bytevector 512 0))
;; read a ustar record of exactly 512 bytes.
(define (read-ustar-record port)
(get-bytevector-n port 512))
;; write a ustar record of exactly 512 bytes, starting with the
;; segment of BV between START (inclusive) and END (exclusive), and
;; padded at the end with nuls as needed.
(define* (write-ustar-record
port bv #:optional (start 0) (end (bytevector-length bv)))
(when (< 512 (- end start))
(fmt-error "write-ustar-record: record too long: start ~s, end ~s, bv ~s"
start end bv))
;; We could have used 'bytevector-pad' here,
;; but instead use a method that avoids allocation.
(put-bytevector port bv start end)
(put-bytevector port nuls 0 (- 512 (- end start))))
;; write 1024 zero bytes, which indicates the end of a ustar archive.
(define (write-ustar-footer port)
(put-bytevector port nuls)
(put-bytevector port nuls))
(define (compose-path-name dir name)
(if (or (string-null? dir)
(file-name-separator? (string-ref dir (- (string-length dir) 1))))
(string-append dir name)
(string-append dir "/" name)))
;; Like 'call-with-port', but also closes PORT if an error occurs.
(define (call-with-port* port proc)
(dynamic-wind
(lambda () #f)
(lambda () (proc port))
(lambda () (close port))))
(define (call-with-dirstream* dirstream proc)
(dynamic-wind
(lambda () #f)
(lambda () (proc dirstream))
(lambda () (closedir dirstream))))
(define (files-in-directory dir)
(call-with-dirstream* (opendir dir)
(lambda (dirstream)
(let loop ((files '()))
(let ((name (readdir dirstream)))
(cond ((eof-object? name)
(reverse files))
((member name '("." ".."))
(loop files))
(else
(loop (cons (compose-path-name dir name) files)))))))))
;; split the path into prefix and name fields for purposes of the
;; ustar header. If the entire path fits in the name field (100 chars
;; max), then leave the prefix empty. Otherwise, try to put the last
;; component into the name field and everything else into the prefix
;; field (155 chars max). If that fails, put as much as possible into
;; the prefix and the rest into the name field. This follows the
;; behavior of GNU tar when creating a ustar archive.
(define (ustar-path-name-split path orig-path)
(define (too-long)
(fmt-error "~a: file name too long" orig-path))
(let ((len (string-length path)))
(cond ((<= len 100) (values "" path))
((> len 256) (too-long))
((string-rindex path
file-name-separator?
(- len 101)
(min (- len 1) 156))
=> (lambda (i)
(values (substring path 0 i)
(substring path (+ i 1) len))))
(else (too-long)))))
(define (bv->ustar-string bv name)
(string-trim-right (bv->ustar-0string bv name) (compose zero? char->integer)))
(define (bv->ustar-number bv name)
(let ((string (bv->ustar-string bv name)))
(or (string->number string 8) 0)))
(define (bv->ustar-0string bv name)
(bytevector->string bv (make-transcoder (latin-1-codec))))
(define-immutable-record-type <ustar-header>
(make-ustar-header name
mode
uid
gid
size
mtime
checksum
;; space
type-flag
link-name
magic
version
uname
gname
dev-major
dev-minor
prefix)
ustar-header?
(name ustar-header-name )
(mode ustar-header-mode )
(uid ustar-header-uid )
(gid ustar-header-gid )
(size ustar-header-size )
(mtime ustar-header-mtime )
(checksum ustar-header-checksum )
;;(space ustar-header-space )
(type-flag ustar-header-type-flag)
(link-name ustar-header-link-name)
(magic ustar-header-magic )
(version ustar-header-version )
(uname ustar-header-uname )
(gname ustar-header-gname )
(dev-major ustar-header-dev-major)
(dev-minor ustar-header-dev-minor)
(prefix ustar-header-prefix ))
(define (ustar-header-type header)
(let ((file-types #(regular - symlink char-special block-special directory fifo))
(type (string->number (ustar-header-type-flag header))))
(when (or (not type)
(< type 0)
(>= type (vector-length file-types)))
(fmt-error "~a: unsupported file type ~a"
(ustar-header-file-name header) type))
(vector-ref file-types (string->number (ustar-header-type-flag header)))))
(define ustar-header-field-size-alist
'((name . 100)
(mode . 8)
(uid . 8)
(gid . 8)
(size . 12)
(mtime . 12)
(checksum . 7)
(space . 1)
(type-flag . 1)
(link-name . 100)
(magic . 6)
(version . 2)
(uname . 32)
(gname . 32)
(dev-major . 8)
(dev-minor . 8)
(prefix . 155)))
(define (ustar-footer? bv)
(every zero? (array->list bv)))
(define (sub-bytevector bv offset size)
(let ((sub (make-bytevector size)))
(bytevector-copy! bv offset sub 0 size)
sub))
(define (read-ustar-header port)
(define offset
(let ((offset 0))
(lambda (. args)
(if (null? args) offset
(let ((n (car args)))
(set! offset (+ offset n))
n)))))
(let ((%record (read-ustar-record port)))
(and (not (eof-object? %record))
(not (ustar-footer? %record))
(let* ((field-bv-alist
`((dummy-checksum . ,(string->utf8 " "))
,@(map
(match-lambda ((field . size)
(cons field (sub-bytevector %record (offset) (offset size)))))
ustar-header-field-size-alist)))
(checksum-fields '(name mode uid gid size mtime
dummy-checksum
type-flag link-name magic version
uname gname dev-major dev-minor
prefix))
(checksum (apply checksum (map (cut assoc-ref field-bv-alist <>)
checksum-fields)))
(header
(make-ustar-header
(bv->ustar-string (assoc-ref field-bv-alist 'name ) "file name" )
(bv->ustar-number (assoc-ref field-bv-alist 'mode ) "file mode" )
(bv->ustar-number (assoc-ref field-bv-alist 'uid ) "user id" )
(bv->ustar-number (assoc-ref field-bv-alist 'gid ) "group id" )
(bv->ustar-number (assoc-ref field-bv-alist 'size ) "file size" )
(bv->ustar-number (assoc-ref field-bv-alist 'mtime ) "modification time")
(bv->ustar-number (assoc-ref field-bv-alist 'checksum ) "checksum" )
;; (bv->ustar-string (assoc-ref field-bv-alist 'space ) "space" )
(bv->ustar-string (assoc-ref field-bv-alist 'type-flag) "type flag" )
(bv->ustar-string (assoc-ref field-bv-alist 'link-name) "link name" )
(bv->ustar-string (assoc-ref field-bv-alist 'magic ) "magic field" )
(bv->ustar-string (assoc-ref field-bv-alist 'version ) "version number" )
(bv->ustar-string (assoc-ref field-bv-alist 'uname ) "user name" )
(bv->ustar-string (assoc-ref field-bv-alist 'gname ) "group name" )
(bv->ustar-number (assoc-ref field-bv-alist 'dev-major) "dev major" )
(bv->ustar-number (assoc-ref field-bv-alist 'dev-minor) "dev minor" )
(bv->ustar-string (assoc-ref field-bv-alist 'prefix ) "directory name" ))))
(when (not (= (ustar-header-checksum header) checksum))
(error "checksum mismatch, expected: ~s, got: ~s\n"
(ustar-header-checksum header)
checksum))
header))))
(define* (write-ustar-header port path st #:key group mtime numeric-owner? owner)
(let* ((type (stat:type st))
(perms (stat:perms st))
(mtime (or mtime (stat:mtime st)))
(uid (or owner (stat:uid st)))
(gid (or group (stat:gid st)))
(uname (or (false-if-exception (passwd:name (getpwuid uid)))
""))
(gname (or (false-if-exception (group:name (getgrgid gid)))
""))
(size (case type
((regular) (stat:size st))
(else 0)))
(type-flag (case type
((regular) "0")
((symlink) "2")
((char-special) "3")
((block-special) "4")
((directory) "5")
((fifo) "6")
(else (fmt-error "~a: unsupported file type ~a"
path type))))
(link-name (case type
((symlink) (readlink path))
(else "")))
(dev-major (case type
((char-special block-special)
(quotient (stat:rdev st) 256))
(else 0)))
(dev-minor (case type
((char-special block-special)
(remainder (stat:rdev st) 256))
(else 0)))
;; Convert file name separators to slashes.
(slash-path (string-map (lambda (c)
(if (file-name-separator? c) #\/ c))
path))
;; Make the path name relative.
;; TODO: handle drive letters on windows.
(relative-path (if (string-every #\/ slash-path)
"."
(string-trim slash-path #\/)))
;; If it's a directory, add a trailing slash,
;; otherwise remove trailing slashes.
(full-path (case type
((directory) (string-append relative-path "/"))
(else (string-trim-right relative-path #\/)))))
(receive (prefix name) (ustar-path-name-split full-path path)
(let* ((%name (ustar-string 100 name "file name"))
(%mode (ustar-number 8 perms "file mode"))
(%uid (ustar-number 8 uid "user id"))
(%gid (ustar-number 8 gid "group id"))
(%size (ustar-number 12 size "file size"))
(%mtime (ustar-number 12 mtime "modification time"))
(%type-flag (ustar-string 1 type-flag "type flag"))
(%link-name (ustar-string 100 link-name "link name"))
(%magic (ustar-0string 6 "ustar" "magic field"))
(%version (ustar-string 2 "00" "version number"))
(%uname (ustar-0string 32 uname "user name"))
(%gname (ustar-0string 32 gname "group name"))
(%dev-major (ustar-number 8 dev-major "dev major"))
(%dev-minor (ustar-number 8 dev-minor "dev minor"))
(%prefix (ustar-string 155 prefix "directory name"))
(%dummy-checksum (string->utf8 " "))
(%checksum
(bytevector-append
(ustar-number
7
(checksum %name %mode %uid %gid %size %mtime
%dummy-checksum
%type-flag %link-name %magic %version
%uname %gname %dev-major %dev-minor
%prefix)
"checksum")
(string->utf8 " "))))
(write-ustar-record port
(bytevector-append
%name %mode %uid %gid %size %mtime
%checksum
%type-flag %link-name %magic %version
%uname %gname %dev-major %dev-minor
%prefix))))))
(define* (write-ustar-file port file-name #:key group mtime numeric-owner? owner sort-order verbosity)
(let* ((file-name (if (string-every file-name-separator? file-name)
file-name-separator-string
(string-trim-right file-name file-name-separator?)))
(st (lstat file-name))
(type (stat:type st))
(size (stat:size st)))
(unless (zero? verbosity)
(if (> verbosity 1) (display-file file-name st)
(display file-name))
(newline))
(write-ustar-header port file-name st #:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner)
(case type
((regular)
(call-with-port* (open-file file-name "rb")
(lambda (in)
(let ((buf (make-bytevector 512)))
(let loop ((left size))
(when (positive? left)
(let* ((asked (min left 512))
(obtained (get-bytevector-n! in buf 0 asked)))
(when (or (eof-object? obtained)
(< obtained asked))
(fmt-error "~a: file appears to have shrunk" file-name))
(write-ustar-record port buf 0 obtained)
(loop (- left obtained)))))))))
((directory)
(let* ((files (files-in-directory file-name))
(files (if (eq? sort-order 'name) (sort files string<)
files)))
(for-each (lambda (file-name) (write-ustar-file port file-name
#:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:verbosity verbosity))
files))))))
(define* (ustar-header-file-name header #:key (strip 0))
(let* ((name (ustar-header-name header))
(prefix (ustar-header-prefix header))
(file-name (if (string-null? prefix) name
(string-append prefix "/" name))))
(if (zero? strip) file-name
(string-join (list-tail (string-split file-name #\/) strip) "/"))))
(define* (read-ustar-file port header #:key (extract? #t) (strip 0))
(let* ((size (ustar-header-size header))
(file-name (ustar-header-file-name header #:strip strip))
(dir (dirname file-name))
(extract? (and extract? (not (string-null? file-name))))
(thunk (lambda _
(set-port-encoding! (current-output-port) "ISO-8859-1") ; bootstrap-guile uses default UTF-8
(let loop ((read 0))
(and (< read size)
(let ((record (read-ustar-record port)))
(and record
(let* ((read (+ read 512))
(block (if (< read size) record
(sub-bytevector record 0 (- size -512 read)))))
(when extract?
(display (bv->ustar-0string block "block")))
(loop read)))))))))
(when extract?
(mkdir-p dir))
(if extract?
(let ((mtime (ustar-header-mtime header)))
(case (ustar-header-type header)
((regular)
(if (file-exists? file-name) (delete-file file-name))
(with-output-to-file file-name thunk #:binary #t)
(utime file-name mtime mtime)
(chmod file-name (ustar-header-mode header)))
((directory)
(mkdir-p file-name)
(utime file-name mtime mtime))
((symlink) (symlink (ustar-header-link-name header) file-name ))))
(thunk))))
(define (ustar-header->stat header)
(let* ((stat-size 17)
(si (list->vector (iota stat-size)))
(st (make-vector stat-size 0)))
(vector-set! st (stat:mode si) (ustar-header-mode header))
(vector-set! st (stat:uid si) (ustar-header-uid header))
(vector-set! st (stat:gid si) (ustar-header-gid header))
(vector-set! st (stat:size si) (ustar-header-size header))
(vector-set! st (stat:mtime si) (ustar-header-mtime header))
(vector-set! st (stat:type si) (ustar-header-type header))
st))
(define* (display-header header #:key verbose?)
(let ((file-name (ustar-header-file-name header)))
(if verbose? (display-file (ustar-header-file-name header) (ustar-header->stat header))
(display file-name))
(newline)))
(define* (write-ustar-port out files #:key group mtime numeric-owner? owner sort-order verbosity)
(for-each
(cut write-ustar-file out <>
#:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:sort-order sort-order #:verbosity verbosity)
files)
(write-ustar-footer out))
(define* (write-ustar-archive file-name files #:key group mtime numeric-owner? owner sort-order verbosity)
(catch #t
(lambda _
(call-with-port* (open-file file-name "wb")
(cut write-ustar-port <> files
#:group group #:mtime mtime #:numeric-owner? numeric-owner? #:owner owner #:sort-order sort-order #:verbosity verbosity)))
(lambda (key subr message args . rest)
(false-if-exception (delete-file file-name))
(format (current-error-port) "ERROR: ~a\n"
(apply format #f message args))
(exit 1))))
(define* (read-ustar-port in files #:key (extract? #t) (strip 0) verbosity)
(let ((dirs
(let loop ((header (read-ustar-header in)) (dirs '()))
(if (not (and header (not (eof-object? header)))) dirs
(begin
(unless (zero? verbosity)
(display-header header #:verbose? (> verbosity 1)))
(read-ustar-file in header #:extract? extract? #:strip strip)
(loop (read-ustar-header in)
(if (eq? (ustar-header-type header) 'directory) (cons header dirs)
dirs)))))))
(define (chmod-header header)
(chmod (ustar-header-file-name header #:strip strip)
(ustar-header-mode header)))
(for-each chmod-header dirs)))
(define* (read-ustar-archive file-name files #:key (extract? #t) (strip 0) verbosity)
(catch #t
(lambda _
(call-with-port* (open-file file-name "rb")
(cut read-ustar-port <> files #:extract? extract? #:strip strip #:verbosity verbosity)))
(lambda (key subr message args . rest)
(format (current-error-port) "ERROR: ~a\n"
(apply format #f message args))
(exit 1))))
(define* (list-ustar-archive file-name files #:key (strip 0) verbosity)
(read-ustar-archive file-name files #:extract? #f #:strip strip #:verbosity verbosity))
(define* (list-ustar-port in files #:key (strip 0) verbosity)
(read-ustar-port in files #:extract? #f #:strip strip #:verbosity verbosity))
;;; Local Variables:
;;; mode: scheme
;;; eval: (put 'call-with-port* 'scheme-indent-function 1)
;;; eval: (put 'call-with-dirstream* 'scheme-indent-function 1)
;;; End:

52
gash/util.scm Normal file
View File

@ -0,0 +1,52 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(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)))

94
makefile Normal file
View File

@ -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

205
sh.bnf Normal file
View File

@ -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
;

25
test.sh Executable file
View File

@ -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

1
test/00-exit-0.sh Normal file
View File

@ -0,0 +1 @@
exit 0

1
test/00-exit-1.exit Normal file
View File

@ -0,0 +1 @@
1

1
test/00-exit-1.sh Normal file
View File

@ -0,0 +1 @@
exit 1

1
test/00-exit-2.exit Normal file
View File

@ -0,0 +1 @@
2

1
test/00-exit-2.sh Normal file
View File

@ -0,0 +1 @@
exit 2

1
test/00-exit-error.exit Normal file
View File

@ -0,0 +1 @@
2

2
test/00-exit-error.sh Normal file
View File

@ -0,0 +1,2 @@
set +e
ls /foo

1
test/00-exit-var.exit Normal file
View File

@ -0,0 +1 @@
2

3
test/00-exit-var.sh Normal file
View File

@ -0,0 +1,3 @@
set +e
ls /foo
exit $?

1
test/00-exit.sh Normal file
View File

@ -0,0 +1 @@
exit

1
test/01-script-$#.sh Normal file
View File

@ -0,0 +1 @@
echo $#

1
test/01-script-$#.stdout Normal file
View File

@ -0,0 +1 @@
4

2
test/01-script-$0.sh Normal file
View File

@ -0,0 +1,2 @@
echo $0

1
test/01-script-$@.sh Normal file
View File

@ -0,0 +1 @@
echo $@

1
test/01-script-$@.stdout Normal file
View File

@ -0,0 +1 @@
-s --long file0 file1

4
test/01-script-backslash-space.sh Normal file
View File

@ -0,0 +1,4 @@
echo foo\
bar baz\
bla
echo

1
test/01-script-backslash-twice.exit Normal file
View File

@ -0,0 +1 @@
2

3
test/01-script-backslash-twice.sh Normal file
View File

@ -0,0 +1,3 @@
exit \
\
2

1
test/01-script-backslash.exit Normal file
View File

@ -0,0 +1 @@
0

2
test/01-script-backslash.sh Normal file
View File

@ -0,0 +1,2 @@
exit\
0

1
test/01-script-newline.exit Normal file
View File

@ -0,0 +1 @@
2

2
test/01-script-newline.sh Normal file
View File

@ -0,0 +1,2 @@
true
exit 2

1
test/01-script-semi.exit Normal file
View File

@ -0,0 +1 @@
2

1
test/01-script-semi.sh Normal file
View File

@ -0,0 +1 @@
true; exit 2

9
test/01-script-shift.sh Normal file
View File

@ -0,0 +1,9 @@
echo $@
shift
echo $@
shift
echo $@
shift
echo $@
shift
echo $@

5
test/01-script-shift.stdout Normal file
View File

@ -0,0 +1,5 @@
-s --long file0 file1
--long file0 file1
file0 file1
file1

1
test/03-echo-brace.sh Normal file
View File

@ -0,0 +1 @@
echo foo:{bar}

1
test/03-echo-brace.stdout Normal file
View File

@ -0,0 +1 @@
foo:{bar}

1
test/03-echo-doublequotes.sh Normal file
View File

@ -0,0 +1 @@
echo "foo" b"ar"

1
test/03-echo-doublequotes.stdout Normal file
View File

@ -0,0 +1 @@
foo bar

1
test/03-echo-escaped-doublequotes.sh Normal file
View File

@ -0,0 +1 @@
echo foo "bar" \"baz\"

1
test/03-echo-escaped-doublequotes.stdout Normal file
View File

@ -0,0 +1 @@
foo bar "baz"

Some files were not shown because too many files have changed in this diff Show More