2017-02-19 12:49:30 +00:00
|
|
|
(define-module (gash gash)
|
|
|
|
|
2018-06-26 19:34:07 +01:00
|
|
|
#:use-module (srfi srfi-1)
|
|
|
|
#:use-module (srfi srfi-26)
|
2017-02-05 21:58:22 +00:00
|
|
|
|
2018-06-26 19:34:07 +01:00
|
|
|
#: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 rdelim)
|
|
|
|
#:use-module (ice-9 readline)
|
|
|
|
#:use-module (ice-9 buffered-input)
|
2018-07-02 17:04:13 +01:00
|
|
|
#:use-module (ice-9 receive)
|
2018-06-26 19:34:07 +01:00
|
|
|
#:use-module (ice-9 regex)
|
2016-06-06 23:54:23 +01:00
|
|
|
|
2018-06-26 19:34:07 +01:00
|
|
|
#:use-module (gash job)
|
|
|
|
#:use-module (gash pipe)
|
|
|
|
#:use-module (gash peg)
|
|
|
|
#:use-module (gash io)
|
|
|
|
#:use-module (gash util)
|
2016-06-06 23:54:23 +01:00
|
|
|
|
2018-07-03 19:55:14 +01:00
|
|
|
#:export (main
|
|
|
|
shell-opt?))
|
2016-06-06 23:54:23 +01:00
|
|
|
|
2017-04-08 20:39:43 +01:00
|
|
|
(define (remove-shell-comments s)
|
|
|
|
(string-join (map
|
|
|
|
(lambda (s)
|
|
|
|
(let* ((n (string-index s #\#)))
|
|
|
|
(if n (string-pad-right s (string-length s) #\space 0 n)
|
|
|
|
s)))
|
|
|
|
(string-split s #\newline)) "\n"))
|
|
|
|
|
|
|
|
(define (remove-escaped-newlines s)
|
|
|
|
(reduce (lambda (next prev)
|
|
|
|
(let* ((escaped? (string-suffix? "\\" next))
|
|
|
|
(next (if escaped? (string-drop-right next 1) next))
|
|
|
|
(sep (if escaped? "" "\n")))
|
|
|
|
(string-append prev sep next)))
|
|
|
|
"" (string-split s #\newline)))
|
|
|
|
|
2016-09-17 18:31:58 +01:00
|
|
|
(define (file-to-string filename)
|
2017-04-08 20:39:43 +01:00
|
|
|
((compose read-string open-input-file) filename))
|
2016-09-17 18:31:58 +01:00
|
|
|
|
|
|
|
(define (string-to-ast string)
|
2017-04-08 20:39:43 +01:00
|
|
|
((compose parse remove-escaped-newlines remove-shell-comments) string))
|
2016-09-17 18:31:58 +01:00
|
|
|
|
|
|
|
(define (file-to-ast filename)
|
|
|
|
((compose string-to-ast file-to-string) filename))
|
|
|
|
|
2017-02-15 22:10:24 +00:00
|
|
|
(define (display-help)
|
|
|
|
(display "\
|
2017-02-19 12:49:30 +00:00
|
|
|
gash [options]
|
2018-07-02 19:20:54 +01:00
|
|
|
-c, --command=STRING Evaluate STRING and exit
|
|
|
|
-d, --debug Enable PEG tracing
|
|
|
|
-h, --help Display this help
|
|
|
|
-p, --parse Parse the shell script and print the parse tree
|
|
|
|
--prefer-builtins Use builtins, even if command is available in PATH
|
|
|
|
-v, --version Display the version
|
2016-06-06 23:54:23 +01:00
|
|
|
"))
|
2017-02-15 22:10:24 +00:00
|
|
|
|
|
|
|
(define (display-version)
|
|
|
|
(display "
|
2017-02-19 12:49:30 +00:00
|
|
|
GASH 0.1
|
2017-02-15 22:10:24 +00:00
|
|
|
|
2016-06-06 23:54:23 +01:00
|
|
|
Copryright (C) 2016 R.E.W. van Beusekom, rutger.van.beusekom@gmail.com.
|
|
|
|
|
2017-02-19 12:49:30 +00:00
|
|
|
This is gash, Guile As SHell. Gash is free software and is covered by
|
|
|
|
the GNU Public License, see COPYING for the copyleft.
|
2017-02-15 22:10:24 +00:00
|
|
|
|
2016-06-06 23:54:23 +01:00
|
|
|
"))
|
2017-02-15 22:10:24 +00:00
|
|
|
|
2018-07-03 19:38:30 +01:00
|
|
|
(define global-variables (list '("SHELLOPTS" . "")))
|
2017-04-08 20:39:43 +01:00
|
|
|
|
2017-02-15 22:10:24 +00:00
|
|
|
(define (main args)
|
2017-04-08 20:39:43 +01:00
|
|
|
(map (lambda (key-value)
|
|
|
|
(let* ((key-value (string-split key-value #\=))
|
|
|
|
(key (car key-value))
|
|
|
|
(value (cadr key-value)))
|
|
|
|
(set! global-variables (assoc-set! global-variables key value))))
|
|
|
|
(environ))
|
2017-02-15 22:10:24 +00:00
|
|
|
(let ((thunk
|
|
|
|
(lambda ()
|
|
|
|
(job-control-init)
|
2018-07-02 07:35:10 +01:00
|
|
|
(let* ((option-spec '((command (single-char #\c) (value #t))
|
|
|
|
(debug (single-char #\d) (value #f))
|
2017-02-15 22:10:24 +00:00
|
|
|
(help (single-char #\h) (value #f))
|
|
|
|
(parse (single-char #\p) (value #f))
|
2018-07-02 17:04:13 +01:00
|
|
|
(prefer-builtins)
|
2017-02-15 22:10:24 +00:00
|
|
|
(version (single-char #\v) (value #f))))
|
2018-07-02 07:35:10 +01:00
|
|
|
(options (getopt-long args option-spec #:stop-at-first-non-option #t ))
|
|
|
|
(command? (option-ref options 'command #f))
|
2017-02-15 22:10:24 +00:00
|
|
|
(help? (option-ref options 'help #f))
|
2018-07-02 07:35:10 +01:00
|
|
|
(parse? (option-ref options 'parse #f))
|
2017-02-15 22:10:24 +00:00
|
|
|
(version? (option-ref options 'version #f))
|
|
|
|
(files (option-ref options '() '()))
|
|
|
|
(run
|
|
|
|
(lambda (ast)
|
|
|
|
(cond (parse?
|
|
|
|
(let ((ast- (transform ast)))
|
2018-07-02 07:35:10 +01:00
|
|
|
(stdout "parsed: " ast)
|
|
|
|
(stdout "prepared: " ast-)
|
2017-02-15 22:10:24 +00:00
|
|
|
#t))
|
|
|
|
(#t
|
|
|
|
(sh-exec ast))))))
|
2018-07-02 17:04:13 +01:00
|
|
|
(set! %prefer-builtins? (option-ref options 'prefer-builtins #f))
|
2017-02-15 22:10:24 +00:00
|
|
|
(cond
|
|
|
|
(help? (display-help))
|
|
|
|
(version? (display-version))
|
2018-07-02 07:35:10 +01:00
|
|
|
(command? (let ((ast (string-to-ast command?)))
|
2018-07-02 19:20:54 +01:00
|
|
|
(exit (if ast (run ast)
|
|
|
|
0))))
|
2017-02-15 22:10:24 +00:00
|
|
|
((pair? files)
|
|
|
|
(let* ((asts (map file-to-ast files))
|
|
|
|
(status (map run asts)))
|
|
|
|
(quit (every identity status))))
|
2017-02-19 12:49:30 +00:00
|
|
|
(#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history"))
|
2017-02-15 22:10:24 +00:00
|
|
|
(thunk (lambda ()
|
|
|
|
(let loop ((line (readline (prompt))))
|
|
|
|
(when (not (eof-object? line))
|
|
|
|
(let ((ast (string-to-ast line)))
|
|
|
|
(when ast
|
|
|
|
(if (not (string-null? line))
|
|
|
|
(add-history line))
|
|
|
|
(run ast))
|
|
|
|
(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)))))))
|
2016-11-01 21:33:08 +00:00
|
|
|
(thunk)))
|
2016-06-06 23:54:23 +01:00
|
|
|
|
2016-10-10 08:55:38 +01:00
|
|
|
(define (expand identifier o) ;;identifier-string -> symbol
|
2016-11-01 13:40:17 +00:00
|
|
|
(define (expand- o)
|
2016-10-10 08:55:38 +01:00
|
|
|
(let ((dollar-identifier (string-append "$" identifier)))
|
|
|
|
(match o
|
|
|
|
((? symbol?) o)
|
|
|
|
((? string?) (if (string=? o dollar-identifier) (string->symbol identifier) o))
|
2016-11-01 13:40:17 +00:00
|
|
|
((? list?) (map expand- o))
|
|
|
|
(_ o))))
|
|
|
|
(map expand- o))
|
2016-10-10 08:55:38 +01:00
|
|
|
|
2016-10-10 22:09:58 +01:00
|
|
|
|
2016-11-01 10:25:36 +00:00
|
|
|
;; TODO: add braces
|
2016-10-10 22:09:58 +01:00
|
|
|
(define (glob pattern) ;; pattern -> list of path
|
2016-11-02 23:39:18 +00:00
|
|
|
|
2016-10-11 09:44:09 +01:00
|
|
|
(define (glob? pattern)
|
|
|
|
(string-match "\\?|\\*" pattern))
|
|
|
|
|
2016-10-10 22:09:58 +01:00
|
|
|
(define (glob2regex pattern)
|
2017-02-05 21:58:22 +00:00
|
|
|
(let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post))
|
|
|
|
(pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post))
|
|
|
|
(pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post)))
|
|
|
|
(make-regexp (string-append "^" pattern "$"))))
|
2016-10-10 22:09:58 +01:00
|
|
|
|
2016-11-01 21:33:08 +00:00
|
|
|
(define (glob-match regex path) ;; pattern path -> bool
|
|
|
|
(regexp-match? (regexp-exec regex path)))
|
2016-10-10 22:09:58 +01:00
|
|
|
|
|
|
|
(define (glob- pattern paths)
|
2016-11-02 23:39:18 +00:00
|
|
|
(map (lambda (path)
|
|
|
|
(if (string-prefix? "./" path) (string-drop path 2) path))
|
|
|
|
(append-map (lambda (path)
|
|
|
|
(map (cute string-append (if (string=? "/" path) "" path) "/" <>)
|
|
|
|
(filter (conjoin (negate (cut string-prefix? "." <>))
|
|
|
|
(cute glob-match (glob2regex pattern) <>))
|
|
|
|
(or (scandir path) '()))))
|
|
|
|
paths)))
|
2018-07-02 18:55:19 +01:00
|
|
|
(pk 'pattern: pattern 'glob:
|
|
|
|
(cond
|
|
|
|
((not pattern) '(""))
|
2018-07-03 19:08:44 +01:00
|
|
|
((string=? "$?" pattern) (list (assoc-ref global-variables "?")))
|
2018-07-02 18:55:19 +01:00
|
|
|
((glob? pattern) (let ((absolute? (string-prefix? "/" pattern)))
|
|
|
|
(let loop ((patterns (filter (negate string-null?) (string-split pattern #\/)))
|
|
|
|
(paths (if absolute? '("/") '("."))))
|
|
|
|
(if (null? patterns)
|
|
|
|
paths
|
|
|
|
(loop (cdr patterns) (glob- (car patterns) paths))))))
|
|
|
|
(#t (list pattern)))))
|
2016-10-10 22:09:58 +01:00
|
|
|
|
2017-02-12 12:10:23 +00:00
|
|
|
(define (background ast)
|
|
|
|
(match ast
|
|
|
|
(('pipeline fg rest ...) `(pipeline #f ,@rest))
|
|
|
|
(_ ast)))
|
|
|
|
|
2018-07-02 17:04:13 +01:00
|
|
|
(define (PATH-search-path program)
|
|
|
|
(search-path (string-split (getenv "PATH") #\:) program))
|
|
|
|
|
|
|
|
(define (cd-command . args)
|
|
|
|
(match args
|
|
|
|
(() (chdir (getenv "HOME")))
|
|
|
|
((dir)
|
|
|
|
(chdir dir))
|
|
|
|
((args ...)
|
|
|
|
(format (current-error-port) "cd: too many arguments: ~a\n" (string-join args)))))
|
|
|
|
|
|
|
|
(define (echo-command . args)
|
|
|
|
(match args
|
|
|
|
(() (newline))
|
2018-07-02 18:55:19 +01:00
|
|
|
(("-n" args ...) (map display args))
|
|
|
|
(_ (map display args) (newline))))
|
2018-07-02 17:04:13 +01:00
|
|
|
|
|
|
|
(define (bg-command . args)
|
|
|
|
(match args
|
|
|
|
(() (bg 1))
|
|
|
|
((job x ...) (bg (string->number (car job))))))
|
|
|
|
|
|
|
|
(define (fg-command . args)
|
|
|
|
(match args
|
|
|
|
(() (fg 1))
|
|
|
|
((job x ...) (fg (string->number (car job))))))
|
|
|
|
|
|
|
|
(define pwd-command (lambda _ (stdout (getcwd))))
|
|
|
|
|
2018-07-02 18:03:21 +01:00
|
|
|
(define (set-command . args) ;; TODO export; env vs set
|
|
|
|
(define (display-var o)
|
|
|
|
(format #t "~a=~a\n" (car o) (cdr o)))
|
2018-07-03 19:38:30 +01:00
|
|
|
(match args
|
|
|
|
(() (for-each display-var global-variables))
|
|
|
|
(("-e") (set-shell-opt "errexit" #t))
|
|
|
|
(("+e") (set-shell-opt "errexit" #f))
|
|
|
|
(("-x") (set-shell-opt "xtrace" #t))
|
|
|
|
(("+x") (set-shell-opt "xtrace" #f))))
|
|
|
|
|
2018-07-03 19:40:47 +01:00
|
|
|
(define (exit-command . args)
|
|
|
|
(match args
|
|
|
|
(() (exit 0))
|
|
|
|
((status)
|
|
|
|
(exit (string->number status)))
|
|
|
|
((args ...)
|
|
|
|
(format (current-error-port) "exit: too many arguments: ~a\n" (string-join args)))))
|
|
|
|
|
2018-07-03 19:38:30 +01:00
|
|
|
(define (set-shell-opt name set?)
|
|
|
|
(let* ((shell-opts (assoc-ref global-variables "SHELLOPTS"))
|
|
|
|
(options (if (string-null? shell-opts) '()
|
|
|
|
(string-split shell-opts #\:)))
|
|
|
|
(new-options (if set? (delete-duplicates (sort (cons name options) string<))
|
|
|
|
(filter (negate (cut equal? <> name)) options)))
|
|
|
|
(new-shell-opts (string-join new-options ":")))
|
|
|
|
(set! global-variables (assoc-set! global-variables "SHELLOPTS" new-shell-opts))))
|
|
|
|
|
|
|
|
(define (shell-opt? name)
|
|
|
|
(member name (string-split (assoc-ref global-variables "SHELLOPTS") #\:)))
|
2018-07-02 17:04:13 +01:00
|
|
|
|
|
|
|
(define %commands
|
|
|
|
;; Built-in commands.
|
|
|
|
`(
|
|
|
|
("echo" . ,echo-command)
|
|
|
|
("cd" . ,cd-command)
|
|
|
|
("pwd" . ,pwd-command)
|
|
|
|
("jobs" . ,jobs-command)
|
|
|
|
("bg" . ,bg-command)
|
|
|
|
("fg" . ,fg-command)
|
2018-07-02 18:03:21 +01:00
|
|
|
("set" . ,set-command)
|
2018-07-03 19:40:47 +01:00
|
|
|
("exit" . ,exit-command)
|
2018-07-02 17:04:13 +01:00
|
|
|
|
|
|
|
;; 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)
|
|
|
|
|
|
|
|
))
|
|
|
|
|
|
|
|
(define %prefer-builtins? #t) ; use builtin, even if COMMAND is available in PATH?
|
2016-10-11 09:44:09 +01:00
|
|
|
(define (builtin ast)
|
2018-07-02 17:04:13 +01:00
|
|
|
(receive (command args)
|
|
|
|
(match ast
|
|
|
|
((('append ('glob command) args ...)) (values command args))
|
|
|
|
((('glob command)) (values command #f))
|
|
|
|
(_ (values #f #f)))
|
|
|
|
(let ((program (and command (PATH-search-path command))))
|
|
|
|
(format (current-error-port) "command ~a => ~s ~s\n" program command args)
|
|
|
|
(cond ((and program (not %prefer-builtins?))
|
|
|
|
#f)
|
|
|
|
((and command (assoc-ref %commands command))
|
|
|
|
=>
|
|
|
|
(lambda (command)
|
|
|
|
(if args
|
|
|
|
`(,apply ,command ,@args)
|
|
|
|
`(,command))))
|
|
|
|
(else
|
|
|
|
(match ast
|
|
|
|
(('for-each rest ...) ast)
|
|
|
|
(('if rest ...) ast)
|
|
|
|
(#t #t)
|
|
|
|
(_ #f)))))))
|
2016-10-11 09:44:09 +01:00
|
|
|
|
2016-10-30 23:19:44 +00:00
|
|
|
;; transform ast -> list of expr
|
|
|
|
;; such that (map eval expr)
|
|
|
|
|
2016-06-06 23:54:23 +01:00
|
|
|
(define (transform ast)
|
|
|
|
(match ast
|
2016-11-01 10:25:36 +00:00
|
|
|
(('script term "&") (list (background (transform term))))
|
2017-02-15 22:10:24 +00:00
|
|
|
(('script term) `(,(transform term)))
|
2016-10-30 23:19:44 +00:00
|
|
|
(('script terms ...) (transform terms))
|
2017-05-15 22:14:54 +01:00
|
|
|
(('substitution "$(" script ")") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment)))
|
|
|
|
(('substitution "`" script "`") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment)))
|
2017-02-15 22:10:24 +00:00
|
|
|
((('term command)) `(,(transform command)))
|
2016-10-30 23:19:44 +00:00
|
|
|
((('term command) ...) (map transform command))
|
|
|
|
((('term command) (('term commands) ...)) (map transform (cons command commands)))
|
|
|
|
(('compound-list terms ...) (transform terms))
|
2017-02-12 12:10:23 +00:00
|
|
|
(('if-clause "if" (expression "then" consequent "fi"))
|
|
|
|
`(if (equal? 0 (status:exit-val ,@(transform expression)))
|
|
|
|
(begin ,@(transform consequent))))
|
|
|
|
(('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi"))
|
|
|
|
`(if (equal? 0 (status:exit-val ,@(transform expression)))
|
|
|
|
(begin ,@(transform consequent))
|
|
|
|
(begin ,@(transform alternative))))
|
|
|
|
(('for-clause ("for" identifier sep do-group)) #t)
|
|
|
|
(('for-clause "for" ((identifier "in" lst sep) do-group))
|
|
|
|
`(for-each (lambda (,(string->symbol identifier))
|
|
|
|
(begin ,@(expand identifier (transform do-group))))
|
|
|
|
(glob ,(transform lst))))
|
2016-10-10 08:55:38 +01:00
|
|
|
(('do-group "do" (command "done")) (transform command))
|
2017-02-15 22:11:58 +00:00
|
|
|
(('pipeline command) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command))))
|
|
|
|
(('pipeline command piped-commands) `(pipeline #t ,@(transform command) ,@(transform piped-commands)))
|
2017-04-08 20:39:43 +01:00
|
|
|
(('simple-command ('word (assignment name value))) (set! global-variables (assoc-set! global-variables (transform name) (transform value))) #t)
|
2017-02-15 22:11:58 +00:00
|
|
|
(('simple-command ('word s)) `((glob ,(transform s))))
|
|
|
|
(('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1))))
|
|
|
|
(('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2)))))
|
|
|
|
(('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))))
|
2017-04-08 20:39:43 +01:00
|
|
|
(('variable s) (assoc-ref global-variables (string-drop s 1)))
|
2016-09-19 21:07:46 +01:00
|
|
|
(('literal s) (transform s))
|
2017-02-15 22:10:24 +00:00
|
|
|
(('singlequotes s) (string-concatenate `("'" ,s "'")))
|
|
|
|
(('doublequotes s) (string-concatenate `("\"" ,s "\"")))
|
|
|
|
(('backticks s) (string-concatenate `("`" ,s "`")))
|
2016-09-19 21:07:46 +01:00
|
|
|
(('delim ('singlequotes s ...)) (string-concatenate (map transform s)))
|
|
|
|
(('delim ('doublequotes s ...)) (string-concatenate (map transform s)))
|
|
|
|
(('delim ('backticks s ...)) (string-concatenate (map transform s)))
|
2017-02-15 22:11:58 +00:00
|
|
|
((('pipe _) command) (transform command))
|
|
|
|
(((('pipe _) command) ...) (map (compose car transform) command))
|
2016-10-11 09:44:09 +01:00
|
|
|
((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...)
|
2016-10-18 08:15:53 +01:00
|
|
|
(_ ast))) ;; done
|
2016-06-06 23:54:23 +01:00
|
|
|
|
2016-10-13 22:40:44 +01:00
|
|
|
(define (sh-exec ast)
|
2016-10-10 13:41:51 +01:00
|
|
|
(define (exec cmd)
|
2018-07-02 18:03:21 +01:00
|
|
|
(format (current-error-port) "sh-exec:exec cmd=~s\n" cmd)
|
2016-10-10 13:41:51 +01:00
|
|
|
(local-eval cmd (the-environment)))
|
2017-12-07 21:46:21 +00:00
|
|
|
(let ((ast (transform ast)))
|
2016-10-13 22:40:44 +01:00
|
|
|
(match ast
|
2016-10-18 08:15:53 +01:00
|
|
|
('script #t) ;; skip
|
2018-07-02 18:03:21 +01:00
|
|
|
(_ (let* ((job (map exec ast))
|
|
|
|
(stati (append-map (lambda (o)
|
|
|
|
(cond ((job? o) (job-status o))
|
|
|
|
((boolean? o) (list (if o 0 1)))
|
|
|
|
(else (list 0)))) ; some commands return a string?
|
|
|
|
job))
|
2018-07-03 19:08:44 +01:00
|
|
|
(stati (map status:exit-val stati))
|
|
|
|
(status (or (find (negate zero?) stati) 0))
|
|
|
|
;; mimick BASH for now
|
|
|
|
(pipestatus (string-append
|
|
|
|
"("
|
|
|
|
(string-join
|
|
|
|
(map (lambda (s i)
|
|
|
|
(format #f "[~a]=\"~a\"" s i))
|
|
|
|
stati
|
|
|
|
(iota (length stati))))
|
|
|
|
")")))
|
|
|
|
(set! global-variables (assoc-set! global-variables "PIPESTATUS" pipestatus))
|
|
|
|
(set! global-variables (assoc-set! global-variables "?" (number->string status)))
|
2018-07-03 19:38:30 +01:00
|
|
|
(when (and (not (zero? status))
|
|
|
|
(shell-opt? "errexit"))
|
|
|
|
(exit status))
|
2018-07-02 19:20:54 +01:00
|
|
|
status)))))
|
2016-06-06 23:54:23 +01:00
|
|
|
|
2016-11-01 21:33:08 +00:00
|
|
|
(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)))
|
|
|
|
(report-jobs)
|
|
|
|
(string-append
|
|
|
|
l e "[01;32m" r user "@" host l e "[00m" r ":"
|
|
|
|
l e "[01;34m" r cwd l e "[00m" r "$ ")))))
|
2016-06-06 23:54:23 +01:00
|
|
|
|
2016-11-02 20:53:08 +00:00
|
|
|
(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 (filename-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 (filename-completion text continue?) (search-binary-in-path-completion text continue?)))
|