255 lines
6.6 KiB
Scheme
255 lines
6.6 KiB
Scheme
(define (standard-command-plugin-completer command args)
|
|
#f)
|
|
|
|
;; helper functions for globbing
|
|
|
|
(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)))
|
|
|
|
;; expand command list:
|
|
;; - substiute environment vars in strings with their values
|
|
;; - globbing
|
|
|
|
(define (env-var-name str)
|
|
(cond
|
|
((regexp-search
|
|
(rx (: #\$ (? #\{) (submatch (+ (- ascii #\}))) (? #\}))) str)
|
|
=> (lambda (matches)
|
|
(match:substring matches 1)))
|
|
(else #f)))
|
|
|
|
(define (lookup-env-var var)
|
|
(cond
|
|
((assoc var (env->alist))
|
|
=> cdr)
|
|
(else
|
|
(error "Undefined environment variable" var))))
|
|
|
|
(define (substitute-env-vars str)
|
|
(cond
|
|
((env-var-name str)
|
|
=> lookup-env-var)
|
|
(else str)))
|
|
|
|
(define (expand-string str)
|
|
(substitute-env-vars str))
|
|
|
|
(define (expand-redirection redirection)
|
|
(make-redirection
|
|
(redirection-op redirection)
|
|
(expand-string (redirection-dest redirection))))
|
|
|
|
(define (expand-command command)
|
|
(let ((expanded (map expand-string (command-args command))))
|
|
(make-command
|
|
(expand-string (command-executable command))
|
|
(fold-right
|
|
(lambda (arg args)
|
|
(if (contains-glob-expression? arg)
|
|
(append (glob-argument arg) args)
|
|
(cons arg args)))
|
|
'() expanded)
|
|
(map expand-redirection (command-redirections command)))))
|
|
|
|
(define (expand-command-line command-line)
|
|
(make-command-line
|
|
(expand-command (command-line-first-cmd command-line))
|
|
(map (lambda (combinator.command)
|
|
(cons (car combinator.command)
|
|
(expand-command (cdr combinator.command))))
|
|
(command-line-combinator/cmds command-line))
|
|
(command-line-job-ctrl command-line)))
|
|
|
|
;; #####
|
|
;; it's a dumb idea to keep command and args separate, merge
|
|
;; this stuff
|
|
(define (standard-command-plugin-evaluater command args)
|
|
(let* ((parsed
|
|
(parse-command-line
|
|
(lex-command-line
|
|
(string-append command " "
|
|
(string-join args)))))
|
|
(expanded (expand-command-line parsed))
|
|
(s-expr (compile-command-line expanded)))
|
|
(debug-message "Compiled command " s-expr)
|
|
(eval-s-expr s-expr)))
|
|
|
|
(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))
|
|
|
|
;; Parse options for ls command using args-fold (SRFI 37)
|
|
;; We don't care for options that format the output.
|
|
|
|
(define defaults-ls-options
|
|
'((long . #t) (dot-files? . #t)
|
|
(sort-by-mtime . #f) (reverse-sort . #f)))
|
|
|
|
(define (parse-ls-arguments args)
|
|
(let* ((on/off-option-processor
|
|
(lambda (name)
|
|
(lambda (option arg-name arg ops)
|
|
(cons (cons name #t) ops))))
|
|
(long-option
|
|
(option '(#\l) #f #f
|
|
(on/off-option-processor 'long)))
|
|
(dotfiles-option
|
|
(option '(#\a) #f #f
|
|
(on/off-option-processor 'dot-files?)))
|
|
(sort-mtime-option
|
|
(option '(#\t) #f #f
|
|
(on/off-option-processor 'sort-by-mtime)))
|
|
(reverse-sort-option
|
|
(option '(#\r) #f #f
|
|
(on/off-option-processor 'reverse-sort))))
|
|
(let ((given-args
|
|
(args-fold
|
|
args
|
|
(list long-option dotfiles-option
|
|
sort-mtime-option reverse-sort-option)
|
|
(lambda (option name args operands)
|
|
(error "Unknown ls option" name))
|
|
cons '())))
|
|
(map (lambda (p)
|
|
(or (assoc (car p) given-args) p))
|
|
defaults-ls-options))))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin
|
|
"ls"
|
|
no-completer
|
|
(lambda (command args)
|
|
(let* ((options (parse-ls-arguments args))
|
|
(set? (lambda (opt) (cdr (assoc opt options))))
|
|
(sort
|
|
(if (set? 'sort-by-mtime)
|
|
(lambda (lst)
|
|
(list-sort
|
|
(lambda (f g)
|
|
(< (file-info:mtime (fs-object-info f))
|
|
(file-info:mtime (fs-object-info g))))
|
|
lst))
|
|
(lambda (lst)
|
|
(list-sort
|
|
(lambda (f g)
|
|
(string<? (fs-object-name f) (fs-object-name g)))
|
|
lst))))
|
|
(reverse
|
|
(if (set? 'reverse-sort)
|
|
reverse
|
|
(lambda (l) l))))
|
|
(reverse
|
|
(sort
|
|
(directory-files (cwd) (set? 'dot-files?))))))))
|
|
|
|
(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" "stopped" "output" "waiting-for-input"))
|
|
(lambda (command args)
|
|
(let ((selectors
|
|
`(("running" . ,running-jobs)
|
|
("ready" . ,ready-jobs)
|
|
("stopped" . ,stopped-jobs)
|
|
("output" . ,jobs-with-new-output)
|
|
("input" . ,jobs-waiting-for-input))))
|
|
(append-map
|
|
(lambda (arg)
|
|
(cond
|
|
((assoc arg selectors)
|
|
=> (lambda (p)
|
|
((cdr p))))))
|
|
(if (null? args)
|
|
(map car selectors)
|
|
(delete-duplicates args)))))))
|
|
|
|
(register-plugin!
|
|
(make-command-plugin
|
|
"ftp"
|
|
(lambda (command prefix args args-pos)
|
|
(cond
|
|
((getenv "FTPHOSTS")
|
|
=> string-tokenize)
|
|
(else
|
|
'("ftp.gnu.org" "ftp.x.org"))))
|
|
(lambda (command args)
|
|
(run/fg (,command ,@args)))))
|
|
|