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

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