Support POSIX job control, sort of.

scheme/job-viewer.scm

@@ -12,9 +12,9 @@
     (cond 
      ((job-running? job) "running")
      ((job-ready? job) "ready")
-     ((job-waiting-for-input? job) "stop/input")
+     ((job-waiting-for-input? job) "waiting for input")
-     ((and (job-end-time job)
+     ((job-has-new-output? job) "waiting with output")
-	   (job-has-new-output? job) "ready/output"))
+     ((job-stopped? job) "stopped")
      (else "run/output"))))
 
 (define (format-job job num-cols)
@@ -125,31 +125,33 @@
 		   (append
 		    (list (fill-up-string 15 (cadr args)))
 		    (cddr args))))))
-	(list
+	`((,(job-name->string (job-name job))
-	 (list (job-name->string (job-name job))
+	   "name:" ,(job-name->string (job-name job)))
-	       "name:" (job-name->string (job-name job)))
+	  (,(if (job-end-time job) 
-	 (list (if (job-end-time job) 
+		(number->string (job-status job)) #f)
-		   (number->string (job-status job)) #f)
+	   "status:" 
-	       "status:" 
+	   ,(if (job-end-time job)
-	       (if (job-end-time job)
+		(number->string (job-status job))
-		   (number->string (job-status job))
+		"-"))
-		   "-"))
+	  (,(job-start-time job) 
-	 (list (job-start-time job) 
+	   "start:"
-	       "start:"
+	   ,(short-date (job-start-time job)))
-	       (short-date (job-start-time job)))
+	  (,(job-end-time job)
-	 (list (job-end-time job)
+	   "end:"
-	       "end:"
+	   ,(if (job-end-time job)
-	       (if (job-end-time job)
+		(short-date (job-end-time job))
-		   (short-date (job-end-time job))
+		"-"))
-		   "-"))
+	  (#f "run status:"
-	 (list #f "run status:"
+	      ,(format-job-run-state job))
-	       (symbol->string (job-run-status job)))
+	  ,@(if (job-with-console? job)
-	 (list (job-console job)
+		`((,(job-console job) "<View Console>" ""))
-	       "<View Console>" "")))
+		'())))
        (- (result-buffer-num-lines buffer) 1)))
 
     (define (handle-key-press self key control-x-pressed?)
       (cond
+       ((= key (char->ascii #\f))
+	(continue-job-in-foreground job))
        ((= key (char->ascii #\g))
 	(set! select-list (make-job-select-list job)))
        ((= key (char->ascii #\newline))

scheme/job.scm

@@ -6,7 +6,7 @@
   (name job-name)
   (console job-console)
   (proc job-proc)
-  (status really-job-status)
+  (status really-job-status set-job-status!)
   (start-time job-start-time)
   (end-time job-end-time set-job-end-time!)
   (run-status job-run-status set-job-run-status!))
@@ -15,7 +15,7 @@
   (lambda (r)
     `(job ,(job-name r) ,(job-run-status r))))
 
-(define (make-job name pty-in pty-out terminal-buffer proc)
+(define (make-job-with-console name proc pty-in pty-out terminal-buffer)
   (let ((job (really-make-job 
 	      name 
 	      (make-console pty-in pty-out 
@@ -27,6 +27,20 @@
     (add-job! job)
     job))
 
+(define (make-job-sans-console name proc)
+  (let ((job (really-make-job 
+	      name #f proc (make-placeholder) 
+	      (date) #f 'running)))
+    (spawn-job-status-surveillant job)
+    (add-job! job)
+    job))
+
+(define (job-with-console? v)
+  (and (job? v) (job-console v)))
+
+(define (job-sans-console? v)
+  (not (job-with-console? v)))
+
 (define (job-status-rv job)
   (placeholder-value-rv (really-job-status job)))
 
@@ -37,9 +51,27 @@
   (let ((channel (make-channel)))
     (spawn
      (lambda ()
-       (let ((status (wait (job-proc job))))
+       (let ((status (wait (job-proc job) wait/stopped-children)))
-	 (set-job-end-time! job (date))
+	 (cond 
-	 (set-job-run-status! job 'ready)
+	  ((status:exit-val status) 
+	   => (lambda (i)
+		(debug-message "spawn-job-status-surveillant exit-val")
+		(set-job-run-status! job 'ready)
+		(set-job-end-time! job (date))))
+	   ((status:stop-sig status)
+	    => (lambda (signal)
+		 (debug-message "spawn-job-status-surveillant stop-sig")
+		 (cond
+		  ((= signal signal/ttin)
+		   (set-job-run-status! job 'waiting-for-input))
+		  ((= signal signal/ttou)
+		   (set-job-run-status! job 'new-output))
+		  (else
+		   (set-job-run-status! job 'stopped)))))
+	   ((status:term-sig status)
+	    => (lambda (i)
+		 (debug-message "spawn-job-status-surveillant term-sig")
+		 (set-job-run-status! job 'stopped))))
 	 (placeholder-set! 
 	  (really-job-status job) status))))))
 
@@ -55,6 +87,9 @@
 (define (job-has-new-output? job)
   (eq? (job-run-status job) 'new-output))
 
+(define (job-stopped? job)
+  (eq? (job-run-status job) 'stopped))
+
 (define (signal-job signal job)
   (signal-process-group signal (job-proc job)))
   
@@ -62,7 +97,11 @@
   (signal-job signal/stop job))
 
 (define (continue-job job)
-  (signal-process-group signal/cont job))
+  (set-job-status! job (make-placeholder))
+  (set-job-run-status! job 'running)
+  (signal-process-group 
+   (proc:pid (job-proc job)) signal/cont)
+  (spawn-job-status-surveillant job))
 
 (define (pause-job-output job)
   (pause-console-output (job-console job)))
@@ -70,6 +109,24 @@
 (define (resume-job-output job)
   (resume-console-output (job-console job)))
 
+(define (continue-job-in-foreground job)
+  (if (job-sans-console? job)
+      (begin
+	(drain-tty (current-output-port))
+	(def-prog-mode)
+	(endwin)
+	(newline)
+	(drain-tty (current-output-port))
+	(obtain-lock paint-lock)
+	(set-tty-process-group 
+	 (current-output-port) (proc:pid (job-proc job)))
+	(continue-job job)
+	(job-status job)
+	(set-tty-process-group (current-output-port) (pid))
+	(display "Press any key to return to Commander S...")
+	(wait-for-key)
+	(release-lock paint-lock))))
+
 ;; channels for communicating with the joblist surveillant
 
 (define add-job-channel
@@ -113,17 +170,22 @@
      (lambda ()
        (let lp ((running '()) 
 		(ready '())
+		(stopped '())
 		(new-output '())
 		(waiting-for-input '())
 		(notify? #f))
+	 (debug-message "spawn-joblist-surveillant "
+			running " " ready " " stopped " "
+			new-output " " waiting-for-input " " notify?)
 	 (cond
 	  (notify?
 	   (send statistics-channel
 		 (list (cons 'running (length running))
 		       (cons 'ready (length ready))
+		       (cons 'stopped (length stopped))
 		       (cons 'new-output (length new-output))
 		       (cons 'waiting-for-input (length waiting-for-input))))
-	   (lp running ready new-output waiting-for-input #f))
+	   (lp running ready stopped new-output waiting-for-input #f))
 	  (else
 	   (apply
 	    select
@@ -131,12 +193,12 @@
 	     (list
 	      (wrap (receive-rv add-job-channel)
 		    (lambda (new-job)
-		      (lp (cons new-job running) 
+		      (lp (cons new-job running)
-			  ready new-output waiting-for-input #t)))
+			  ready stopped new-output waiting-for-input #t)))
 
 	      (wrap (receive-rv clear-ready-jobs-channel)
 		    (lambda (ignore)
-		      (lp running '() new-output waiting-for-input #t)))
+		      (lp running '() stopped new-output waiting-for-input #t)))
       
 	      (wrap (receive-rv get-job-list-channel)
 		    (lambda (state.channel)
@@ -144,19 +206,41 @@
 			    (case (car state.channel)
 			      ((running) running)
 			      ((ready) ready)
+			      ((stopped) stopped)
 			      ((new-output) new-output)
 			      ((waiting-for-input) waiting-for-input)
 			      (else
 			       (error "joblist-surveillant" state.channel))))
-		      (lp running ready new-output waiting-for-input #f))))
+		      (lp running ready stopped new-output waiting-for-input #f))))
 
 	     (map (lambda (job)
 		    (wrap (job-status-rv job)
-			  (lambda (ignore)
+			  (lambda (status)
-			    (lp (delete job running)
+			    (cond
-				(cons job ready)
+			     ((status:exit-val status)
-				new-output
+			      => (lambda (ignore)
-				waiting-for-input #t))))
+				   (lp (delete job running)
+				       (cons job ready) stopped
+				       new-output waiting-for-input #t)))
+			     ((status:stop-sig status)
+			      => (lambda (signal)
+				   (cond 
+				     ((= signal signal/ttin)
+				      (lp (delete job running)
+					  ready stopped new-output
+					  (cons job waiting-for-input) #t))
+				     ((= signal signal/ttou)
+				      (lp (delete job running)
+					  ready stopped
+					  (cons job new-output)
+					  waiting-for-input #t))
+				     (else
+				      (error "Unhandled signal" signal)))))
+			     ((status:term-sig status)
+			      => (lambda (signal)
+				   (lp (delete job running)
+				       ready (cons job stopped)
+				       new-output waiting-for-input #t)))))))
 		  running))))))))
     statistics-channel))
 
@@ -173,7 +257,12 @@
    (lambda args
      (display args))))     
 
-(define-syntax run/bg
+(define (save-tty-excursion port thunk)
+  (let ((settings (tty-info port)))
+    (thunk)
+    (set-tty-info/now port settings)))
+
+(define-syntax run-with-console
   (syntax-rules ()
     ((_ epf)
      (call-with-values
@@ -182,10 +271,64 @@
 	    (lambda ()
 	      (exec-epf epf))))
        (lambda (proc pty-in pty-out tty-name)
-	 (make-job (quote epf) pty-in pty-out 
+	 (make-job-with-console
-		   (make-terminal-buffer 
+	  (quote epf) proc
-		    (- (result-buffer-num-cols (result-buffer)) 1)
+	  pty-in pty-out 
-		    (- (result-buffer-num-lines (result-buffer)) 1))
+	  (make-terminal-buffer 
-		   proc))))))
+	   (- (result-buffer-num-cols (result-buffer)) 1)
+	   (- (result-buffer-num-lines (result-buffer)) 1))))))))
+
+(define-syntax go
+  (syntax-rules ()
+    ((_ epf)
+     (save-tty-excursion
+      (current-input-port)
+      (lambda ()
+	(def-prog-mode)
+	(clear)
+	(endwin)
+	(restore-initial-tty-info! (current-input-port))
+	(drain-tty (current-output-port))
+	(obtain-lock paint-lock)
+	(let ((foreground-pgrp (tty-process-group (current-output-port)))
+	      (proc 
+	       (fork 
+		(lambda () 
+		  (set-process-group (pid) (pid))
+		  (set-tty-process-group (current-output-port) (pid))
+		  (exec-epf epf)))))
+	  (job-status (make-job-sans-console (quote epf) proc))
+	  (set-tty-process-group (current-output-port) foreground-pgrp)
+	  (display "Press any key to return to Commander S...")
+	  (wait-for-key)
+	  (release-lock paint-lock)))))))
+
+(define-syntax go/bg
+  (syntax-rules ()
+    ((_ epf)
+     (let* ((orig (tty-info (current-output-port)))
+	    (child (copy-tty-info orig)))
+       (obtain-lock paint-lock)
+       (endwin)
+       (drain-tty (current-output-port))
+;       (set-tty-process-group (current-output-port) (pid))
+       (set-tty-info:local-flags 
+	child
+	(bitwise-and (tty-info:local-flags child)
+		     ttyl/ttou-signal))
+       (set-tty-info/now (current-output-port) child)
+       (let ((proc
+ 	      (fork
+ 	       (lambda ()
+		 (set-process-group (pid) (pid))
+ 		 (exec-epf epf)))))
+ 	 (let ((job (make-job-sans-console (quote epf) proc)))
+	   (set-tty-info/now (current-output-port) orig)
+	   (release-lock paint-lock)
+ 	   job))))))
+
+
+;	   (set-tty-info/now (current-input-port) info)))))))
 
 ;;; EOF
+

scheme/layout.scm

@@ -198,3 +198,36 @@
   (if (> (string-length string) length)
       (substring string 0 length)
       string))
+
+;; ,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 (show-shell-screen)
+  (def-prog-mode)
+  (endwin)
+  (display "Press any key to return to Commander S")
+  (wait-for-key))
+
+(define (with-output-to-result-screen thunk)
+  (def-prog-mode)
+  (endwin)
+  (newline)
+  (thunk)
+  (display "Press any key to return to Commander S...")
+  (wait-for-key))
+
+(define paint-lock (make-lock))

scheme/nuit-engine.scm

@@ -29,8 +29,6 @@
 (define (enter-command-mode!)
   (set! *command-buffer-mode* 'command))
 
-(define paint-lock (make-lock))
-
 (define executable-completions-lock (make-lock))
 (define executable-completions #f)
 
@@ -245,14 +243,49 @@
   (move-cursor (command-buffer) (result-buffer))
   (refresh-command-window))
 
+;; #### implement me
+(define terminal-input-handler
+  (lambda ignore
+    'terminal-input))
+
+;; #### implement me
+(define terminal-output-handler
+  (lambda ignore
+    'terminal-output))
+
+(define (install-signal-handlers)
+  (for-each 
+   (lambda (signal)
+     (set-interrupt-handler signal #f))
+   (list interrupt/int interrupt/quit interrupt/tstp))
+  (set-interrupt-handler signal/ttin terminal-input-handler)
+  (set-interrupt-handler signal/ttou terminal-output-handler))
+
+(define (enable-tty-output-control! port)
+  (let ((info (copy-tty-info (tty-info port))))
+    (set-tty-info:local-flags
+     info
+     (bitwise-and (tty-info:local-flags info)
+		  ttyl/ttou-signal))
+    (set-tty-info/now port info)))
+
+(define (process-group-leader?)
+  (= (process-group) (pid)))
+
 ;; handle input
 (define (run)
-
+  (save-initial-tty-info! (current-input-port))
   (init-screen)
   (init-windows!)
   (clear)
 
+  (if (not (process-group-leader?))
+      (become-session-leader))
+
+  (set-tty-process-group (current-input-port) (pid))
+
   (init-executables-completion-set!)
+  (enable-tty-output-control! (current-output-port))
 
   ;; init joblist
   (let ((statistics-channel (spawn-joblist-surveillant)))
@@ -270,13 +303,6 @@
 	 (release-lock paint-lock)
 	 (lp (cml-receive statistics-channel))))))
 
-  (set-process-group (pid) (pid))
-  (set-tty-process-group (current-input-port) (pid))
-
-  '(set-interrupt-handler interrupt/keyboard 
-			  (lambda a 
-			    (set! active-keyboard-interrupt a)))
-      
   ;;Loop
   (paint)
   (let loop ((ch (wait-for-input)) (c-x-pressed? #f)
@@ -468,6 +494,7 @@
 		    (case (car status.count)
 		      ((running) (stat-item "run:" (cdr status.count)))
 		      ((ready) (stat-item "ready:" (cdr status.count)))
+		      ((stopped) (stat-item "stop:" (cdr status.count)))
 		      ((new-output) (stat-item "out:" (cdr status.count)))
 		      ((waiting-for-input) (stat-item "in:" (cdr status.count)))))
 		  statistics)))
@@ -563,11 +590,12 @@
 (define eval-expression
   (let ((env (init-evaluation-environment 'nuit-eval)))
     (lambda (exp)
-      (with-fatal-and-capturing-error-handler
+      (eval (read-sexp-from-string exp) env))))
-       (lambda (condition raw-continuation continuation decline)
+;       (with-fatal-and-capturing-error-handler
-	 raw-continuation)
+;        (lambda (condition raw-continuation continuation decline)
-       (lambda ()
+; 	 raw-continuation)
-	 (eval (read-sexp-from-string exp) env))))))
+;        (lambda ()
+; 	 (eval (read-sexp-from-string exp) env))))))
 
 (define (determine-plugin-by-type result)
   (find (lambda (r)

scheme/nuit-packages.scm

@@ -60,12 +60,20 @@
 	  set-result-buffer-highlighted!
 	  result-buffer-marked
 	  set-result-buffer-marked!
-	  make-simple-result-buffer-printer))
+	  make-simple-result-buffer-printer
+
+	  show-shell-screen
+	  with-output-to-result-screen
+	  wait-for-key
+
+	  paint-lock))
 
 (define-structure layout layout-interface
-  (open scheme
+  (open scheme-with-scsh
 	srfi-6			;; basic string ports
 	define-record-types
+	let-opt
+	locks
 
 	tty-debug
 	ncurses)
@@ -104,8 +112,11 @@
 (define-structures 
   ((app-windows app-windows-interface)
    (nuit-windows nuit-windows-interface)
-   (result-buffer-changes result-buffer-changes-interface))
+   (result-buffer-changes result-buffer-changes-interface)
-  (open scheme
+   (initial-tty (export save-initial-tty-info!
+			restore-initial-tty-info!)))
+  (open (modify scheme-with-scsh
+		(hide select receive))
 	define-record-types
 	threads
 	
@@ -218,6 +229,7 @@
 	srfi-13
         
 	joblist
+	layout
         fs-object
 	pps
 	nuit-eval
@@ -347,7 +359,8 @@
 (define-structures
   ((nuit-eval (compound-interface 
 	       (interface-of scheme-with-scsh)
-	       (export focus-value)))
+	       (export focus-value)
+	       run-jobs-interface))
    (nuit-eval/focus-table (export focus-table)))
   (open 
    (modify scheme-with-scsh
@@ -357,6 +370,7 @@
 
    terminal-buffer
    jobs
+   run-jobs
    focus-table
    fs-object
    pps)
@@ -463,15 +477,20 @@
 ;;; jobs and joblist
 
 (define-interface job-interface
-  (export make-job
+  (export make-job-with-console
+	  make-job-sans-console
 	  job-status
 	  job-status-rv
 
 	  job?
+	  job-with-console?
+	  job-sans-console?
+
 	  job-running?
 	  job-ready?
 	  job-waiting-for-input?
 	  job-has-new-output?
+	  job-stopped?
 	  job-start-time
 	  job-end-time
 	  job-proc
@@ -485,10 +504,17 @@
 	  jobs-with-new-output
 	  jobs-waiting-for-input
 
+	  continue-job-in-foreground
+
 	  signal-job
 	  stop-job
-	  continue-job
+	  continue-job))
-	  (run/bg :syntax)))
+
+(define-interface run-jobs-interface
+  (export
+   (run-with-console :syntax)
+   (go :syntax)
+   (go/bg :syntax)))
 
 (define-interface joblist-interface
   (export running-jobs
@@ -499,6 +525,7 @@
 	  initial-job-statistics))
 
 (define-structures ((jobs	job-interface)
+		    (run-jobs   run-jobs-interface)
 		    (joblist	joblist-interface))
   (open (modify scheme-with-scsh 
 		(hide receive select))
@@ -506,16 +533,19 @@
 	threads
 	srfi-1
 	signals
+	locks
 
 	rendezvous
 	rendezvous-channels
 	rendezvous-placeholders
 
+	initial-tty
+	ncurses
 	terminal-buffer
 	nuit-windows
 	app-windows
 	layout
-
+	tty-debug
 	console)
   (files job))
 
@@ -551,6 +581,7 @@
 	let-opt
 
 	app-windows
+	initial-tty
 	nuit-windows 
 
 	focus-table

scheme/std-command.scm

@@ -1,29 +1,6 @@
-;; ,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 
@@ -161,3 +138,16 @@
 			     => (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)))))
+

scheme/win.scm

@@ -32,7 +32,7 @@
 (define (result-frame-window) *result-frame-window*)
 
 (define *command-buffer*
-  (make-buffer '("Welcome to the scsh-ncurses-ui!" "")
+  (make-buffer '("Welcome to the Commander S!" "")
 	       2 2 2 1 1
 	       0 0
 	       #t 1))
@@ -60,6 +60,14 @@
 (define (focus-result-buffer!)
   (set! *focus-buffer* 'result-buffer))
 
+(define *untouched-tty* #f)
+
+(define (save-initial-tty-info! port)
+  (set! *untouched-tty* (copy-tty-info (tty-info port))))
+
+(define (restore-initial-tty-info! port)
+  (set-tty-info/now port *untouched-tty*))
+
 (define (make-inlying-app-window outer-window)
   (make-app-window (+ (app-window-x outer-window) 1)
 		   (+ (app-window-y outer-window) 1)
@@ -129,14 +137,13 @@
        (select
 	(wrap (receive-rv result-buffer-changes-subscribers)
 	      (lambda (answer-channel)
-		(debug-message "result-buffer-surveillant "
+		(debug-message "result-buffer-surveillant 1")
-			       answer-channel)
 		(receive result-buffer-changed-channel)
 		(send answer-channel 'ignore)
 		(lp)))
 	(wrap (receive-rv result-buffer-changed-channel)
 	      (lambda (ignore)
-		(debug-message "result-buffer-surveillant")
+		(debug-message "result-buffer-surveillant 2")
 		(lp))))))))
       
 (define (result-buffer-other-object-has-focus-rv)