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

Import bournish commands from GNU Guix. 

* AUTHORS: New file.
* gash/bournish-commands.scm: New file.  Imported and adapted from GNU
  Guix.
* gash/bournish-commands.scm: Likewise.
* gash/gash.scm (%commands): Add commands from Bournish.
This commit is contained in:
Jan Nieuwenhuizen 2018-07-04 20:02:49 +02:00
parent 0bc6de34d1
commit 836f7627b2
5 changed files with 328 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
AUTHORS Normal file
View File

@ -0,0 +1,10 @@
Rutger EW van Beusekom <rutger.van.beusekom@gmail.com>
Main author
All files except the imported files listed below
Adapted from GNU Guix
gash/bournish-commands.scm
gash/guix-build-utils.scm
Adapted from Mes
build-aux/build-guile.sh

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

@ -36,6 +36,8 @@ GUILE_AUTO_COMPILE=0
set -e
SCM_FILES="
gash/bournish-commands.scm
gash/guix-build-utils.scm
gash/gash.scm
gash/io.scm
gash/job.scm

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

@ -0,0 +1,218 @@
;;; 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/>.
(define-module (gash bournish-commands)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 match)
#:use-module (ice-9 ftw)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module (gash guix-build-utils)
#:use-module (gash io)
#:export (
cat-command
ls-command
reboot-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 (expand-variable str)
"Return STR or code to obtain the value of the environment variable STR
refers to."
;; XXX: No support for "${VAR}".
(if (string-prefix? "$" str)
`(or (getenv ,(string-drop str 1)) "")
str))
(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 ls-command-implementation
;; Run-time support procedure.
(case-lambda
(()
(display-tabulated (scandir ".")))
(files
(let ((files (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)))
(display-tabulated files)))))
(define (ls-command . files)
(apply ls-command-implementation files))
(define (which-command program . rest)
(stdout (search-path (executable-path) program)))
(define (cat-command file . rest)
(call-with-input-file file
(lambda (port)
(dump-port port (current-output-port))
*unspecified*)))
(define (rm-command . args)
"Emit code for the 'rm' command."
(cond ((member "-r" args)
(for-each delete-file-recursively
(apply delete (cons "-r" args))))
(else
(for-each delete-file args))))
(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."
(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))))

56
gash/gash.scm
View File

@ -18,6 +18,7 @@
#:use-module (gash peg)
#:use-module (gash io)
#:use-module (gash util)
#:use-module (gash bournish-commands)
#:export (main
%debug-level
@ -67,10 +68,11 @@ gash [options]
(display "
GASH 0.1
Copryright (C) 2016 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com.
Copryright (C) 2016,2017,2018 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com.
This is gash, Guile As SHell. Gash is free software and is covered by
the GNU Public License, see COPYING for the copyleft.
This is gash, Guile As SHell. Gash is free software and is covered by
the GNU General Public License version 3 or later, see COPYING for the
copyleft.
"))
@ -244,6 +246,16 @@ the GNU Public License, see COPYING for the copyleft.
((args ...)
(format (current-error-port) "exit: too many arguments: ~a\n" (string-join args)))))
(define (help-command . _)
(display "\
Hello, this is gash, Guile As SHell.
TODO
"))
(define (cp-command source dest)
`(copy-file ,source ,dest))
(define (set-shell-opt! name set?)
(let* ((shell-opts (assoc-ref global-variables "SHELLOPTS"))
(options (if (string-null? shell-opts) '()
@ -259,28 +271,22 @@ the GNU Public License, see COPYING for the copyleft.
(define %commands
;; Built-in commands.
`(
("echo" . ,echo-command)
("cd" . ,cd-command)
("pwd" . ,pwd-command)
("jobs" . ,jobs-command)
("bg" . ,bg-command)
("fg" . ,fg-command)
("set" . ,set-command)
("exit" . ,exit-command)
;; Bournish
;; ("echo" ,(lambda strings `(list ,@strings)))
;; ("cd" ,(lambda (dir) `(chdir ,dir)))
;; ("pwd" ,(lambda () `(getcwd)))
;; ("rm" ,rm-command)
;; ("cp" ,(lambda (source dest) `(copy-file ,source ,dest)))
;; ("help" ,help-command)
;; ("ls" ,ls-command)
;; ("which" ,which-command)
;; ("cat" ,cat-command)
;; ("wc" ,wc-command)
;; ("reboot" ,reboot-command)
("bg" . ,bg-command)
("cat" . ,cat-command)
("cd" . ,cd-command)
("cp" . ,cp-command)
("echo" . ,echo-command)
("exit" . ,exit-command)
("fg" . ,fg-command)
("help" . ,help-command)
("jobs" . ,jobs-command)
("ls" . ,ls-command)
("pwd" . ,pwd-command)
("reboot" . ,reboot-command)
("rm" . ,rm-command)
("set" . ,set-command)
("wc" . ,wc-command)
("which" . ,which-command)
))
(define %prefer-builtins? #t) ; use builtin, even if COMMAND is available in PATH?

67
gash/guix-build-utils.scm Normal file
View File

@ -0,0 +1,67 @@
;;; Gash -- Guile As Shell
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash guix-build-utils)
;; #:use-module (srfi srfi-1)
;; #:use-module (srfi srfi-11)
;; #:use-module (srfi srfi-26)
;; #:use-module (srfi srfi-34)
;; #:use-module (srfi srfi-35)
;; #:use-module (srfi srfi-60)
;; #:use-module (ice-9 ftw)
;; #:use-module (ice-9 match)
;; #:use-module (ice-9 regex)
;; #:use-module (ice-9 rdelim)
;; #:use-module (ice-9 format)
;; #:use-module (ice-9 threads)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:export (dump-port))
;;; Commentary:
;;; This code is taken from (guix build utils)
(define* (dump-port in out
#:key (buffer-size 16384)
(progress (lambda (t k) (k))))
"Read as much data as possible from IN and write it to OUT, using chunks of
BUFFER-SIZE bytes. Call PROGRESS at the beginning and after each successful
transfer of BUFFER-SIZE bytes or less, passing it the total number of bytes
transferred and the continuation of the transfer as a thunk."
(define buffer
(make-bytevector buffer-size))
(define (loop total bytes)
(or (eof-object? bytes)
(let ((total (+ total bytes)))
(put-bytevector out buffer 0 bytes)
(progress total
(lambda ()
(loop total
(get-bytevector-n! in buffer 0 buffer-size)))))))
;; Make sure PROGRESS is called when we start so that it can measure
;; throughput.
(progress 0
(lambda ()
(loop 0 (get-bytevector-n! in buffer 0 buffer-size)))))