suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* Use #lang & reformat

Browse Source 
* Remove no longer relevant references to `macos'
* Fix some type errors (that weren't reachable)
* Make streamify-* always return the thread (`get-thread?' was always #t)

original commit: a69d7c00c138b2efd8e298e1cc4e060917672a8c
This commit is contained in:
Eli Barzilay 2010-09-12 23:25:56 -04:00
parent cd4dbaad6a
commit cffcd4f2d7
1 changed files with 155 additions and 194 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

163
collects/mzlib/process.rkt
View File

@ -1,5 +1,4 @@
#lang mzscheme
(module process mzscheme
(provide process (provide process
process* process*
process/ports process/ports
@ -15,8 +14,8 @@
(define (shell-path/args who argstr) (define (shell-path/args who argstr)
(case (system-type) (case (system-type)
((unix macosx) (append '("/bin/sh" "-c") (list argstr))) [(unix macosx) (append '("/bin/sh" "-c") (list argstr))]
((windows) (let ([cmd [(windows) (let ([cmd
(let ([d (find-system-path 'sys-dir)]) (let ([d (find-system-path 'sys-dir)])
(let ([cmd (build-path d "cmd.exe")]) (let ([cmd (build-path d "cmd.exe")])
(if (file-exists? cmd) (if (file-exists? cmd)
@ -28,35 +27,25 @@
(build-path d 'up "command.com"))))))]) (build-path d 'up "command.com"))))))])
(list cmd (list cmd
'exact 'exact
(format "~a /c \"~a\"" (path->string cmd) argstr)))) (format "~a /c \"~a\"" (path->string cmd) argstr)))]
(else (raise-mismatch-error [else (raise-mismatch-error
who who
(format "~a: don't know what shell to use for platform: " who) (format "~a: don't know what shell to use for platform: " who)
(system-type))))) (system-type))]))
(define (if-stream-out p) (define (if-stream-out p)
(if (or (not p) (file-stream-port? p)) (cond [(or (not p) (file-stream-port? p)) p]
p [(output-port? p) #f]
(if (output-port? p) [else (raise-type-error 'subprocess "output port" p)]))
#f
(raise-type-error
'subprocess
"output port"
p))))
(define (if-stream-in p) (define (if-stream-in p)
(if (or (not p) (file-stream-port? p)) (cond [(or (not p) (file-stream-port? p)) p]
p [(input-port? p) #f]
(if (input-port? p) [else (raise-type-error 'subprocess "input port" p)]))
#f
(raise-type-error
'subprocess
"input port"
p))))
(define (streamify-in cin in get-thread? ready-for-break) (define (streamify-in cin in ready-for-break)
(if (and cin (not (file-stream-port? cin))) (if (and cin (not (file-stream-port? cin)))
(let ([t (thread (lambda () (thread (lambda ()
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
@ -65,18 +54,16 @@
(copy-port cin in) (copy-port cin in)
(ready-for-break #f))) (ready-for-break #f)))
(lambda () (close-output-port in))) (lambda () (close-output-port in)))
(ready-for-break #t)))]) (ready-for-break #t)))
(and get-thread? t))
in)) in))
(define (streamify-out cout out get-thread?) (define (streamify-out cout out)
(if (and cout (not (file-stream-port? cout))) (if (and cout (not (file-stream-port? cout)))
(let ([t (thread (lambda () (thread (lambda ()
(dynamic-wind (dynamic-wind
void void
(lambda () (copy-port out cout)) (lambda () (copy-port out cout))
(lambda () (close-input-port out)))))]) (lambda () (close-input-port out)))))
(and get-thread? t))
out)) out))
;; Old-style functions: ---------------------------------------- ;; Old-style functions: ----------------------------------------
@ -88,14 +75,13 @@
(if-stream-out cerr) (if-stream-out cerr)
exe args)] exe args)]
[(it-ready) (make-semaphore)]) [(it-ready) (make-semaphore)])
(let ([so (streamify-out cout out #t)] (let ([so (streamify-out cout out)]
[si (streamify-in cin in #t (lambda (ok?) [si (streamify-in cin in (lambda (ok?)
(if ok? (if ok?
(semaphore-post it-ready) (semaphore-post it-ready)
(semaphore-wait it-ready))))] (semaphore-wait it-ready))))]
[se (streamify-out cerr err #t)] [se (streamify-out cerr err)]
[aport (lambda (x) [aport (lambda (x) (and (port? x) x))])
(and (port? x) x))])
(when (thread? si) (when (thread? si)
;; Wait for process to end, then stop copying input: ;; Wait for process to end, then stop copying input:
(thread (lambda () (thread (lambda ()
@ -104,107 +90,82 @@
(break-thread si)))) (break-thread si))))
(let ([threads-still-going? (let ([threads-still-going?
(lambda () (lambda ()
(ormap (lambda (s) (ormap (lambda (s) (and (thread? s) (thread-running? s)))
(and (thread? s)
(thread-running? s)))
(list so si se)))]) (list so si se)))])
(define (control m)
(case m
[(status)
(let ([s (subprocess-status subp)])
(cond [(or (not (integer? s)) (threads-still-going?))
'running]
[(zero? s) 'done-ok]
[else 'done-error]))]
[(exit-code)
(if (threads-still-going?)
#f
(let ([s (subprocess-status subp)]) (and (integer? s) s)))]
[(wait)
(subprocess-wait subp)
(let ([twait (lambda (t) (when (thread? t) (thread-wait t)))])
(twait so)
(twait si)
(twait se))]
[(interrupt) (subprocess-kill subp #f)]
[(kill) (subprocess-kill subp #t)]
[else (raise-type-error
'control-process
"'status, 'exit-code, 'wait, 'interrupt, or 'kill" m)]))
(list (aport so) (list (aport so)
(aport si) (aport si)
(subprocess-pid subp) (subprocess-pid subp)
(aport se) (aport se)
(letrec ((control control)))))
(lambda (m)
(case m
((status) (let ((s (subprocess-status subp)))
(cond ((or (not (integer? s))
(threads-still-going?))
'running)
((zero? s) 'done-ok)
(else 'done-error))))
((exit-code) (if (threads-still-going?)
#f
(let ((s (subprocess-status subp)))
(and (integer? s) s))))
((wait)
(subprocess-wait subp)
(let ([twait (lambda (t)
(when (thread? t)
(thread-wait t)))])
(twait so)
(twait si)
(twait se)))
((interrupt) (subprocess-kill subp #f))
((kill) (subprocess-kill subp #t))
(else
(raise-type-error 'control-process
"'status, 'exit-code, 'wait, 'interrupt, or 'kill" m))))))
control))))))
(define (process/ports out in err str) (define (process/ports out in err str)
(apply process*/ports out in err (shell-path/args "process/ports" str))) (apply process*/ports out in err (shell-path/args 'process/ports str)))
(define (process* exe . args) (define (process* exe . args)
(apply process*/ports #f #f #f exe args)) (apply process*/ports #f #f #f exe args))
(define (process str) (define (process str)
(apply process* (shell-path/args "process" str))) (apply process* (shell-path/args 'process str)))
;; Note: these always use current ports ;; Note: these always use current ports
(define (system*/exit-code exe . args) (define (system*/exit-code exe . args)
(if (eq? (system-type) 'macos)
(if (null? args)
(raise-mismatch-error
'system*/exit-code "command-line arguments not supported for MacOS" args)
(subprocess #f #f #f exe))
(let ([cout (current-output-port)] (let ([cout (current-output-port)]
[cin (current-input-port)] [cin (current-input-port)]
[cerr (current-error-port)] [cerr (current-error-port)]
[it-ready (make-semaphore)]) [it-ready (make-semaphore)])
(let-values ([(subp out in err) (let-values ([(subp out in err)
(apply (apply subprocess
subprocess
(if-stream-out cout) (if-stream-out cout)
(if-stream-in cin) (if-stream-in cin)
(if-stream-out cerr) (if-stream-out cerr)
exe args)]) exe args)])
(let ([ot (streamify-out cout out #t)] (let ([ot (streamify-out cout out)]
[it (streamify-in cin in #t (lambda (ok?) [it (streamify-in cin in (lambda (ok?)
(if ok? (if ok?
(semaphore-post it-ready) (semaphore-post it-ready)
(semaphore-wait it-ready))))] (semaphore-wait it-ready))))]
[et (streamify-out cerr err #t)]) [et (streamify-out cerr err)])
(subprocess-wait subp) (subprocess-wait subp)
(when it (when it
;; stop piping output to subprocess ;; stop piping output to subprocess
(semaphore-wait it-ready) (semaphore-wait it-ready)
(break-thread it)) (break-thread it))
;; wait for other pipes to run dry: ;; wait for other pipes to run dry:
(when (thread? ot) (when (thread? ot) (thread-wait ot))
(thread-wait ot)) (when (thread? et) (thread-wait et))
(when (thread? et) (when err (close-input-port err))
(thread-wait et)) (when out (close-input-port out))
(when err (when in (close-output-port in)))
(close-input-port err)) (subprocess-status subp))))
(when out
(close-input-port out))
(when in
(close-output-port in)))
(subprocess-status subp)))))
(define (system* exe . args) (define (system* exe . args)
(if (eq? (system-type) 'macos) (zero? (apply system*/exit-code exe args)))
(if (null? args)
(raise-mismatch-error
'system* "command-line arguments not supported for MacOS" args)
(subprocess #f #f #f exe))
(zero? (apply system*/exit-code exe args))))
(define (system str) (define (system str)
(if (eq? (system-type) 'macos) (apply system* (shell-path/args 'system str)))
(subprocess #f #f #f "by-id" str)
(apply system* (shell-path/args "system" str))))
(define (system/exit-code str) (define (system/exit-code str)
(if (eq? (system-type) 'macos) (apply system*/exit-code (shell-path/args 'system/exit-code str)))
(subprocess #f #f #f "by-id" str)
(apply system*/exit-code (shell-path/args "system" str)))))