From 836f7627b26421a559ecb428ad3fce91e31d1c38 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 4 Jul 2018 20:02:49 +0200 Subject: [PATCH] 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. --- AUTHORS | 10 ++ build-aux/build-guile.sh | 2 + gash/bournish-commands.scm | 218 +++++++++++++++++++++++++++++++++++++ gash/gash.scm | 56 +++++----- gash/guix-build-utils.scm | 67 ++++++++++++ 5 files changed, 328 insertions(+), 25 deletions(-) create mode 100644 AUTHORS create mode 100644 gash/bournish-commands.scm create mode 100644 gash/guix-build-utils.scm diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..4d3661a --- /dev/null +++ b/AUTHORS @@ -0,0 +1,10 @@ +Rutger EW van Beusekom +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 diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index d499bfc..7c4f75a 100755 --- a/build-aux/build-guile.sh +++ b/build-aux/build-guile.sh @@ -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 diff --git a/gash/bournish-commands.scm b/gash/bournish-commands.scm new file mode 100644 index 0000000..bdc1518 --- /dev/null +++ b/gash/bournish-commands.scm @@ -0,0 +1,218 @@ +;;; 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 . + +(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)))) diff --git a/gash/gash.scm b/gash/gash.scm index d4feee8..198c002 100644 --- a/gash/gash.scm +++ b/gash/gash.scm @@ -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? diff --git a/gash/guix-build-utils.scm b/gash/guix-build-utils.scm new file mode 100644 index 0000000..896cc6d --- /dev/null +++ b/gash/guix-build-utils.scm @@ -0,0 +1,67 @@ +;;; Gash -- Guile As Shell +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013 Andreas Enge +;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2015, 2018 Mark H Weaver +;;; +;;; 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 . + + +(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)))))