;;; Gash --- Guile As SHell ;;; Copyright © 2016,2017,2018 R.E.W. van Beusekom ;;; Copyright © 2018, 2019 Timothy Sample ;;; 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 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 , Copyright (C) 2017,2018 Timothy Sample , 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) 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) stringbinary-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?)))