andrius
/
gash
mirror of https://git.savannah.gnu.org/git/gash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

checkpoint

This commit is contained in:
Rutger van Beusekom 2016-10-20 09:08:06 +02:00
parent fc8b856110
commit 628f111ced
2 changed files with 29 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
sh/anguish.scm
View File

@ -149,6 +149,7 @@ copyleft.
(match ast (match ast
(('append ('glob "cd") arg) `(apply chdir ,arg)) (('append ('glob "cd") arg) `(apply chdir ,arg))
(('append ('glob "echo") args ...) `(apply stdout ,@args)) (('append ('glob "echo") args ...) `(apply stdout ,@args))
(('glob "jobs") `(jobs))
(('for-each rest ...) ast) (('for-each rest ...) ast)
(('if rest ...) ast) (('if rest ...) ast)
(_ #f))) (_ #f)))

34
sh/pipe.scm
View File

@ -8,7 +8,7 @@
:use-module (srfi srfi-9) :use-module (srfi srfi-9)
:use-module (srfi srfi-26) :use-module (srfi srfi-26)
:export (pipeline job-control-init)) :export (pipeline job-control-init jobs))
(define (stdout . o) (define (stdout . o)
(map display o) (map display o)
@ -35,10 +35,17 @@
(define job-table '()) ;; list of <job> (define job-table '()) ;; list of <job>
(define (status->state status) (define (status->state status)
(cond ((status:exit-val status) 'completed) (cond ((status:exit-val status) 'Completed)
((status:term-sig status) 'terminated) ((status:term-sig status) 'Terminated)
((status:stop-sig status) 'stopped) ((status:stop-sig status) 'Stopped)
(#t 'running))) (#t 'Running)))
(define (jobs)
(map (lambda (job number)
(stdout "[" number "]? " (status->state (job-status job)) "\t\t"
(process-command (car (job-processes job)))))
(reverse job-table)
(iota (length job-table) 1 1)))
(define (job-status job) (define (job-status job)
(process-status (car (job-processes job)))) (process-status (car (job-processes job))))
@ -51,6 +58,9 @@
(define (job-running? job) (define (job-running? job)
(find (compose not process-status) (job-processes job))) (find (compose not process-status) (job-processes job)))
(define (job-stopped? job)
(find (compose status:stop-sig process-status) (job-processes job)))
(define (add-to-process-group job pid) (define (add-to-process-group job pid)
(let* ((pgid (job-pgid job)) (let* ((pgid (job-pgid job))
(pgid (or pgid pid))) (pgid (or pgid pid)))
@ -128,6 +138,10 @@
(job-add-process job pid command) (job-add-process job pid command)
(and src (close src)))))) (and src (close src))))))
;; TODO:
;; report job status: before prompt or by calling jobs
;; remove reported terminated or completed jobs
(define (pipeline . commands) (define (pipeline . commands)
(let ((interactive? (isatty? (current-error-port))) (let ((interactive? (isatty? (current-error-port)))
(job (make-job (length job-table) #f '()))) (job (make-job (length job-table) #f '())))
@ -148,7 +162,15 @@
(if (job-running? job) (loop)))) (if (job-running? job) (loop))))
(tcsetpgrp (current-error-port) (getpid)) (tcsetpgrp (current-error-port) (getpid))
;;(pretty-print job-table) ;;(pretty-print job-table)
(job-status job))) (job-status job)
(reap-jobs)))
(define (disjoin . predicates)
(lambda (. arguments)
(any (cut apply <> arguments) predicates)))
(define (reap-jobs)
(set! job-table (filter (disjoin job-running? job-stopped?) job-table)))
;;(pipeline (list "ls" "/") ;;(pipeline (list "ls" "/")
;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e")) ;;(pipeline (list "ls" "/") (list "grep" "o") (list "tr" "o" "e"))