scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Support POSIX job control, sort of.

This commit is contained in:
eknauel 2005-06-14 11:20:30 +00:00
parent 96e9c07f0e
commit 34761f66d2
7 changed files with 331 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
scheme/job-viewer.scm
View File

@ -12,9 +12,9 @@
(cond
((job-running? job) "running")
((job-ready? job) "ready")
((job-waiting-for-input? job) "stop/input")
((and (job-end-time job)
(job-has-new-output? job) "ready/output"))
((job-waiting-for-input? job) "waiting for input")
((job-has-new-output? job) "waiting with 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
(list (job-name->string (job-name job))
"name:" (job-name->string (job-name job)))
(list (if (job-end-time job)
(number->string (job-status job)) #f)
"status:"
(if (job-end-time job)
(number->string (job-status job))
"-"))
(list (job-start-time job)
"start:"
(short-date (job-start-time job)))
(list (job-end-time job)
"end:"
(if (job-end-time job)
(short-date (job-end-time job))
"-"))
(list #f "run status:"
(symbol->string (job-run-status job)))
(list (job-console job)
"<View Console>" "")))
`((,(job-name->string (job-name job))
"name:" ,(job-name->string (job-name job)))
(,(if (job-end-time job)
(number->string (job-status job)) #f)
"status:"
,(if (job-end-time job)
(number->string (job-status job))
"-"))
(,(job-start-time job)
"start:"
,(short-date (job-start-time job)))
(,(job-end-time job)
"end:"
,(if (job-end-time job)
(short-date (job-end-time job))
"-"))
(#f "run status:"
,(format-job-run-state job))
,@(if (job-with-console? job)
`((,(job-console job) "<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))

187
scheme/job.scm
View File

@ -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))))
(set-job-end-time! job (date))
(set-job-run-status! job 'ready)
(let ((status (wait (job-proc job) wait/stopped-children)))
(cond
((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)
ready new-output waiting-for-input #t)))
(lp (cons new-job running)
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)
(lp (delete job running)
(cons job ready)
new-output
waiting-for-input #t))))
(lambda (status)
(cond
((status:exit-val status)
=> (lambda (ignore)
(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-terminal-buffer
(- (result-buffer-num-cols (result-buffer)) 1)
(- (result-buffer-num-lines (result-buffer)) 1))
proc))))))
(make-job-with-console
(quote epf) proc
pty-in pty-out
(make-terminal-buffer
(- (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

33
scheme/layout.scm
View File

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

58
scheme/nuit-engine.scm
View File

@ -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
(lambda (condition raw-continuation continuation decline)
raw-continuation)
(lambda ()
(eval (read-sexp-from-string exp) env))))))
(eval (read-sexp-from-string exp) env))))
; (with-fatal-and-capturing-error-handler
; (lambda (condition raw-continuation continuation decline)
; raw-continuation)
; (lambda ()
; (eval (read-sexp-from-string exp) env))))))
(define (determine-plugin-by-type result)
(find (lambda (r)

49
scheme/nuit-packages.scm
View File

@ -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))
(open scheme
(result-buffer-changes result-buffer-changes-interface)
(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
(run/bg :syntax)))
continue-job))
(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

36
scheme/std-command.scm
View File

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

15
scheme/win.scm
View File

@ -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 "
answer-channel)
(debug-message "result-buffer-surveillant 1")
(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)