From 975d3f7ee0f034afed9264493473f6968db74838 Mon Sep 17 00:00:00 2001 From: Rutger van Beusekom Date: Tue, 18 Oct 2016 09:15:53 +0200 Subject: [PATCH] checkpoint: HAX0R kuch!!! 8-( --- sh/anguish.scm | 12 +-- sh/pipe.scm | 259 ++++++++++++++++++++++++++++--------------------- 2 files changed, 156 insertions(+), 115 deletions(-) diff --git a/sh/anguish.scm b/sh/anguish.scm index 80f64f8..8a23e52 100644 --- a/sh/anguish.scm +++ b/sh/anguish.scm @@ -35,6 +35,7 @@ ((compose string-to-ast file-to-string) filename)) (define (main args) + (job-control-init) (let* ((option-spec '((debug (single-char #\d) (value #f)) (help (single-char #\h) (value #f)) (parse (single-char #\p) (value #f)) @@ -49,11 +50,10 @@ (cond (parse? (let ((ast- (transform ast))) (format (current-output-port) "parsed : ~s\n\n" ast) - (format (current-output-port) "prepared: ~s\n\n" ast-) + (map (cut format (current-output-port) "prepared: ~s\n\n" <>) ast-) #t)) (#t - (sh-exec ast) - #t)))))) + (sh-exec ast))))))) (cond (help? (display "\ @@ -181,7 +181,7 @@ copyleft. ((('pipe _) command ...) (map transform command)) (((('pipe _) command) ...) (map transform command)) ((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...) - (_ ast))) + (_ ast))) ;; done (define (sh-exec ast) (define (exec cmd) @@ -193,8 +193,8 @@ copyleft. ;(print (format (current-error-port) "transformed: ~a\n" ast)) ) (match ast - ('script '()) ;; skip - (_ (map exec ast))))) + ('script #t) ;; skip + (_ (begin (map exec ast) #t))))) (define (prompt) diff --git a/sh/pipe.scm b/sh/pipe.scm index 0be4a6b..19eebf1 100644 --- a/sh/pipe.scm +++ b/sh/pipe.scm @@ -4,7 +4,61 @@ :use-module (srfi srfi-8) :use-module (srfi srfi-9) :use-module (srfi srfi-26) - :export (pipeline)) + :export (pipeline job-control-init)) + +(define (stdout . o) + (map display o) + (newline)) + +(define (stderr . o) + (map (cut display <> (current-error-port)) o) + (newline)) + +(define-record-type + (make-process pid command status) + process? + (pid process-pid) + (command process-command) + (status process-status set-process-status!)) ;; '(running stopped completed terminated) + +(define-record-type + (make-job id pgid processes) + job? + (id job-id) + (pgid job-pgid set-job-pgid!) + (processes job-processes set-job-processes!)) + +(define job-table '()) ;; list of + +;; (define (job-at index) +;; (let ((len (length job-table))) +;; (if (or (> index len) (< index 0)) #f +;; (list-ref job-table (- len index))))) + +(define (add-to-process-group job pid) + (let* ((pgid (job-pgid job)) + (pgid (if (= 0 pgid) pid pgid))) + (setpgid pid pgid) + pgid)) + +(define (job-add-process job pid command) + (let ((pgid (add-to-process-group job pid))) + (set-job-pgid! job pgid) + (tcsetpgrp (current-input-port) pgid) + (cons (make-process pid command 'running) (job-processes job)))) + +(define (job-control-init) + (let* ((interactive? (isatty? (current-input-port))) + (pgid (getpgrp)) + (pid (getpid))) + (when interactive? + (while (not (eqv? (tcgetpgrp (current-input-port)) pgid)) + (kill (- pgid) SIGTTIN)) ;; we are not in the foreground + (map (cut sigaction <> SIG_IGN) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU)) + (sigaction SIGCHLD SIG_DFL) + (setpgid pid pid) ;; create new process group for ourself + (tcsetpgrp (current-input-port) pid)))) (define (pipe*) (let ((p (pipe))) @@ -16,152 +70,139 @@ (define (exec* command) ;; list of strings (apply execlp (cons (car command) command))) -(define (spawn-source command) +(define (spawn-source job interactive? command) (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) (close r) + (tcsetpgrp (current-input-port) (add-to-process-group job (getpid))) (move->fdes w 1) (exec* command)) (#t + (job-add-process job pid command) (close w) r))))) -(define (spawn-filter src command) +(define (spawn-filter job interactive? src command) (receive (r w) (pipe*) (let ((pid (primitive-fork))) (cond ((= 0 pid) + (tcsetpgrp (current-input-port) (add-to-process-group job (getpid))) (move->fdes src 0) (close r) (move->fdes w 1) (exec* command)) (#t + (job-add-process job pid command) (close w) r))))) -(define (spawn-sink src command) +(define (spawn-sink job interactive? src command) (let ((pid (primitive-fork))) (cond ((= 0 pid) - (move->fdes src 0) + (tcsetpgrp (current-input-port) (add-to-process-group job (getpid))) + (map (cut sigaction <> SIG_DFL) + (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) + + (and src (move->fdes src 0)) (exec* command)) (#t - (close src) - (waitpid pid))))) + (job-add-process job pid command) + (and src (close src)))))) (define (pipeline . commands) - (if (< 1 (length commands)) - (let loop ((src (spawn-source (car commands))) - (commands (cdr commands))) - (if (null? (cdr commands)) (spawn-sink src (car commands)) - (loop (spawn-filter src (car commands)) - (cdr commands)))) - (apply system* (car commands)))) + (let ((interactive? (isatty? (current-input-port))) + (job (make-job (length job-table) 0 '()))) + (set! job-table (cons job job-table)) + (if (< 1 (length commands)) + (let loop ((src (spawn-source job interactive? (car commands))) + (commands (cdr commands))) + (if (null? (cdr commands)) + (spawn-sink job interactive? src (car commands)) + (loop (spawn-filter job interactive? src (car commands)) + (cdr commands)))) + (spawn-sink job interactive? #f (car commands)))) + (waitpid WAIT_ANY WUNTRACED) + (sleep 2) + ;;(tcsetpgrp (current-input-port) (getpgrp)) + (stdout "job-table: " job-table)) ;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define (stdout . o) - (map display o) - (newline)) +;; (define (job-launch command fg?) ;; todo: integrate into pipeline +;; (let* ((interactive? (isatty? (current-input-port))) +;; (pgid (getpid)) +;; (pid (primitive-fork))) +;; (if (= 0 pid) +;; (when interactive? ;; the child i.e. command +;; (setpgid pid pgid) +;; (if fg? (tcsetpgrp (current-input-port) pgid)) +;; (map (cut sigaction <> SIG_DFL) +;; (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) +;; (map move->fdes +;; (list (current-input-port) (current-output-port) (current-error-port)) +;; (iota 4)) +;; (exec* command) +;; (exit 1)) +;; (when interactive? ;; the parent i.e. shell +;; (setpgid pid pgid) +;; (set! job-table +;; (acons pid +;; (make-job (length job-table) `(,pid) pgid command 'running) +;; job-table)) +;; (when fg? +;; (waitpid pid WUNTRACED) +;; (tcsetpgrp (current-input-port) (getpid))))))) -(define (stderr . o) - (map (cut display <> (current-error-port)) o) - (newline)) +;; (define (mark-job-status pid status) +;; (if (not (= 0 pid)) +;; (cond ((status:stop-sig status) +;; (set-job-stopped! pid job-table)) +;; ((status:term-sig status) +;; (set-job-terminated! pid job-table)) +;; ((status:exit-val status) +;; (set-job-completed! pid job-table))))) -(define-record-type - (make-job id pid pgid command status ) - job? - (id job-id) - (pid job-pid) - (pgid job-pgid) - (command job-command) - (status job-status set-job-status!)) ;; '(running stopped completed terminated) +;; (define (job-wait job) +;; (let loop () +;; (let* ((status (job-status job)) +;; (pid-status (waitpid WAIT_ANY WUNTRACED)) +;; (pid (car pid-status)) +;; (status (cdr pid-status))) +;; (mark-job-status pid status) +;; (if (eq? status (job-status job)) (loop))))) -(define job-table '()) +;; (define (set-job-stopped! job-table pid) +;; (set-job-status! (assoc-ref job-table pid) 'stopped)) -(define (job-control-init) - (let* ((interactive? (isatty? (current-input-port))) - (pid (getpid)) - (pgid pid)) - (when interactive? - (map (cut sigaction <> SIG_IGN) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) - (setpgid pid pgid) - (tcsetpgrp (current-input-port) pid)))) +;; (define (set-job-terminated! job-table pid) ;; signal +;; (set-job-status! (assoc-ref job-table pid) 'terminated)) -(define (job-launch command fg?) ;; todo: integrate into pipeline - (let* ((interactive? (isatty? (current-input-port))) - (pgid (getpid)) - (pid (primitive-fork))) - (if (= 0 pid) - (when interactive? - (setpgid pid pgid) - (if fg? (tcsetpgrp (current-input-port) pgid)) - (map (cut sigaction <> SIG_DFL) - (list SIGINT SIGQUIT SIGTSTP SIGTTIN SIGTTOU SIGCHLD)) - (map move->fdes - (list (current-input-port) (current-output-port) (current-error-port)) - (iota 4)) - (exec* command) - (exit 1)) - (when interactive? - (setpgid pid pgid) - (set! job-table - (acons pid - (make-job (length job-table) pid pgid command 'running) - job-table)) - (when fg? - (waitpid pid WUNTRACED) - (tcsetpgrp (current-input-port) (getpid))))))) +;; (define (set-job-completed! job-table pid) ;; exit value +;; (set-job-status! (assoc-ref job-table pid) 'completed)) -(define (mark-job-status pid status) - (if (not (= 0 pid)) - (cond ((status:stop-sig status) - (set-job-stopped! pid job-table)) - ((status:term-sig status) - (set-job-terminated! pid job-table)) - ((status:exit-val status) - (set-job-completed! pid job-table))))) +;; (define (notify-job-status job-table) ;; call when prompting, from SIGCHLD handler or +;; (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) +;; (pid (car pid-status)) +;; (status (cdr pid-status))) +;; (mark-job-status pid status))) -(define (job-wait job) - (let loop () - (let* ((status (job-status job)) - (pid-status (waitpid WAIT_ANY WUNTRACED)) - (pid (car pid-status)) - (status (cdr pid-status))) - (mark-job-status pid status) - (if (eq? status (job-status job)) (loop))))) +;; (define (job-by-id job-table id) +;; (if (< job-id (length job-table)) +;; (list-ref job-table job-id) +;; #f)) -(define (set-job-stopped! job-table pid) - (set-job-status! (assoc-ref job-table pid) 'stopped)) +;; (define (background job-id) +;; (let ((job (job-by-id job-table job-id))) +;; (if (and job (eq? 'stopped (job-status job))) +;; (kill (- (job-pgid job)) SIGCONT)))) -(define (set-job-terminated! job-table pid) ;; signal - (set-job-status! (assoc-ref job-table pid) 'terminated)) - -(define (set-job-completed! job-table pid) ;; exit value - (set-job-status! (assoc-ref job-table pid) 'completed)) - -(define (notify-job-status job-table) ;; call when prompting, from SIGCHLD handler or - (let* ((pid-status (waitpid WAIT_ANY (logior WUNTRACED WNOHANG))) - (pid (car pid-status)) - (status (cdr pid-status))) - (mark-job-status pid status))) - -(define (job-by-id job-table id) - (if (< job-id (length job-table)) - (list-ref job-table job-id) - #f)) - -(define (background job-id) - (let ((job (job-by-id job-table job-id))) - (if (and job (eq? 'stopped (job-status job))) - (kill (- (job-pgid job)) SIGCONT)))) - -(define (foreground job-id) - (let ((job (job-by-id job-table job-id))) - (tcsetpgrp (current-input-port) (job-pgid job)) - (if (and job (eq? 'stopped (job-status job))) - (kill (- (job-pgid job)) SIGCONT)) - (job-wait job) - (tcsetpgrp (current-input-port) (getpid)))) +;; (define (foreground job-id) +;; (let ((job (job-by-id job-table job-id))) +;; (tcsetpgrp (current-input-port) (job-pgid job)) +;; (if (and job (eq? 'stopped (job-status job))) +;; (kill (- (job-pgid job)) SIGCONT)) +;; (job-wait job) +;; (tcsetpgrp (current-input-port) (getpid))))