164 lines
4.3 KiB
Scheme
164 lines
4.3 KiB
Scheme
;; ,open let-opt
|
|
(define (wait-for-key . optionals)
|
|
(let-optionals optionals
|
|
((tty-port (current-input-port)))
|
|
(let* ((old (tty-info tty-port))
|
|
(copy (copy-tty-info old)))
|
|
(set-tty-info:local-flags
|
|
copy
|
|
(bitwise-and (tty-info:local-flags copy)
|
|
(bitwise-not ttyl/canonical)))
|
|
(set-tty-info:min copy 1)
|
|
(set-tty-info:time copy 0)
|
|
(set-tty-info/now tty-port copy)
|
|
(let ((c (read-char tty-port)))
|
|
(set-tty-info/now tty-port old)
|
|
c))))
|
|
|
|
(define (standard-command-plugin-completer command args)
|
|
#f)
|
|
|
|
(define (show-shell-screen)
|
|
(def-prog-mode)
|
|
(endwin)
|
|
(display "Press any key to return to scsh-nuit...")
|
|
(wait-for-key))
|
|
|
|
(define (contains-glob-enumerator? arg)
|
|
(if-match
|
|
(regexp-search
|
|
(rx (: (submatch (* any)) ("{[") (* any) (submatch (* any)) ("]}")))
|
|
arg)
|
|
(whole-arg submatch-before submatch-after)
|
|
(not (or (string-suffix? "\\" submatch-before)
|
|
(string-suffix? "\\" submatch-after)))
|
|
#f))
|
|
|
|
(define (contains-glob-wildcard? arg)
|
|
(if-match
|
|
(regexp-search (rx (: (submatch (* any)) ("*?"))) arg)
|
|
(whole-arg submatch-before)
|
|
(not (string-suffix? "\\" submatch-before))
|
|
#f))
|
|
|
|
(define (contains-glob-expression? arg)
|
|
(or (contains-glob-wildcard? arg)
|
|
(contains-glob-enumerator? arg)))
|
|
|
|
(define (glob-argument arg)
|
|
(let ((files (glob arg)))
|
|
(if (null? files)
|
|
(error "no files match this glob expression" arg (cwd))
|
|
files)))
|
|
|
|
(define (expand-command-argument arg)
|
|
(let ((expanded (expand-file-name arg)))
|
|
(cond
|
|
((contains-glob-expression? arg)
|
|
(glob-argument expanded))
|
|
(else (list expanded)))))
|
|
|
|
(define (expand-argument-list args)
|
|
(fold-right
|
|
(lambda (arg expanded)
|
|
(append (expand-command-argument arg) expanded))
|
|
'() args))
|
|
|
|
(define (standard-command-plugin-evaluater command args)
|
|
(def-prog-mode)
|
|
(endwin)
|
|
(newline)
|
|
(let ((status (run (,command ,@(expand-argument-list args)))))
|
|
(newline)
|
|
(display "Press any key to return to scsh-nuit...")
|
|
(wait-for-key)
|
|
status))
|
|
|
|
(define standard-command-plugin
|
|
(make-command-plugin #f
|
|
standard-command-plugin-completer
|
|
standard-command-plugin-evaluater))
|
|
|
|
;; some common commands
|
|
|
|
(define no-completer (lambda args #f))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin
|
|
"ls"
|
|
no-completer
|
|
(lambda (command args)
|
|
(if (null? args)
|
|
(directory-files (cwd))
|
|
(let ((arg (file-name->fs-object
|
|
(expand-file-name (car args) (cwd)))))
|
|
(if (file-info-directory? (fs-object-info arg))
|
|
(directory-files (fs-object-complete-path arg))
|
|
arg))))))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin "ps"
|
|
no-completer
|
|
(lambda (command args)
|
|
(pps))))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin "pwd"
|
|
no-completer
|
|
(lambda (command args)
|
|
(cwd))))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin "cd"
|
|
no-completer
|
|
(lambda (command args)
|
|
(chdir (resolve-file-name (if (null? args)
|
|
"~"
|
|
(car args))))
|
|
(cwd))))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin "setenv"
|
|
no-completer
|
|
(lambda (command args)
|
|
(setenv (car args) (cadr args)))))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin "getenv"
|
|
no-completer
|
|
(lambda (command args)
|
|
(getenv (car args)))))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin "printenv"
|
|
no-completer
|
|
(lambda (command args)
|
|
(env->alist))))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin "exit"
|
|
no-completer
|
|
(lambda (command args)
|
|
(clear)
|
|
(exit (if (null? args)
|
|
0
|
|
(string->number (car args)))))))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin "jobs"
|
|
(lambda (command prefix args arg-pos)
|
|
'("running" "ready" "output" "waiting-for-input"))
|
|
(lambda (command args)
|
|
(append-map
|
|
(lambda (arg)
|
|
;; #### warn if argument is unknown
|
|
(cond
|
|
((assoc arg
|
|
`(("running" . ,running-jobs)
|
|
("ready" . ,ready-jobs)
|
|
("output" . ,jobs-with-new-output)
|
|
("input" . ,jobs-waiting-for-input)))
|
|
=> (lambda (p)
|
|
((cdr p))))))
|
|
(delete-duplicates args)))))
|