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:
parent
0bc6de34d1
commit
836f7627b2
|
@ -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
|
|
@ -36,6 +36,8 @@ GUILE_AUTO_COMPILE=0
|
||||||
set -e
|
set -e
|
||||||
|
|
||||||
SCM_FILES="
|
SCM_FILES="
|
||||||
|
gash/bournish-commands.scm
|
||||||
|
gash/guix-build-utils.scm
|
||||||
gash/gash.scm
|
gash/gash.scm
|
||||||
gash/io.scm
|
gash/io.scm
|
||||||
gash/job.scm
|
gash/job.scm
|
||||||
|
|
|
@ -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))))
|
|
@ -18,6 +18,7 @@
|
||||||
#:use-module (gash peg)
|
#:use-module (gash peg)
|
||||||
#:use-module (gash io)
|
#:use-module (gash io)
|
||||||
#:use-module (gash util)
|
#:use-module (gash util)
|
||||||
|
#:use-module (gash bournish-commands)
|
||||||
|
|
||||||
#:export (main
|
#:export (main
|
||||||
%debug-level
|
%debug-level
|
||||||
|
@ -67,10 +68,11 @@ gash [options]
|
||||||
(display "
|
(display "
|
||||||
GASH 0.1
|
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
|
This is gash, Guile As SHell. Gash is free software and is covered by
|
||||||
the GNU Public License, see COPYING for the copyleft.
|
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 ...)
|
((args ...)
|
||||||
(format (current-error-port) "exit: too many arguments: ~a\n" (string-join 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?)
|
(define (set-shell-opt! name set?)
|
||||||
(let* ((shell-opts (assoc-ref global-variables "SHELLOPTS"))
|
(let* ((shell-opts (assoc-ref global-variables "SHELLOPTS"))
|
||||||
(options (if (string-null? shell-opts) '()
|
(options (if (string-null? shell-opts) '()
|
||||||
|
@ -259,28 +271,22 @@ the GNU Public License, see COPYING for the copyleft.
|
||||||
(define %commands
|
(define %commands
|
||||||
;; Built-in commands.
|
;; Built-in commands.
|
||||||
`(
|
`(
|
||||||
("echo" . ,echo-command)
|
("bg" . ,bg-command)
|
||||||
("cd" . ,cd-command)
|
("cat" . ,cat-command)
|
||||||
("pwd" . ,pwd-command)
|
("cd" . ,cd-command)
|
||||||
("jobs" . ,jobs-command)
|
("cp" . ,cp-command)
|
||||||
("bg" . ,bg-command)
|
("echo" . ,echo-command)
|
||||||
("fg" . ,fg-command)
|
("exit" . ,exit-command)
|
||||||
("set" . ,set-command)
|
("fg" . ,fg-command)
|
||||||
("exit" . ,exit-command)
|
("help" . ,help-command)
|
||||||
|
("jobs" . ,jobs-command)
|
||||||
;; Bournish
|
("ls" . ,ls-command)
|
||||||
;; ("echo" ,(lambda strings `(list ,@strings)))
|
("pwd" . ,pwd-command)
|
||||||
;; ("cd" ,(lambda (dir) `(chdir ,dir)))
|
("reboot" . ,reboot-command)
|
||||||
;; ("pwd" ,(lambda () `(getcwd)))
|
("rm" . ,rm-command)
|
||||||
;; ("rm" ,rm-command)
|
("set" . ,set-command)
|
||||||
;; ("cp" ,(lambda (source dest) `(copy-file ,source ,dest)))
|
("wc" . ,wc-command)
|
||||||
;; ("help" ,help-command)
|
("which" . ,which-command)
|
||||||
;; ("ls" ,ls-command)
|
|
||||||
;; ("which" ,which-command)
|
|
||||||
;; ("cat" ,cat-command)
|
|
||||||
;; ("wc" ,wc-command)
|
|
||||||
;; ("reboot" ,reboot-command)
|
|
||||||
|
|
||||||
))
|
))
|
||||||
|
|
||||||
(define %prefer-builtins? #t) ; use builtin, even if COMMAND is available in PATH?
|
(define %prefer-builtins? #t) ; use builtin, even if COMMAND is available in PATH?
|
||||||
|
|
|
@ -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)))))
|
Loading…
Reference in New Issue