Refactor builtin commands.
* gash/gash.scm (main): Handle --prefer-builtins. (display-help): Mention it. (bg-command, cd-command, echo-command, pwd-command, fg-command): New functions. (%commands): New variable. (builtin): Use it.
This commit is contained in:
parent
01bfb484dc
commit
d79936f561
103
gash/gash.scm
103
gash/gash.scm
|
@ -10,6 +10,7 @@
|
||||||
#:use-module (ice-9 rdelim)
|
#:use-module (ice-9 rdelim)
|
||||||
#:use-module (ice-9 readline)
|
#:use-module (ice-9 readline)
|
||||||
#:use-module (ice-9 buffered-input)
|
#:use-module (ice-9 buffered-input)
|
||||||
|
#:use-module (ice-9 receive)
|
||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
|
|
||||||
#:use-module (gash job)
|
#:use-module (gash job)
|
||||||
|
@ -48,10 +49,11 @@
|
||||||
(define (display-help)
|
(define (display-help)
|
||||||
(display "\
|
(display "\
|
||||||
gash [options]
|
gash [options]
|
||||||
-d, --debug Enable PEG tracing
|
-d, --debug Enable PEG tracing
|
||||||
-h, --help Display this help
|
-h, --help Display this help
|
||||||
-p, --parse Parse the shell script and print the parse tree
|
-p, --parse Parse the shell script and print the parse tree
|
||||||
-v, --version Display the version
|
--prefer-builtins Use builtins, even if command is available in PATH
|
||||||
|
-v, --version Display the version
|
||||||
"))
|
"))
|
||||||
|
|
||||||
(define (display-version)
|
(define (display-version)
|
||||||
|
@ -81,6 +83,7 @@ the GNU Public License, see COPYING for the copyleft.
|
||||||
(debug (single-char #\d) (value #f))
|
(debug (single-char #\d) (value #f))
|
||||||
(help (single-char #\h) (value #f))
|
(help (single-char #\h) (value #f))
|
||||||
(parse (single-char #\p) (value #f))
|
(parse (single-char #\p) (value #f))
|
||||||
|
(prefer-builtins)
|
||||||
(version (single-char #\v) (value #f))))
|
(version (single-char #\v) (value #f))))
|
||||||
(options (getopt-long args option-spec #:stop-at-first-non-option #t ))
|
(options (getopt-long args option-spec #:stop-at-first-non-option #t ))
|
||||||
(command? (option-ref options 'command #f))
|
(command? (option-ref options 'command #f))
|
||||||
|
@ -97,6 +100,7 @@ the GNU Public License, see COPYING for the copyleft.
|
||||||
#t))
|
#t))
|
||||||
(#t
|
(#t
|
||||||
(sh-exec ast))))))
|
(sh-exec ast))))))
|
||||||
|
(set! %prefer-builtins? (option-ref options 'prefer-builtins #f))
|
||||||
(cond
|
(cond
|
||||||
(help? (display-help))
|
(help? (display-help))
|
||||||
(version? (display-version))
|
(version? (display-version))
|
||||||
|
@ -176,21 +180,84 @@ the GNU Public License, see COPYING for the copyleft.
|
||||||
(('pipeline fg rest ...) `(pipeline #f ,@rest))
|
(('pipeline fg rest ...) `(pipeline #f ,@rest))
|
||||||
(_ ast)))
|
(_ ast)))
|
||||||
|
|
||||||
|
(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))
|
||||||
|
(("-n" args ...) (display (string-join args)))
|
||||||
|
(_ (stdout (string-join args)))))
|
||||||
|
|
||||||
|
(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))))
|
||||||
|
|
||||||
|
|
||||||
|
(define %commands
|
||||||
|
;; Built-in commands.
|
||||||
|
`(
|
||||||
|
("echo" . ,echo-command)
|
||||||
|
("cd" . ,cd-command)
|
||||||
|
("pwd" . ,pwd-command)
|
||||||
|
("jobs" . ,jobs-command)
|
||||||
|
("bg" . ,bg-command)
|
||||||
|
("fg" . ,fg-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)
|
||||||
|
|
||||||
|
))
|
||||||
|
|
||||||
|
(define %prefer-builtins? #t) ; use builtin, even if COMMAND is available in PATH?
|
||||||
(define (builtin ast)
|
(define (builtin ast)
|
||||||
;;(stdout "builtin: " ast "\n")
|
(receive (command args)
|
||||||
(match ast
|
(match ast
|
||||||
((('append ('glob "cd") arg)) `(apply chdir ,arg))
|
((('append ('glob command) args ...)) (values command args))
|
||||||
((('append ('glob "fg") ('glob arg))) `(fg ,(string->number arg)))
|
((('glob command)) (values command #f))
|
||||||
((('append ('glob "bg") ('glob arg))) `(bg ,(string->number arg)))
|
(_ (values #f #f)))
|
||||||
((('append ('glob "echo") args ...)) `(stdout (string-join ,@args " ")))
|
(let ((program (and command (PATH-search-path command))))
|
||||||
((('glob "echo")) `(stdout))
|
(format (current-error-port) "command ~a => ~s ~s\n" program command args)
|
||||||
((('glob "fg")) `(fg 1))
|
(cond ((and program (not %prefer-builtins?))
|
||||||
((('glob "bg")) `(bg 1))
|
#f)
|
||||||
((('glob "jobs")) `(jobs))
|
((and command (assoc-ref %commands command))
|
||||||
(('for-each rest ...) ast)
|
=>
|
||||||
(('if rest ...) ast)
|
(lambda (command)
|
||||||
(#t #t)
|
(if args
|
||||||
(_ #f)))
|
`(,apply ,command ,@args)
|
||||||
|
`(,command))))
|
||||||
|
(else
|
||||||
|
(match ast
|
||||||
|
(('for-each rest ...) ast)
|
||||||
|
(('if rest ...) ast)
|
||||||
|
(#t #t)
|
||||||
|
(_ #f)))))))
|
||||||
|
|
||||||
;; transform ast -> list of expr
|
;; transform ast -> list of expr
|
||||||
;; such that (map eval expr)
|
;; such that (map eval expr)
|
||||||
|
|
|
@ -13,7 +13,7 @@
|
||||||
job-control-init
|
job-control-init
|
||||||
job-debug-id
|
job-debug-id
|
||||||
job-setup-process
|
job-setup-process
|
||||||
jobs
|
jobs-command
|
||||||
new-job
|
new-job
|
||||||
report-jobs
|
report-jobs
|
||||||
wait))
|
wait))
|
||||||
|
@ -65,10 +65,8 @@
|
||||||
(stdout "[" (job-id job) "] " (map status->state (job-status job)) "\t\t"
|
(stdout "[" (job-id job) "] " (map status->state (job-status job)) "\t\t"
|
||||||
(job-command job)))
|
(job-command job)))
|
||||||
|
|
||||||
(define (jobs)
|
(define (jobs-command)
|
||||||
(map (lambda (job)
|
(for-each (lambda (job) (display-job job)) (reverse job-table)))
|
||||||
(display-job job))
|
|
||||||
(reverse job-table)))
|
|
||||||
|
|
||||||
(define (job-status job)
|
(define (job-status job)
|
||||||
(map process-status (job-processes job)))
|
(map process-status (job-processes job)))
|
||||||
|
|
Loading…
Reference in New Issue