From b433052b4aa50ad9e05d083f4f777be867c7529e Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 30 Oct 2018 19:45:01 +0100 Subject: [PATCH] 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. --- .gitignore | 3 + AUTHORS | 9 +- bin/builtin.in | 4 +- bin/gash.in | 2 +- build-aux/build-guile.sh | 13 +- build-aux/pre-inst-env.in | 45 ++ configure | 113 ++-- gash/bournish-commands.scm | 530 ++---------------- gash/builtins.scm | 2 +- gash/commands/cat.scm | 41 ++ gash/commands/compress.scm | 68 +++ gash/commands/cp.scm | 36 ++ gash/commands/find.scm | 65 +++ gash/commands/grep.scm | 109 ++++ gash/commands/ls.scm | 106 ++++ gash/commands/reboot.scm | 44 ++ gash/commands/tar.scm | 152 +++++ gash/commands/wc.scm | 81 +++ gash/commands/which.scm | 38 ++ gash/config.scm.in | 7 + gash/gash.scm | 4 +- gash/guix-utils.scm | 3 +- gash/io.scm | 2 - gash/script.scm | 3 +- .../{guix-build-utils.scm => shell-utils.scm} | 68 ++- gash/ustar.scm | 2 +- gash/util.scm | 8 - makefile | 30 +- 28 files changed, 1010 insertions(+), 578 deletions(-) create mode 100644 build-aux/pre-inst-env.in create mode 100644 gash/commands/cat.scm create mode 100644 gash/commands/compress.scm create mode 100644 gash/commands/cp.scm create mode 100644 gash/commands/find.scm create mode 100644 gash/commands/grep.scm create mode 100644 gash/commands/ls.scm create mode 100644 gash/commands/reboot.scm create mode 100644 gash/commands/tar.scm create mode 100644 gash/commands/wc.scm create mode 100644 gash/commands/which.scm rename gash/{guix-build-utils.scm => shell-utils.scm} (82%) diff --git a/.gitignore b/.gitignore index ebb4f43..d5690d4 100644 --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/AUTHORS b/AUTHORS index 4d3661a..bcce19a 100644 --- a/AUTHORS +++ b/AUTHORS @@ -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 diff --git a/bin/builtin.in b/bin/builtin.in index 72fc775..d0eff5f 100644 --- a/bin/builtin.in +++ b/bin/builtin.in @@ -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 @@ -21,4 +21,4 @@ ;;; along with Gash. If not, see . (define (main args) - ((@ (gash gash) main) (cons* (car (command-line)) "--" "@builtin@" (cdr (command-line))))) + (apply (@@ (gash commands @builtin@) main) args)) diff --git a/bin/gash.in b/bin/gash.in index f42446a..c7587d1 100644 --- a/bin/gash.in +++ b/bin/gash.in @@ -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 diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index e3b6327..5b55be7 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -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=. diff --git a/build-aux/pre-inst-env.in b/build-aux/pre-inst-env.in new file mode 100644 index 0000000..0f45566 --- /dev/null +++ b/build-aux/pre-inst-env.in @@ -0,0 +1,45 @@ +#! @BASH@ + +# Gash -- Guile As SHell +# Copyright © 2018 Jan (janneke) Nieuwenhuizen +# +# This file is part of Gash. +# +# Gash is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or (at +# your option) any later version. +# +# Gash is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +# details. +# +# You should have received a copy of the GNU General Public License +# along with Gash. If not, see . + +srcdir="@srcdir@" +abs_top_srcdir="@abs_top_srcdir@" +abs_top_builddir="@abs_top_builddir@" +prefix=${prefix-@prefix@} + +MES_PREFIX=${MES_PREFIX-${srcdest}mes} +export MES_PREFIX + +GUILE_LOAD_COMPILED_PATH="$abs_top_builddir/bin:$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" +GUILE_LOAD_PATH="$abs_top_srcdir${GUILE_LOAD_PATH:+:}$GUILE_LOAD_PATH" +if [ -n "$srcdest" ]; then + GUILE_LOAD_PATH="${srcdest}module:${srcdest}mes:$GUILE_LOAD_PATH" +fi +export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH + +PATH="$abs_top_builddir/bin:$PATH" +export PATH + +COMMANDS="$abs_top_builddir/gash/commands" +export COMMANDS + +LANG= +LC_ALL= + +exec "$@" diff --git a/configure b/configure index 43f97cd..b4d2d68 100755 --- a/configure +++ b/configure @@ -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 < 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 <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) diff --git a/gash/builtins.scm b/gash/builtins.scm index 5aa7ac0..944884d 100644 --- a/gash/builtins.scm +++ b/gash/builtins.scm @@ -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) diff --git a/gash/commands/cat.scm b/gash/commands/cat.scm new file mode 100644 index 0000000..3af3f6b --- /dev/null +++ b/gash/commands/cat.scm @@ -0,0 +1,41 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands cat) + #:use-module (srfi srfi-1) + #:use-module (gash shell-utils) + #:export (cat)) + +(define (cat name . args) + (fold (lambda (file p) + (if (string=? file "-") (dump-port (current-input-port) (current-output-port)) + (call-with-input-file file + (lambda (port) + (dump-port port (current-output-port)))))) + 0 args)) + +(define main cat) diff --git a/gash/commands/compress.scm b/gash/commands/compress.scm new file mode 100644 index 0000000..bfce7f0 --- /dev/null +++ b/gash/commands/compress.scm @@ -0,0 +1,68 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands compress) + #:use-module (ice-9 getopt-long) + #:use-module (srfi srfi-1) + + #:use-module (gash config) + #:use-module (gash compress) + #:use-module (gash guix-utils) + #:export ( + compress + )) + +(define (compress . args) + (let* ((option-spec + '((bits (single-char #\b) (value #t)) + (decompress (single-char #\d)) + (help (single-char #\h)) + (stdout (single-char #\c)) + (verbose (single-char #\v)) + (version (single-char #\V)))) + (options (getopt-long args option-spec)) + (bits (string->number (option-ref options 'bits "16"))) + (decompress? (option-ref options 'decompress #f)) + (stdout? (option-ref options 'stdout #f)) + (files (option-ref options '() '())) + (help? (option-ref options 'help #f)) + (usage? (and (not help?) (or (and (null? files) (isatty? (current-input-port)))))) + (verbose? (option-ref options 'verbose #f)) + (version? (option-ref options 'version #f))) + (cond (version? (format #t "compress (GASH) ~a\n" %version) (exit 0)) + ((or help? usage?) (format (if usage? (current-error-port) #t) + "\ +Usage: compress [OPTION]... [FILE]... + -b, --bits=BITS use a maximum of BITS bits per code [16] + -c, --stdout write on standard output, keep original files unchanged + -d, --decompress decompress + -h, --help display this help + -v, --verbose show compression ratio + -V, --version display version +") + (exit (if usage? 2 0))) + (decompress? (if (pair? files) (uncompress-file (car files) verbose?) + (uncompress-port (current-input-port) (current-output-port) verbose?))) + (else (if (pair? files) (compress-file (car files) bits verbose?) + (compress-port (current-input-port) (current-output-port) bits verbose?)))))) + +(define main compress) diff --git a/gash/commands/cp.scm b/gash/commands/cp.scm new file mode 100644 index 0000000..4e486ae --- /dev/null +++ b/gash/commands/cp.scm @@ -0,0 +1,36 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands cp) + #:export ( + cp + )) + +(define (cp name source dest . rest) + (copy-file source dest)) + +(define main cp) diff --git a/gash/commands/find.scm b/gash/commands/find.scm new file mode 100644 index 0000000..19bc5a3 --- /dev/null +++ b/gash/commands/find.scm @@ -0,0 +1,65 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands find) + #:use-module (ice-9 getopt-long) + + #:use-module (gash config) + #:use-module (gash io) + #:use-module (gash shell-utils) + + #:export ( + find + )) + +(define (find . args) + (let* ((option-spec + '((help) + (version))) + (options (getopt-long args option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '())) + (files (if (null? files) '(".") files)) + (file (car files))) + (when (> (length files) 1) + (format (current-error-port) "find: too many FILEs: ~s\n" files) + (error "find failed")) + ;; TODO: find [OPTION]... [FILE]... [EXPRESSION]... + ;; and options: esp: -x, -L + (cond (version? (format #t "find (GASH) ~a\n" %version)) + (help? (display "Usage: find [OPTION]... [FILE] + +Options: + --help display this help and exit + --version display version information and exit +")) + (else + (let* ((files (find-files file #:directories? #t #:fail-on-error? #t))) + (for-each stdout files)))))) + +(define main find) diff --git a/gash/commands/grep.scm b/gash/commands/grep.scm new file mode 100644 index 0000000..c310d21 --- /dev/null +++ b/gash/commands/grep.scm @@ -0,0 +1,109 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands grep) + #:use-module (ice-9 ftw) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + + #:use-module (gash guix-utils) + #:use-module (gash compress) + #:use-module (gash config) + #:use-module (gash io) + #:use-module (gash ustar) + #:use-module (gash util) + #:use-module (gash shell-utils) + + #:export ( + grep + )) + +(define (grep . args) + (let* ((option-spec + '((help) + (line-number (single-char #\n)) + (files-with-matches (single-char #\l)) + (files-without-match (single-char #\L)) + (with-file-name (single-char #\H)) + (no-file-name (single-char #\h)) + (only-matching (single-char #\o)) + (version (single-char #\V)))) + (options (getopt-long args option-spec)) + (help? (option-ref options 'help #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (version? (format #t "grep (GASH) ~a\n" %version)) + (help? (display "Usage: grep [OPTION]... PATTERN [FILE]... + +Options: + --help display this help and exit + -h, --no-filename suppress the file name prefix on output + -H, --with-filename print file name with output lines + -l, --files-with-matches print only names of FILEs with selected lines + -L, --files-without-match print only names of FILEs with no selected lines + -n, --line-number print line number with output lines + -o, --only-matching show only the part of a line matching PATTERN + -V, --version display version information and exit +")) + ((null? files) #t) + (else + (let* ((pattern (car files)) + (files (if (pair? (cdr files)) (cdr files) + (list "-"))) + (matches (append-map (cut grep+ pattern <>) files))) + (define (display-match o) + (let* ((s (grep-match-string o)) + (s (if (option-ref options 'only-matching #f) + (substring s (grep-match-column o) (grep-match-end-column o)) + s)) + (s (if (option-ref options 'line-number #f) + (string-append (number->string (grep-match-line o)) ":" s) + s)) + (s (if (option-ref options 'with-file-name #f) + (string-append (grep-match-file-name o) ":" s) + s))) + (stdout s))) + (define (files-with-matches) + (delete-duplicates (map grep-match-file-name matches))) + (cond ((option-ref options 'files-with-matches #f) + (let ((result (files-with-matches))) + (and (pair? result) + (for-each stdout result) + 0))) + ((option-ref options 'files-without-match #f) + (let* ((result (files-with-matches)) + (result (filter (negate (cut member <> result)) files))) + (and (pair? result) + (for-each stdout result) + 0))) + (else + (and (pair? matches) + (for-each display-match matches) + 0)))))))) + +(define main grep) diff --git a/gash/commands/ls.scm b/gash/commands/ls.scm new file mode 100644 index 0000000..c15e5e4 --- /dev/null +++ b/gash/commands/ls.scm @@ -0,0 +1,106 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands ls) + #:use-module (ice-9 ftw) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 match) + + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + + #:use-module (gash config) + #:use-module (gash io) + #:use-module (gash shell-utils) + + #:export ( + ls + )) + +(cond-expand + (guile + ;; Support -1, see https://lists.gnu.org/archive/html/bug-guile/2018-07/msg00009.html + (module-define! (resolve-module '(ice-9 getopt-long)) 'short-opt-rx (make-regexp "^-([a-zA-Z0-9]+)(.*)"))) + (else)) + +(define (ls . args) + (let* ((option-spec + '((all (single-char #\a)) + (help) + (long (single-char #\l)) + (one-file-per-line (single-char #\1)) + (version))) + (options (getopt-long args option-spec)) + (all? (option-ref options 'all #f)) + (help? (option-ref options 'help #f)) + (long? (option-ref options 'long #f)) + (one-file-per-line? (option-ref options 'one-file-per-line #f)) + (version? (option-ref options 'version #f)) + (files (option-ref options '() '()))) + (cond (version? (format #t "ls (GASH) ~a\n" %version)) + (help? (display "Usage: ls [OPTION]... [FILE]... + +Options: + -a, --all do not ignore entries starting with . + --help display this help and exit + -l, --long use a long listing format + --version display version information and exit + -1 list one file per line +")) + (else + (let* ((files (if (null? files) (scandir ".") + (append-map (lambda (file) + (catch 'system-error + (lambda () + (match (stat:type (lstat file)) + ('directory + ;; Like GNU ls, list the contents of + ;; FILE rather than FILE itself. + (match (scandir file + (match-lambda + ((or "." "..") #f) + (_ #t))) + (#f + (list file)) + ((files ...) + (map (cut string-append file "/" <>) + files)))) + (_ + (list file)))) + (lambda args + (let ((errno (system-error-errno args))) + (format (current-error-port) "~a: ~a~%" + file (strerror errno)) + '())))) + files))) + (files (if all? files + (filter (negate (cut string-prefix? "." <>)) files)))) + (cond (long? (for-each (lambda (f) (display-file f) (newline)) files)) + (one-file-per-line? (for-each stdout files)) + (else (display-tabulated files)))))))) + +(define main ls) diff --git a/gash/commands/reboot.scm b/gash/commands/reboot.scm new file mode 100644 index 0000000..ae6a9da --- /dev/null +++ b/gash/commands/reboot.scm @@ -0,0 +1,44 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands reboot) + #:export ( + reboot + )) + +(define (reboot name . args) + "Emit code for 'reboot'." + ;; Normally Bournish is used in the initrd, where 'reboot' is provided + ;; directly by (guile-user). In other cases, just bail out. + (if (defined? 'reboot) + (reboot) + (begin + (format (current-error-port) + "I don't know how to reboot, sorry about that!~%") + 1))) + +(define main reboot) diff --git a/gash/commands/tar.scm b/gash/commands/tar.scm new file mode 100644 index 0000000..32449ec --- /dev/null +++ b/gash/commands/tar.scm @@ -0,0 +1,152 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; Code: + +(define-module (gash commands tar) + #:use-module (ice-9 getopt-long) + #:use-module (srfi srfi-26) + #:use-module (gash config) + #:use-module (gash compress) + #:use-module (gash ustar) + #:use-module (gash guix-utils) + #:use-module (gash shell-utils) + + #:export ( + tar + )) + +(define (tar . args) + (let* ((option-spec + '((create (single-char #\c)) + (compress (single-char #\Z)) + (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) diff --git a/gash/commands/wc.scm b/gash/commands/wc.scm new file mode 100644 index 0000000..8d4c386 --- /dev/null +++ b/gash/commands/wc.scm @@ -0,0 +1,81 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands wc) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + + #:use-module (ice-9 match) + #:use-module (gash shell-utils) + #:export ( + wc + )) + +(define (lines+chars port) + "Return the number of lines and number of chars read from PORT." + (let loop ((lines 0) (chars 0)) + (match (read-char port) + ((? eof-object?) ;done! + (values lines chars)) + (#\newline ;recurse + (loop (1+ lines) (1+ chars))) + (_ ;recurse + (loop lines (1+ chars)))))) + +(define (wc-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a ~a~%" lines chars file))) + +(define (wc-l-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a~%" lines file))) + +(define (wc-c-print file) + (let-values (((lines chars) + (call-with-input-file file lines+chars))) + (format #t "~a ~a~%" chars file))) + +(define (wc- . files) + (for-each wc-print (filter file-exists?* files))) + +(define (wc-l . files) + (for-each wc-l-print (filter file-exists?* files))) + +(define (wc-c . files) + (for-each wc-c-print (filter file-exists?* files))) + +(define (wc name . args) + (cond ((member "-l" args) + (apply wc-l (delete "-l" args))) + ((member "-c" args) + (apply wc-c (delete "-c" args))) + (else + (apply wc- args)))) + +(define main wc) diff --git a/gash/commands/which.scm b/gash/commands/which.scm new file mode 100644 index 0000000..a4fa981 --- /dev/null +++ b/gash/commands/which.scm @@ -0,0 +1,38 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Efraim Flashner +;;; Copyright © 2017 Ricardo Wurmus +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen +;;; +;;; This file is part of Gash. +;;; +;;; Gash is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY +;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS +;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more +;;; details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Gash. If not, see . + +;;; Commentary: + +;;; The initial bournish.scm was taken from Guix. + +;;; Code: + +(define-module (gash commands which) + #:use-module (gash io) + #:use-module (gash shell-utils) + #:export ( + which + )) + +(define (which name program . rest) + (stdout (search-path (executable-path) program))) + +(define main which) diff --git a/gash/config.scm.in b/gash/config.scm.in index 264e4b0..0d7ec41 100644 --- a/gash/config.scm.in +++ b/gash/config.scm.in @@ -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@") diff --git a/gash/gash.scm b/gash/gash.scm index eea1972..b3a6cd1 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -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 () diff --git a/gash/guix-utils.scm b/gash/guix-utils.scm index 4b3c90a..285f627 100644 --- a/gash/guix-utils.scm +++ b/gash/guix-utils.scm @@ -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 diff --git a/gash/io.scm b/gash/io.scm index d947369..749320b 100644 --- a/gash/io.scm +++ b/gash/io.scm @@ -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) diff --git a/gash/script.scm b/gash/script.scm index 289343f..e046fd5 100644 --- a/gash/script.scm +++ b/gash/script.scm @@ -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 diff --git a/gash/guix-build-utils.scm b/gash/shell-utils.scm similarity index 82% rename from gash/guix-build-utils.scm rename to gash/shell-utils.scm index 6ec2903..0ebb705 100644 --- a/gash/guix-build-utils.scm +++ b/gash/shell-utils.scm @@ -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-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)))) diff --git a/gash/ustar.scm b/gash/ustar.scm index 73ab410..6701c85 100644 --- a/gash/ustar.scm +++ b/gash/ustar.scm @@ -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 diff --git a/gash/util.scm b/gash/util.scm index 6bd68ad..08dbac6 100644 --- a/gash/util.scm +++ b/gash/util.scm @@ -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)))) diff --git a/makefile b/makefile index 8a081f5..0fe88bd 100644 --- a/makefile +++ b/makefile @@ -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