(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/s-expr v) (if (string? v) (substitute-env-vars v) v)) (define (expand-redirection redirection) (make-redirection (redirection-op redirection) (expand-string/s-expr (redirection-dest redirection)))) (define (expand-command command) (let ((expanded (map expand-string/s-expr (command-args command)))) (make-command (expand-string/s-expr (command-executable command)) (fold-right (lambda (arg args) (if (and (string? arg) (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 #f) (define just-run-in-foreground (lambda (command args) (run/fg (,command ,@args)))) (define just-run-in-background (lambda (command args) (run/bg (,command ,@args)))) ;; 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) (stringalist)))) (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 "latex" (make-completer-for-file-with-extension '(".tex")) just-run-in-foreground)) (register-plugin! (make-command-plugin "xdvi" (make-completer-for-file-with-extension '(".dvi")) just-run-in-background)) (register-plugin! (make-command-plugin "ftp" (let* ((hosts '("ftp.gnu.org" "ftp.x.org")) (cs (make-completion-set hosts))) (lambda (command to-complete) (debug-message "ftp completer " command "," to-complete) (completions-for cs (or (to-complete-prefix to-complete) "")))) (lambda (command args) (run/fg (,command ,@args)))))