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

generalizations to `subprocess' & company

Browse Source 
- allow byte strings in more places
  - allow stderr spec to be 'stdout to redirect stderr to stdout
 Closes PR 11711

original commit: b4056373be7f869e50e14122c9cd39eaad5148df
This commit is contained in:
Matthew Flatt 2011-02-19 08:30:34 -07:00
commit 99de1ca5e8
6 changed files with 82 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/kw.rkt
View File

@ -128,7 +128,7 @@
[else (ormap (lambda (k) (and (assq k rests) #t)) ; suggested?
(car (cddddr processed-spec)))])))
(define (make-keyword-get-expr key rest default known-vars)
;; expand (for id macros) and check if its a simple expression, because if
;; expand (for id macros) and check if it's a simple expression, because if
;; it is, evaluation cannot have side-effects and we can use keyword-get*
(define default*
(local-expand default 'expression (cons #'#%app known-vars)))

105
collects/mzlib/process.rkt
View File

@ -1,4 +1,4 @@
#lang mzscheme
#lang racket/base
(provide process
process*
process/ports
@ -33,15 +33,20 @@
(format "~a: don't know what shell to use for platform: " who)
(system-type))]))
(define (if-stream-out p)
(cond [(or (not p) (file-stream-port? p)) p]
(define (if-stream-out who p [sym-ok? #f])
(cond [(and sym-ok? (eq? p 'stdout)) p]
[(or (not p) (and (output-port? p) (file-stream-port? p))) p]
[(output-port? p) #f]
[else (raise-type-error 'subprocess "output port" p)]))
[else (raise-type-error who
(if sym-ok?
"output port, #f, or 'stdout"
"output port or #f")
p)]))
(define (if-stream-in p)
(cond [(or (not p) (file-stream-port? p)) p]
(define (if-stream-in who p)
(cond [(or (not p) (and (input-port? p) (file-stream-port? p))) p]
[(input-port? p) #f]
[else (raise-type-error 'subprocess "input port" p)]))
[else (raise-type-error who "input port or #f" p)]))
(define (streamify-in cin in ready-for-break)
(if (and cin (not (file-stream-port? cin)))
@ -58,22 +63,52 @@
in))
(define (streamify-out cout out)
(if (and cout (not (file-stream-port? cout)))
(thread (lambda ()
(dynamic-wind
void
(lambda () (copy-port out cout))
(lambda () (close-input-port out)))))
out))
(if (and cout
(not (eq? cout 'stdout))
(not (file-stream-port? cout)))
(thread (lambda ()
(dynamic-wind
void
(lambda () (copy-port out cout))
(lambda () (close-input-port out)))))
out))
(define (check-exe who exe)
(unless (or (path-string? exe)
(eq? exe 'exact))
(raise-type-error who "path, string, or 'exact" exe))
exe)
(define (check-args who exe args)
(cond
[(eq? exe 'exact)
(unless (and (= 1 (length args))
(string? (car args))
(path-string? (car args)))
(raise-mismatch-error "expected a single string argument with 'exact, given: "
args))]
[else
(for ([s (in-list args)])
(unless (or (path-string? s)
(and (bytes? s)
(for/and ([b (in-bytes s)]) (positive? b))))
(raise-type-error who "path, string, or byte string (no with nuls)" s)))])
args)
(define (check-command who str)
(unless (or (string? str)
(bytes? str))
(raise-type-error who "string or byte string" str)))
;; Old-style functions: ----------------------------------------
(define (process*/ports cout cin cerr exe . args)
(define (do-process*/ports who 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)]
(if-stream-out who cout)
(if-stream-in who cin)
(if-stream-out who cerr #t)
(check-exe who exe)
(check-args who exe args))]
[(it-ready) (make-semaphore)])
(let ([so (streamify-out cout out)]
[si (streamify-in cin in (lambda (ok?)
@ -121,27 +156,32 @@
(aport se)
control)))))
(define (process*/ports cout cin cerr exe . args)
(apply do-process*/ports 'process*/ports cout cin cerr exe args))
(define (process/ports out in err str)
(apply process*/ports out in err (shell-path/args 'process/ports str)))
(apply do-process*/ports 'process/ports out in err (shell-path/args 'process/ports str)))
(define (process* exe . args)
(apply process*/ports #f #f #f exe args))
(apply do-process*/ports 'process* #f #f #f exe args))
(define (process str)
(apply process* (shell-path/args 'process str)))
(check-command 'process str)
(apply do-process*/ports 'process #f #f #f (shell-path/args 'process str)))
;; Note: these always use current ports
(define (system*/exit-code exe . args)
(define (do-system*/exit-code who 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)])
(if-stream-out who cout)
(if-stream-in who cin)
(if-stream-out who cerr #t)
(check-exe who exe)
(check-args who exe args))])
(let ([ot (streamify-out cout out)]
[it (streamify-in cin in (lambda (ok?)
(if ok?
@ -161,11 +201,16 @@
(when in (close-output-port in)))
(subprocess-status subp))))
(define (system*/exit-code exe . args)
(apply do-system*/exit-code 'system*/exit-code exe args))
(define (system* exe . args)
(zero? (apply system*/exit-code exe args)))
(zero? (apply do-system*/exit-code 'system* exe args)))
(define (system str)
(apply system* (shell-path/args 'system str)))
(check-command 'system str)
(zero? (apply do-system*/exit-code 'system (shell-path/args 'system str))))
(define (system/exit-code str)
(apply system*/exit-code (shell-path/args 'system/exit-code str)))
(check-command 'system/exit-code str)
(apply do-system*/exit-code 'system/exit-code (shell-path/args 'system/exit-code str)))

2
collects/mzlib/sandbox.rkt
View File

@ -36,7 +36,7 @@
;; Compatbility:
;; * recognize 'r5rs, etc, and wrap them as a list.
;; * 'begin form of reqs
;; * more agressively extract requires from lang and reqs
;; * more aggressively extract requires from lang and reqs
(define *make-evaluator
(case-lambda
[(lang reqs . progs)

2
collects/mzlib/thread.rkt
View File

@ -7,7 +7,7 @@
#|
t accepts a function, f, and creates a thread. It returns the thread and a
function, g. When g is applied it passes it's argument to f, and evaluates
function, g. When g is applied it passes its argument to f, and evaluates
the call of f in the time of the thread that was created. Calls to g do not
block.
|#

6
collects/net/ftp-unit.rkt
View File

@ -30,7 +30,7 @@
;; Checks a standard-format response, checking for the given
;; expected 3-digit result code if expected is not #f.
;;
;; While checking, the function sends reponse lines to
;; While checking, the function sends response lines to
;; diagnostic-accum. This function -accum functions can return a
;; value that accumulates over multiple calls to the function, and
;; accum-start is used as the initial value. Use `void' and
@ -178,7 +178,7 @@
(fprintf (ftp-connection-out tcp-ports) "LIST\n")
(ftp-check-response (ftp-connection-in tcp-ports)
(ftp-connection-out tcp-ports)
#"150" void (void))
(list #"150" #"125") void (void))
(let ([dir-list (filter-tcp-data tcp-data re:dir-line)])
(close-input-port tcp-data)
(ftp-check-response (ftp-connection-in tcp-ports)
@ -205,7 +205,7 @@
(display tcpstring (ftp-connection-out tcp-ports))
(ftp-check-response (ftp-connection-in tcp-ports)
(ftp-connection-out tcp-ports)
#"150" print-msg (void))
(list #"125" #"150") print-msg (void))
(copy-port tcp-data new-file)
(close-output-port new-file)
(close-input-port tcp-data)

2
collects/tests/racket/contract-mzlib-test.rktl
View File

@ -4618,7 +4618,7 @@ so that propagation occurs.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; provide/contract tests
;; (at the end, becuase they are slow w/out .zo files)
;; (at the end, because they are slow w/out .zo files)
;;
(test/spec-passed