208 lines
8.3 KiB
Scheme
208 lines
8.3 KiB
Scheme
;;; Gash --- Guile As SHell
|
|
;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
|
|
;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
|
|
;;; 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 gash)
|
|
#:use-module (gash config)
|
|
#:use-module (gash environment)
|
|
#:use-module (gash eval)
|
|
#:use-module (gash parser)
|
|
#:use-module (gash repl)
|
|
#:use-module (ice-9 buffered-input)
|
|
#:use-module (ice-9 ftw)
|
|
#:use-module (ice-9 getopt-long)
|
|
#:use-module (ice-9 local-eval)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 pretty-print)
|
|
#:use-module (ice-9 receive)
|
|
#:use-module (ice-9 regex)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-26)
|
|
#:export (main))
|
|
|
|
(catch #t
|
|
(lambda _ (use-modules (ice-9 readline)))
|
|
(lambda (key . args)
|
|
(use-modules (gash readline))))
|
|
|
|
(define (display-help)
|
|
(display (string-append "\
|
|
Usage: gash [OPTION]... [FILE]...
|
|
or gash [OPTION]...
|
|
|
|
Options:
|
|
-c, --command=STRING Evaluate STRING and exit
|
|
-e, --errexit Exit upon error
|
|
-h, --help Display this help
|
|
-p, --parse Parse the shell script and print the parse tree
|
|
-v, --version Display the version
|
|
-x, --xtrace Print simple command trace
|
|
")))
|
|
|
|
(define (display-version)
|
|
(display (string-append "
|
|
gash (GASH) " %version "
|
|
|
|
Copyright (C) 2016,2017,2018 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>,
|
|
Copyright (C) 2017,2018 Timothy Sample <samplet@ngyro.com>,
|
|
and others.
|
|
|
|
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.
|
|
")))
|
|
|
|
(define (main args)
|
|
(let ((thunk
|
|
(lambda ()
|
|
(let* ((option-spec '((command (single-char #\c) (value #t))
|
|
(errexit (single-char #\e))
|
|
(help (single-char #\h))
|
|
(parse (single-char #\p))
|
|
(version (single-char #\v))
|
|
(xtrace (single-char #\x))))
|
|
(args (take-while (negate (cut equal? <> "--")) args))
|
|
(options (getopt-long args option-spec #:stop-at-first-non-option #t))
|
|
(command (option-ref options 'command #f))
|
|
(opt? (lambda (name) (lambda (o) (and (eq? (car o) name) (cdr o)))))
|
|
(help? (option-ref options 'help #f))
|
|
(parse? (option-ref options 'parse #f))
|
|
(version? (option-ref options 'version #f))
|
|
(files (option-ref options '() '())))
|
|
(setopt! 'errexit (option-ref options 'errexit #f))
|
|
(setopt! 'xtrace (option-ref options 'xtrace #f))
|
|
(cond
|
|
(help? (display-help))
|
|
(version? (display-version))
|
|
(command (if (null? files)
|
|
(set-program-arguments (list (car (program-arguments))))
|
|
(set-program-arguments files))
|
|
(call-with-input-string command
|
|
(lambda (port)
|
|
(exit (run-repl port parse?)))))
|
|
((pair? files)
|
|
(let ((script (car files)))
|
|
(set-program-arguments files)
|
|
(call-with-input-file script
|
|
(lambda (port)
|
|
(exit (run-repl port parse?))))))
|
|
((isatty? (current-input-port))
|
|
(let* ((HOME (string-append (getenv "HOME") "/.gash_history"))
|
|
(thunk (lambda ()
|
|
(let loop ((line (readline (prompt))))
|
|
(when (not (eof-object? line))
|
|
(let ((ast (call-with-input-string line
|
|
(lambda (port) (read-sh port)))))
|
|
(when (and ast
|
|
(not (string-null? line)))
|
|
(unless parse?
|
|
(eval-sh ast))
|
|
(add-history line))
|
|
(loop (let ((previous (if ast "" (string-append line "\n")))
|
|
(next (readline (if ast (prompt) "> "))))
|
|
(if (eof-object? next) next
|
|
(string-append previous next))))))))))
|
|
(clear-history)
|
|
(read-history HOME)
|
|
(with-readline-completion-function completion thunk)
|
|
(write-history HOME)
|
|
(newline)))
|
|
(else (exit (run-repl (current-input-port) parse?))))))))
|
|
(thunk)))
|
|
|
|
(define prompt
|
|
(let* ((l (string #\001))
|
|
(r (string #\002))
|
|
(e (string #\033))
|
|
(user (getenv "USER"))
|
|
(host (gethostname))
|
|
(home (getenv "HOME")))
|
|
(lambda ()
|
|
(let* ((cwd (getcwd))
|
|
(cwd (if (string-prefix? home cwd)
|
|
(string-replace cwd "~" 0 (string-length home))
|
|
cwd)))
|
|
(string-append
|
|
l e "[01;32m" r user "@" host l e "[00m" r ":"
|
|
l e "[01;34m" r cwd l e "[00m" r (if (zero? (getuid)) "# " "$ "))))))
|
|
|
|
(define (string-prefix s1 s2)
|
|
(substring/read-only s1 0 (string-prefix-length s1 s2)))
|
|
|
|
(define next->file-completion (lambda () #f))
|
|
(define next->binary-completion (lambda () #f))
|
|
|
|
(define (isdir? path)
|
|
(and (access? path F_OK) (eq? 'directory (stat:type (stat path)))))
|
|
|
|
(define (ls dir)
|
|
(map (lambda (path)
|
|
(if (isdir? (string-append dir path))
|
|
(string-append path "/")
|
|
path))
|
|
(sort (filter (negate (cut string-every #\. <>))
|
|
(scandir (if (string-null? dir) (getcwd) dir))) string<?)))
|
|
|
|
(define (complete prefix list)
|
|
(if (string-null? prefix) list
|
|
(filter (cut string-prefix? prefix <>) list)))
|
|
|
|
(define (slash dir)
|
|
(if (string-suffix? "/" dir) dir
|
|
(string-append dir "/")))
|
|
|
|
(define (after-slash path)
|
|
(let ((at (string-index-right path #\/)))
|
|
(if at (string-drop path (+ 1 at))
|
|
path)))
|
|
|
|
|
|
(define (file-name-completion text continue?)
|
|
(if continue?
|
|
(next->file-completion)
|
|
(let* ((dir (slash (if (isdir? text) text (dirname text))))
|
|
(listing (ls dir))
|
|
(dir (if (string=? "./" dir) "" dir))
|
|
(completions (complete (after-slash text) listing)))
|
|
(set! next->file-completion
|
|
(lambda ()
|
|
(if (null? completions)
|
|
#f
|
|
(let ((completion (car completions)))
|
|
(set! completions (cdr completions))
|
|
(string-append dir completion)))))
|
|
(next->file-completion))))
|
|
|
|
(define (search-binary-in-path-completion text continue?)
|
|
(if (not continue?)
|
|
(let* ((paths (string-split (getenv "PATH") #\:))
|
|
(binaries (apply append (filter identity (map scandir paths))))
|
|
(completions (sort (filter (cut string-prefix? text <>) binaries) string<?)))
|
|
(set! next->binary-completion (lambda ()
|
|
(if (null? completions)
|
|
#f
|
|
(let ((completion (car completions)))
|
|
(set! completions (cdr completions))
|
|
completion))))
|
|
(next->binary-completion))
|
|
(next->binary-completion)))
|
|
|
|
(define (completion text continue?)
|
|
(or (file-name-completion text continue?) (search-binary-in-path-completion text continue?)))
|