commander-s/scheme/std-command.scm

(define (standard-command-plugin-completer command args)
  #f)

(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)))))

(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 (,command ,@args)))))