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

349
collects/mzlib/process.rkt
View File

@ -1,210 +1,171 @@
#lang mzscheme
(provide process
process*
process/ports
process*/ports
system
system*
system/exit-code
system*/exit-code)
(module process mzscheme (require mzlib/port)
(provide process
process*
process/ports
process*/ports
system
system*
system/exit-code
system*/exit-code)
(require mzlib/port) ;; Helpers: ----------------------------------------
;; Helpers: ---------------------------------------- (define (shell-path/args who argstr)
(case (system-type)
[(unix macosx) (append '("/bin/sh" "-c") (list argstr))]
[(windows) (let ([cmd
(let ([d (find-system-path 'sys-dir)])
(let ([cmd (build-path d "cmd.exe")])
(if (file-exists? cmd)
cmd
(let ([cmd (build-path d "command.com")])
(if (file-exists? cmd)
cmd
;; One last try: up a dir
(build-path d 'up "command.com"))))))])
(list cmd
'exact
(format "~a /c \"~a\"" (path->string cmd) argstr)))]
[else (raise-mismatch-error
who
(format "~a: don't know what shell to use for platform: " who)
(system-type))]))
(define (shell-path/args who argstr) (define (if-stream-out p)
(case (system-type) (cond [(or (not p) (file-stream-port? p)) p]
((unix macosx) (append '("/bin/sh" "-c") (list argstr))) [(output-port? p) #f]
((windows) (let ([cmd [else (raise-type-error 'subprocess "output port" p)]))
(let ([d (find-system-path 'sys-dir)])
(let ([cmd (build-path d "cmd.exe")])
(if (file-exists? cmd)
cmd
(let ([cmd (build-path d "command.com")])
(if (file-exists? cmd)
cmd
;; One last try: up a dir
(build-path d 'up "command.com"))))))])
(list cmd
'exact
(format "~a /c \"~a\"" (path->string cmd) argstr))))
(else (raise-mismatch-error
who
(format "~a: don't know what shell to use for platform: " who)
(system-type)))))
(define (if-stream-out 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 (output-port? p) [else (raise-type-error 'subprocess "input port" p)]))
#f
(raise-type-error
'subprocess
"output port"
p))))
(define (if-stream-in p) (define (streamify-in cin in ready-for-break)
(if (or (not p) (file-stream-port? p)) (if (and cin (not (file-stream-port? cin)))
p (thread (lambda ()
(if (input-port? p) (dynamic-wind
#f void
(raise-type-error (lambda ()
'subprocess (with-handlers ([exn:break? void])
"input port" (ready-for-break #t)
p)))) (copy-port cin in)
(ready-for-break #f)))
(lambda () (close-output-port in)))
(ready-for-break #t)))
in))
(define (streamify-in cin in get-thread? ready-for-break) (define (streamify-out cout out)
(if (and cin (not (file-stream-port? cin))) (if (and cout (not (file-stream-port? cout)))
(let ([t (thread (lambda () (thread (lambda ()
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda () (copy-port out cout))
(with-handlers ([exn:break? void]) (lambda () (close-input-port out)))))
(ready-for-break #t) out))
(copy-port cin in)
(ready-for-break #f)))
(lambda () (close-output-port in)))
(ready-for-break #t)))])
(and get-thread? t))
in))
(define (streamify-out cout out get-thread?) ;; Old-style functions: ----------------------------------------
(if (and cout (not (file-stream-port? cout)))
(let ([t (thread (lambda ()
(dynamic-wind
void
(lambda () (copy-port out cout))
(lambda () (close-input-port out)))))])
(and get-thread? t))
out))
;; Old-style functions: ---------------------------------------- (define (process*/ports cout cin cerr exe . args)
(let-values ([(subp out in err) (apply subprocess
(if-stream-out cout)
(if-stream-in cin)
(if-stream-out cerr)
exe args)]
[(it-ready) (make-semaphore)])
(let ([so (streamify-out cout out)]
[si (streamify-in cin in (lambda (ok?)
(if ok?
(semaphore-post it-ready)
(semaphore-wait it-ready))))]
[se (streamify-out cerr err)]
[aport (lambda (x) (and (port? x) x))])
(when (thread? si)
;; Wait for process to end, then stop copying input:
(thread (lambda ()
(sync subp si)
(semaphore-wait it-ready)
(break-thread si))))
(let ([threads-still-going?
(lambda ()
(ormap (lambda (s) (and (thread? s) (thread-running? s)))
(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)
(aport si)
(subprocess-pid subp)
(aport se)
control)))))
(define (process*/ports cout cin cerr exe . args) (define (process/ports out in err str)
(let-values ([(subp out in err) (apply subprocess (apply process*/ports out in err (shell-path/args 'process/ports str)))
(if-stream-out cout)
(if-stream-in cin)
(if-stream-out cerr)
exe args)]
[(it-ready) (make-semaphore)])
(let ([so (streamify-out cout out #t)]
[si (streamify-in cin in #t (lambda (ok?)
(if ok?
(semaphore-post it-ready)
(semaphore-wait it-ready))))]
[se (streamify-out cerr err #t)]
[aport (lambda (x)
(and (port? x) x))])
(when (thread? si)
;; Wait for process to end, then stop copying input:
(thread (lambda ()
(sync subp si)
(semaphore-wait it-ready)
(break-thread si))))
(let ([threads-still-going?
(lambda ()
(ormap (lambda (s)
(and (thread? s)
(thread-running? s)))
(list so si se)))])
(list (aport so)
(aport si)
(subprocess-pid subp)
(aport se)
(letrec ((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* exe . args)
(apply process*/ports out in err (shell-path/args "process/ports" str))) (apply process*/ports #f #f #f exe args))
(define (process* exe . args) (define (process str)
(apply process*/ports #f #f #f exe args)) (apply process* (shell-path/args 'process str)))
(define (process str) ;; Note: these always use current ports
(apply process* (shell-path/args "process" str))) (define (system*/exit-code exe . args)
(let ([cout (current-output-port)]
[cin (current-input-port)]
[cerr (current-error-port)]
[it-ready (make-semaphore)])
(let-values ([(subp out in err)
(apply subprocess
(if-stream-out cout)
(if-stream-in cin)
(if-stream-out cerr)
exe args)])
(let ([ot (streamify-out cout out)]
[it (streamify-in cin in (lambda (ok?)
(if ok?
(semaphore-post it-ready)
(semaphore-wait it-ready))))]
[et (streamify-out cerr err)])
(subprocess-wait subp)
(when it
;; stop piping output to subprocess
(semaphore-wait it-ready)
(break-thread it))
;; wait for other pipes to run dry:
(when (thread? ot) (thread-wait ot))
(when (thread? et) (thread-wait et))
(when err (close-input-port err))
(when out (close-input-port out))
(when in (close-output-port in)))
(subprocess-status subp))))
;; Note: these always use current ports (define (system* exe . args)
(define (system*/exit-code exe . args) (zero? (apply 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)]
[cin (current-input-port)]
[cerr (current-error-port)]
[it-ready (make-semaphore)])
(let-values ([(subp out in err)
(apply
subprocess
(if-stream-out cout)
(if-stream-in cin)
(if-stream-out cerr)
exe args)])
(let ([ot (streamify-out cout out #t)]
[it (streamify-in cin in #t (lambda (ok?)
(if ok?
(semaphore-post it-ready)
(semaphore-wait it-ready))))]
[et (streamify-out cerr err #t)])
(subprocess-wait subp)
(when it
;; stop piping output to subprocess
(semaphore-wait it-ready)
(break-thread it))
;; wait for other pipes to run dry:
(when (thread? ot)
(thread-wait ot))
(when (thread? et)
(thread-wait et))
(when err
(close-input-port err))
(when out
(close-input-port out))
(when in
(close-output-port in)))
(subprocess-status subp)))))
(define (system* exe . args) (define (system str)
(if (eq? (system-type) 'macos) (apply system* (shell-path/args 'system str)))
(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/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* (shell-path/args "system" str))))
(define (system/exit-code str)
(if (eq? (system-type) 'macos)
(subprocess #f #f #f "by-id" str)
(apply system*/exit-code (shell-path/args "system" str)))))