diff --git a/scheme/job-viewer.scm b/scheme/job-viewer.scm index 09a1f09..57a0062 100644 --- a/scheme/job-viewer.scm +++ b/scheme/job-viewer.scm @@ -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) - "" ""))) + `((,(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) "" "")) + '()))) (- (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)) diff --git a/scheme/job.scm b/scheme/job.scm index 662a49f..3a86802 100644 --- a/scheme/job.scm +++ b/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)))) - (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 + diff --git a/scheme/layout.scm b/scheme/layout.scm index 01c695b..412d2d1 100644 --- a/scheme/layout.scm +++ b/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)) \ No newline at end of file diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm index 9a6ddbf..7340a0b 100644 --- a/scheme/nuit-engine.scm +++ b/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 - (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) diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index b603291..3164a2d 100644 --- a/scheme/nuit-packages.scm +++ b/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)) - (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 diff --git a/scheme/std-command.scm b/scheme/std-command.scm index 7613408..9b13c79 100644 --- a/scheme/std-command.scm +++ b/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))))) + diff --git a/scheme/win.scm b/scheme/win.scm index 06d91b0..330d48d 100644 --- a/scheme/win.scm +++ b/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 " - 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)