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

builtins: Split out into gash/commands/. 

* gash/commands/cat.scm: New file, expand from bournish-commands.scm.
* gash/commands/compress.scm: Likewise.
* gash/commands/cp.scm: Likewise.
* gash/commands/find.scm: Likewise.
* gash/commands/grep.scm: Likewise.
* gash/commands/ls.scm: Likewise.
* gash/commands/reboot.scm: Likewise.
* gash/commands/tar.scm: Likewise.
* gash/commands/wc.scm: Likewise.
* gash/commands/which.scm: Likewise.
* build-aux/pre-inst-env.in: New file.
* configure: Expand it.
* gash/bournish-commands.scm: Remove.
* gash/shell-utils.scm: Rename from guix-build-utils.scm.
This commit is contained in:
Jan Nieuwenhuizen 2018-10-30 19:45:01 +01:00
parent 1e5389f01d
commit b433052b4a
28 changed files with 1010 additions and 578 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -1,5 +1,6 @@
*.go
*~
/bin/bash
/bin/cat
/bin/compress
/bin/cp
@ -8,9 +9,11 @@
/bin/grep
/bin/ls
/bin/reboot
/bin/sh
/bin/tar
/bin/wc
/bin/which
/.config.make
/doc/version.texi
/gash/config.scm
/pre-inst-env

9
AUTHORS
View File

@ -3,8 +3,13 @@ Main author
All files except the imported files listed below
Adapted from GNU Guix
gash/bournish-commands.scm
gash/guix-build-utils.scm
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

4
bin/builtin.in
View File

@ -1,5 +1,5 @@
#! @GUILE@ \
--no-auto-compile -e main -L @GUILE_SITE_DIR@ -C @GUILE_SITE_CCACHE_DIR@ -L . -C . -s
--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>
@ -21,4 +21,4 @@
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define (main args)
((@ (gash gash) main) (cons* (car (command-line)) "--" "@builtin@" (cdr (command-line)))))
(apply (@@ (gash commands @builtin@) main) args))

2
bin/gash.in
View File

@ -1,5 +1,5 @@
#! @GUILE@ \
--no-auto-compile -e main -L @GUILE_SITE_DIR@ -C @GUILE_SITE_CCACHE_DIR@ -L . -C . -s
--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>

13
build-aux/build-guile.sh
View File

@ -40,7 +40,6 @@ set -e
SCM_FILES="
gash/bournish-commands.scm
gash/guix-build-utils.scm
gash/guix-utils.scm
gash/builtins.scm
gash/compress.scm
@ -55,8 +54,20 @@ gash/peg.scm
gash/pipe.scm
gash/readline.scm
gash/script.scm
gash/shell-utils.scm
gash/ustar.scm
gash/util.scm
gash/commands/cat.scm
gash/commands/compress.scm
gash/commands/cp.scm
gash/commands/find.scm
gash/commands/grep.scm
gash/commands/ls.scm
gash/commands/reboot.scm
gash/commands/tar.scm
gash/commands/wc.scm
gash/commands/which.scm
"
export srcdir=.

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

113
configure vendored
View File

@ -14,9 +14,9 @@ fi
BASH=$(command -v bash)
GUILE=$(command -v guile)
GUILE_TOOLS=$(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))')
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
@ -28,45 +28,25 @@ if [ -d $GEESH_PREFIX ]; then
fi
fi
sed \
-e s,@GUILE@,$GUILE,\
-e s,@GUILE_SITE_DIR@,$GUILE_SITE_DIR,\
-e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\
bin/gash.in > bin/gash
chmod +x bin/gash
BUILTINS="
bash
cat
compress
cp
find
grep
ls
reboot
sh
tar
wc
which
"
for builtin in $BUILTINS; do
sed \
-e s,@GUILE@,$GUILE,\
-e s,@GUILE_SITE_DIR@,$GUILE_SITE_DIR,\
-e s,@GUILE_SITE_CCACHE_DIR@,$GUILE_SITE_CCACHE_DIR,\
-e s,@builtin@,$builtin,\
bin/builtin.in > bin/$builtin
chmod +x bin/$builtin
done
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
GUILE_TOOLS=$GUILE_TOOLS
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
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
@ -78,13 +58,56 @@ COMPRESS=$(command -v compress)
GZIP=$(command -v gzip)
XZ=$(command -v xz)
sed \
-e "s,@BZIP2@,$BZIP2,"\
-e "s,@COMPRESS@,$COMPRESS,"\
-e "s,@GZIP@,$GZIP,"\
-e "s,@XZ@,$XZ,"\
-e "s,@VERSION@,$VERSION,"\
gash/config.scm.in > gash/config.scm
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
}
subst bin/gash.in bin/gash
chmod +x bin/gash
SHELLS="
bash
sh
"
BUILTINS="
cat
compress
cp
find
grep
ls
reboot
tar
wc
which
"
for builtin in $BUILTINS $SHELLS; 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:

530
gash/bournish-commands.scm
View File

@ -26,515 +26,62 @@
;;; Code:
(define-module (gash bournish-commands)
#: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-build-utils)
#: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 config)
#:use-module (gash shell-utils)
#:use-module (gash commands cat)
#:use-module (gash commands compress)
#:use-module (gash commands cp)
#:use-module (gash commands find)
#:use-module (gash commands grep)
#:use-module (gash commands ls)
#:use-module (gash commands reboot)
#:use-module (gash commands sed)
#:use-module (gash commands tar)
#:use-module (gash commands wc)
#:use-module (gash commands which)
#:export (
%bournish-commands
cat-command
display-tabulated
compress-command
cp-command
find-command
grep-command
ls-command
reboot-command
sed-command
rm-command
wc-command
which-command
))
;;; Commentary:
;;; This code is taken from (guix build bournish)
;;;
;;; This is a super minimal Bourne-like shell language for Guile. It is meant
;;; to be used at the REPL as a rescue shell. In a way, this is to Guile what
;;; eshell is to Emacs.
;;;
;;; Code:
(define (wrap-command command name)
(define (wrap-command name command)
(lambda args
(catch #t
(cut apply command args)
(lambda (key . args)
(format (current-error-port) "~a: ~a ~a\n" name key args)
1))))
(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* (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))
(define cat-command (wrap-command cat "cat"))
(define compress-command (wrap-command "compress" compress))
(define cp-command (wrap-command "cp" cp))
(define find-command (wrap-command "find" find))
(define grep-command (wrap-command "grep" grep))
(define ls-command (wrap-command "ls" ls))
(define reboot-command (wrap-command "reboot" reboot))
(define sed-command (wrap-command "sed" sed))
(define tar-command (wrap-command "tar" tar))
(define wc-command (wrap-command "wc" wc))
(define which-command (wrap-command "which" which))
(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)))))
(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-command-implementation . args)
;; Run-time support procedure.
(lambda _
(let* ((option-spec
'((all (single-char #\a))
(help)
(long (single-char #\l))
(one-file-per-line (single-char #\1))
(version)))
(options (getopt-long (cons "ls" 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 ls-command (wrap-command ls-command-implementation "ls"))
(define (which-command program . rest)
(lambda _
(stdout (search-path (executable-path) program))))
(define (cat-command-implementation . args)
(lambda _
(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 args)))
(define cat-command (wrap-command cat-command-implementation "cat"))
(define (rm-command-implementation . args)
(lambda _
(cond ((member "-r" args)
(for-each delete-file-recursively
(apply delete (cons "-r" args))))
(else
(for-each delete-file args)))))
(define rm-command (wrap-command rm-command-implementation "rm"))
(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 (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 (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-command-implementation . files)
(for-each wc-print (filter file-exists?* files)))
(define (wc-l-command-implementation . files)
(for-each wc-l-print (filter file-exists?* files)))
(define (wc-c-command-implementation . files)
(for-each wc-c-print (filter file-exists?* files)))
(define (wc-command . args)
"Emit code for the 'wc' command."
(lambda _
(cond ((member "-l" args)
(apply wc-l-command-implementation (delete "-l" args)))
((member "-c" args)
(apply wc-c-command-implementation (delete "-c" args)))
(else
(apply wc-command-implementation args)))))
(define (reboot-command . 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 %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))))
(define (cp-command-implementation source dest . rest)
(lambda _ (copy-file source dest)))
(define cp-command (wrap-command cp-command-implementation "cp"))
(define (find-command-implementation . args)
;; Run-time support procedure.
(lambda _
(let* ((option-spec
'((help)
(version)))
(options (getopt-long (cons "find" 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 find-command (wrap-command find-command-implementation "find"))
(define (grep-command . args)
(lambda _
(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 (cons "grep" 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 (multi-opt options name)
(let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o)))))
(filter-map opt? options)))
(define (tar-command . args)
(lambda _
(let* ((option-spec
'((create (single-char #\c))
(compress (single-char #\Z))
(gzip (single-char #\z))
(bzip2 (single-char #\j))
(xz (single-char #\J))
(group (value #t))
(extract (single-char #\x))
(file (single-char #\f) (value #t))
(help (single-char #\h))
(mtime (value #t))
(list (single-char #\t))
(numeric-owner?)
(owner (value #t))
(sort (value #t))
(verbose (single-char #\v))
(version (single-char #\V))))
(args (cons "tar" args))
(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))))))
(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)))
(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, --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
-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 (not (option-ref options 'sort #f)) files
(sort files string<)))
(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 owner `(#:owner ,owner) '())
#: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 owner `(#:owner ,owner) '())
#: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 #: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 #:verbosity (1+ verbosity))))
(list-ustar-archive file files #:verbosity (1+ verbosity))))))))
(define (compress-command . args)
(lambda _
(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))))
(args (cons "compress" args))
(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 %bournish-commands
(define (%bournish-commands)
`(
("cat" . ,cat-command)
("compress" . ,compress-command)
@ -543,6 +90,7 @@ Usage: compress [OPTION]... [FILE]...
("grep" . ,grep-command)
("ls" . ,ls-command)
("reboot" . ,reboot-command)
("sed" . ,sed-command)
("tar" . ,tar-command)
("wc" . ,wc-command)
("which" . ,which-command)

2
gash/builtins.scm
View File

@ -32,7 +32,7 @@
#:use-module (gash gash) ; %prefer-builtins?
#:use-module (gash bournish-commands)
#:use-module (gash environment)
#:use-module (gash guix-build-utils)
#:use-module (gash shell-utils)
#:use-module (gash io)
#:use-module (gash job)
#:use-module (gash pipe)

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 args))
(define main cat)

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)

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

@ -0,0 +1,36 @@
;;; 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)
#:export (
cp
))
(define (cp name source dest . rest)
(copy-file source dest))
(define main cp)

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)

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)

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

@ -0,0 +1,152 @@
;;; 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))
(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))
(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))))))
(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)))
(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, --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
-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 (not (option-ref options 'sort #f)) files
(sort files string<)))
(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 owner `(#:owner ,owner) '())
#: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 owner `(#:owner ,owner) '())
#: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 #: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 #:verbosity (1+ verbosity))))
(list-ustar-archive file files #:verbosity (1+ verbosity)))))))
(define main tar)

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)

7
gash/config.scm.in
View File

@ -18,6 +18,7 @@
(define-module (gash config)
#:export (%bzip2
%commands
%xz
%compress
%gzip
@ -43,6 +44,12 @@
((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@")

4
gash/gash.scm
View File

@ -52,7 +52,7 @@
(call-with-input-file file-name parse))
(define (display-help)
(let ((builtins (sort (map car (append %bournish-commands ;;%builtin-commands
(let ((builtins (sort (map car (append (%bournish-commands) ;;%builtin-commands
)) string<)))
(display (string-append "\
Usage: gash [OPTION]... [FILE]...
@ -130,7 +130,7 @@ copyleft.
(builtin-command-line
(let* ((builtin (car builtin-command-line))
(args (cdr builtin-command-line))
(command (assoc-ref %bournish-commands builtin)))
(command (assoc-ref (%bournish-commands) builtin)))
((apply command args))))
(#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history"))
(thunk (lambda ()

3
gash/guix-utils.scm
View File

@ -31,13 +31,12 @@
;;; 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 guix-build-utils) #:select (dump-port))
#:use-module ((gash shell-utils) #:select (dump-port))
#:use-module (ice-9 match)
#:use-module (gash config)
#:export (filtered-port

2
gash/io.scm
View File

@ -1,8 +1,6 @@
(define-module (gash io)
#:use-module (srfi srfi-1)
#:use-module (gash gash)
#:export (pke stdout stderr))
(define (output port o)

3
gash/script.scm
View File

@ -33,7 +33,6 @@
#:use-module (gash config)
#:use-module (gash environment)
#:use-module (gash gash)
#:use-module (gash guix-build-utils)
#:use-module (gash io)
#:use-module (gash job)
#:use-module (gash pipe)
@ -249,7 +248,7 @@
(format (current-error-port) "gash: ~a: permission denied\n" command))
#f)
((and command (or (assoc-ref %builtin-commands command)
(assoc-ref %bournish-commands command)))
(assoc-ref (%bournish-commands) command)))
=>
(lambda (command)
(if args

68
gash/guix-build-utils.scm → gash/shell-utils.scm
View File

@ -26,7 +26,7 @@
;;; Code:
(define-module (gash guix-build-utils)
(define-module (gash shell-utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
@ -41,12 +41,15 @@
#:use-module (rnrs io ports)
#:export (
delete-file-recursively
display-tabulated
display-file
dump-port
executable-path
file-name-predicate
find-files
file-exists?*
grep*
grep
grep+
<grep-match>
grep-match-file-name
grep-match-string
@ -54,6 +57,7 @@
grep-match-column
grep-match-end-column
mkdir-p
multi-opt
directory-exists?
executable-file?
@ -216,7 +220,7 @@ transferred and the continuation of the transfer as a thunk."
(match:end m)) matches)
matches))))))
(define (grep pattern file)
(define (grep+ pattern file)
(cond ((and (string? file)
(not (equal? file "-"))) (call-with-input-file file
(lambda (in)
@ -248,6 +252,53 @@ transferred and the continuation of the transfer as a thunk."
(apply throw args))))))
(() #t))))
(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"))
@ -289,3 +340,14 @@ transferred and the continuation of the transfer as a thunk."
(display date)
(display " "))
(display file-name))
(define (multi-opt options name)
(let ((opt? (lambda (o) (and (eq? (car o) name) (cdr o)))))
(filter-map opt? 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))))

2
gash/ustar.scm
View File

@ -33,7 +33,7 @@
#:use-module (ice-9 receive)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (gash guix-build-utils)
#:use-module (gash shell-utils)
#:export (read-ustar-archive
read-ustar-port
write-ustar-archive

8
gash/util.scm
View File

@ -15,11 +15,3 @@
(define (conjoin . predicates)
(lambda (. arguments)
(every (cut apply <> arguments) predicates)))
(define (wrap-command command name)
(lambda args
(catch #t
(cut apply command args)
(lambda (key . args)
(format (current-error-port) "~a: ~a ~a\n" name key args)
1))))

30
makefile
View File

@ -9,7 +9,7 @@ bin/gash: bin/gash.in | do-configure
bin/tar: bin/tar.in | do-configure
do-configure:
./configure --prefix=$(PREFIX)
./configure --prefix=$(prefix)
all: all-go do-configure
@ -33,21 +33,21 @@ check-gash: all
SHELL=bin/gash ./test.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)
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
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'`;\
@ -79,7 +79,7 @@ help:
export BUILD_DEBUG
export GUILE
export GUILE_TOOLS
export GUILE_LOAD_PATH
export GUILE_LOAD_COMPILED_PATH
export guile_load_path
export guile_load_compiled_path