442 lines
14 KiB
Racket
442 lines
14 KiB
Racket
|
|
(load-relative "testing.rktl")
|
|
|
|
(require mzlib/process)
|
|
|
|
(Section 'subprocess)
|
|
|
|
(define self
|
|
(parameterize ([current-directory (find-system-path 'orig-dir)])
|
|
(find-executable-path (find-system-path 'exec-file) #f)))
|
|
(define cat (find-executable-path
|
|
(if (eq? 'windows (system-type))
|
|
"cat.exe"
|
|
"cat")
|
|
#f))
|
|
(define tmpfile (build-path (find-system-path 'temp-dir) "cattmp"))
|
|
(define tmpfile2 (build-path (find-system-path 'temp-dir) "cattmp2"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; process* tests
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; Simple `process' tests using "cat"
|
|
|
|
(let ([p (process* cat)])
|
|
(fprintf (cadr p) "Hello\n")
|
|
(close-output-port (cadr p))
|
|
(test "Hello" read-line (car p))
|
|
(test eof read-line (car p))
|
|
(test eof read-line (cadddr p))
|
|
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-ok (list-ref p 4) 'status)
|
|
|
|
(close-input-port (car p))
|
|
(close-input-port (cadddr p)))
|
|
|
|
;; Generate output to stderr as well as stdout
|
|
|
|
(define (nosuchfile-test dash nosuchfile)
|
|
(let ([p (process* cat dash nosuchfile)])
|
|
(fprintf (cadr p) "Hello\n")
|
|
(close-output-port (cadr p))
|
|
(test "Hello" read-line (car p))
|
|
(test eof read-line (car p))
|
|
(test '("nosuchfile")
|
|
regexp-match "nosuchfile" (read-line (cadddr p)))
|
|
(test eof read-line (cadddr p))
|
|
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-error (list-ref p 4) 'status)
|
|
|
|
(close-input-port (car p))
|
|
(close-input-port (cadddr p))))
|
|
(nosuchfile-test "-" "nosuchfile")
|
|
(nosuchfile-test #"-" (string->path "nosuchfile"))
|
|
(nosuchfile-test (string->path "-") "nosuchfile")
|
|
|
|
;; Redirect stderr to stdout:
|
|
|
|
(let ([p (process*/ports #f #f 'stdout cat "-" "nosuchfile")])
|
|
(test #t file-stream-port? (car p))
|
|
(test #t file-stream-port? (cadr p))
|
|
(test #f cadddr p)
|
|
|
|
(fprintf (cadr p) "Hello\n")
|
|
(close-output-port (cadr p))
|
|
(test "Hello" read-line (car p))
|
|
(test '("nosuchfile")
|
|
regexp-match "nosuchfile" (read-line (car p)))
|
|
(test eof read-line (car p))
|
|
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-error (list-ref p 4) 'status)
|
|
|
|
(close-input-port (car p)))
|
|
|
|
;; Supply file for stdout
|
|
|
|
(let ([f (open-output-file tmpfile #:exists 'truncate/replace)])
|
|
(let ([p (process*/ports f #f #f cat)])
|
|
(test #f car p)
|
|
|
|
(fprintf (cadr p) "Hello\n")
|
|
(close-output-port (cadr p))
|
|
(test eof read-line (cadddr p))
|
|
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-ok (list-ref p 4) 'status)
|
|
|
|
(close-output-port f)
|
|
(test 6 file-size tmpfile)
|
|
(test 'Hello with-input-from-file tmpfile read)
|
|
|
|
(close-input-port (cadddr p))))
|
|
|
|
;; Supply file for stdout & stderr, only stdout writes
|
|
|
|
(define (stderr-to-stdout-test stderr-filter)
|
|
(let ([f (open-output-file tmpfile #:exists 'truncate/replace)])
|
|
(let ([p (process*/ports f #f (stderr-filter f) cat)])
|
|
(test #f car p)
|
|
(test #f cadddr p)
|
|
|
|
(fprintf (cadr p) "Hello\n")
|
|
(close-output-port (cadr p))
|
|
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-ok (list-ref p 4) 'status)
|
|
|
|
(close-output-port f)
|
|
(test 6 file-size tmpfile)
|
|
(test 'Hello with-input-from-file tmpfile read))))
|
|
(stderr-to-stdout-test values)
|
|
(stderr-to-stdout-test (lambda (x) 'stdout))
|
|
|
|
;; Supply file for stderr
|
|
|
|
(let ([f (open-output-file tmpfile #:exists 'truncate/replace)])
|
|
(let ([p (process*/ports #f #f f cat "nosuchfile")])
|
|
(test #f cadddr p)
|
|
|
|
(close-output-port (cadr p))
|
|
|
|
(test eof read-line (car p))
|
|
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-error (list-ref p 4) 'status)
|
|
|
|
(close-output-port f)
|
|
(test '("nosuchfile")
|
|
regexp-match "nosuchfile" (with-input-from-file tmpfile
|
|
read-line))
|
|
|
|
(close-input-port (car p))))
|
|
|
|
;; Supply file for stdout & stderr, only stderr writes
|
|
|
|
(let ([f (open-output-file tmpfile #:exists 'truncate/replace)])
|
|
(let ([p (process*/ports f #f f cat "nosuchfile")])
|
|
(test #f car p)
|
|
(test #f cadddr p)
|
|
|
|
(close-output-port (cadr p))
|
|
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-error (list-ref p 4) 'status)
|
|
|
|
(close-output-port f)
|
|
(test '("nosuchfile")
|
|
regexp-match "nosuchfile" (with-input-from-file tmpfile
|
|
read-line))))
|
|
|
|
;; Supply file for stdout & stderr, both write
|
|
|
|
(let ([f (open-output-file tmpfile #:exists 'truncate/replace)])
|
|
(let ([p (process*/ports f #f f cat "-" "nosuchfile")])
|
|
(test #f car p)
|
|
(test #f cadddr p)
|
|
|
|
(fprintf (cadr p) "First line\n")
|
|
(close-output-port (cadr p))
|
|
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-error (list-ref p 4) 'status)
|
|
|
|
(close-output-port f)
|
|
(with-input-from-file tmpfile
|
|
(lambda ()
|
|
(test "First line" read-line)
|
|
(test '("nosuchfile") regexp-match "nosuchfile" (read-line))
|
|
(test eof read-line)))))
|
|
|
|
;; Supply separate files for stdout & stderr
|
|
|
|
(let ([f (open-output-file tmpfile #:exists 'truncate/replace)]
|
|
[f2 (open-output-file tmpfile2 #:exists 'truncate/replace)])
|
|
(let ([p (process*/ports f #f f2 cat "-" "nosuchfile")])
|
|
(test #f car p)
|
|
(test #f cadddr p)
|
|
|
|
(fprintf (cadr p) "The line\n")
|
|
(close-output-port (cadr p))
|
|
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-error (list-ref p 4) 'status)
|
|
|
|
(close-output-port f)
|
|
(close-output-port f2)
|
|
|
|
(with-input-from-file tmpfile
|
|
(lambda ()
|
|
(test "The line" read-line)
|
|
(test eof read-line)))
|
|
|
|
(with-input-from-file tmpfile2
|
|
(lambda ()
|
|
(test '("nosuchfile") regexp-match "nosuchfile" (read-line))
|
|
(test eof read-line)))))
|
|
|
|
;; Supply file for stdin
|
|
|
|
(let ([f (open-output-file tmpfile #:exists 'truncate/replace)])
|
|
(fprintf f "Howdy\n")
|
|
(close-output-port f))
|
|
(let ([f (open-input-file tmpfile)])
|
|
(let ([p (process*/ports #f f #f cat)])
|
|
(test #f cadr p)
|
|
|
|
(test "Howdy" read-line (car p))
|
|
(test eof read-line (car p))
|
|
(test eof read-line (cadddr p))
|
|
|
|
(close-input-port f)
|
|
|
|
(close-input-port (car p))
|
|
(close-input-port (cadddr p))))
|
|
|
|
;; Files for everyone
|
|
|
|
(let ([f (open-input-file tmpfile)]
|
|
[f2 (open-output-file tmpfile2 #:exists 'truncate/replace)])
|
|
(let ([p (process*/ports f2 f f2 cat "-" "nosuchfile")])
|
|
(test #f car p)
|
|
(test #f cadr p)
|
|
(test #f cadddr p)
|
|
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-error (list-ref p 4) 'status)
|
|
|
|
(close-input-port f)
|
|
(close-output-port f2)
|
|
|
|
(with-input-from-file tmpfile2
|
|
(lambda ()
|
|
(test "Howdy" read-line)
|
|
(test '("nosuchfile") regexp-match "nosuchfile" (read-line))))))
|
|
|
|
;; strings for everyone
|
|
|
|
(let ([f (open-input-string (string-append
|
|
"1"
|
|
(make-string 50000 #\0)
|
|
"\n"))]
|
|
[f2 (open-output-string)])
|
|
(let ([p (process*/ports f2 f f2 cat "-" "nosuchfile")])
|
|
(test #f car p)
|
|
(test #f cadr p)
|
|
(test #f cadddr p)
|
|
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-error (list-ref p 4) 'status)
|
|
|
|
(let ([p (open-input-string (get-output-string f2))])
|
|
(test (expt 10 50000) read p)
|
|
(test "" read-line p)
|
|
(test '("nosuchfile") regexp-match "nosuchfile" (read-line p)))))
|
|
|
|
;; Check error cases
|
|
|
|
(let ([f (open-input-file tmpfile)]
|
|
[f2 (open-output-file tmpfile2 #:exists 'truncate/replace)])
|
|
|
|
(let ([test
|
|
(lambda (o i e)
|
|
(err/rt-test (process*/ports o i e cat)))])
|
|
(test f #f #f)
|
|
(test #f f2 #f)
|
|
(test #f #f f)
|
|
|
|
(test f f f2)
|
|
(test f2 f2 f2)
|
|
(test f2 f f)))
|
|
|
|
;; system* ------------------------------------------------------
|
|
|
|
(let ([out (open-output-string)])
|
|
(test #t 'system*
|
|
(parameterize ([current-input-port (open-input-string "Hi\n")]
|
|
[current-output-port out])
|
|
(system* cat "-")))
|
|
(test "Hi\n" get-output-string out))
|
|
|
|
(let ([out (open-output-string)])
|
|
(test 0 'system*/exit-code
|
|
(parameterize ([current-input-port (open-input-string "Hi\n")]
|
|
[current-output-port out])
|
|
(system*/exit-code cat "-")))
|
|
(test "Hi\n" get-output-string out))
|
|
|
|
;; shells ------------------------------------------------------
|
|
|
|
(let ([go
|
|
(lambda (path->string)
|
|
(let ([p (process (path->string cat))])
|
|
(fprintf (cadr p) "Hi\n")
|
|
(close-output-port (cadr p))
|
|
(test "Hi" read-line (car p) 'any)
|
|
(close-input-port (car p))
|
|
(close-input-port (cadddr p))
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-ok (list-ref p 4) 'status)))])
|
|
(go path->string)
|
|
(go path->bytes))
|
|
|
|
(let ([p (process/ports #f (open-input-string "Hi\n") 'stdout (path->string cat))])
|
|
(test "Hi" read-line (car p) 'any)
|
|
(close-input-port (car p))
|
|
(test #f cadddr p)
|
|
((list-ref p 4) 'wait)
|
|
(test 'done-ok (list-ref p 4) 'status))
|
|
|
|
(let ([out (open-output-string)])
|
|
(test #t 'system
|
|
(parameterize ([current-input-port (open-input-string "Hi\n")]
|
|
[current-output-port out])
|
|
(system (path->string cat))))
|
|
(test "Hi\n" get-output-string out))
|
|
|
|
(let ([out (open-output-string)])
|
|
(test 0 'system
|
|
(parameterize ([current-input-port (open-input-string "Hi\n")]
|
|
[current-output-port out])
|
|
(system/exit-code (path->string cat))))
|
|
(test "Hi\n" get-output-string out))
|
|
|
|
;; empty strings and nul checks ------------------------------------------------------
|
|
|
|
(err/rt-test (subprocess #f #f #f ""))
|
|
(err/rt-test (process* ""))
|
|
(err/rt-test (system* ""))
|
|
|
|
(let ([no-nuls (lambda (thunk)
|
|
(err/rt-test (thunk) (lambda (exn)
|
|
(regexp-match? #rx"without nuls" (exn-message exn)))))])
|
|
(no-nuls (lambda () (subprocess #f #f #f cat "\0")))
|
|
(no-nuls (lambda () (subprocess #f #f #f cat #"\0")))
|
|
(no-nuls (lambda () (process "\0")))
|
|
(no-nuls (lambda () (process* cat "\0")))
|
|
(no-nuls (lambda () (process*/ports #f #f #f cat "\0")))
|
|
(no-nuls (lambda () (system "\0")))
|
|
(no-nuls (lambda () (system* cat "\0"))))
|
|
|
|
(let ([call-empty-arg
|
|
(lambda (empty-arg)
|
|
(let ([out (open-output-string)])
|
|
(test #t 'system-empty-string
|
|
(parameterize ([current-input-port (open-input-string "Hi\n")]
|
|
[current-output-port out])
|
|
(system* self "-e" "(current-command-line-arguments)" empty-arg)))
|
|
(test "'#(\"\")\n" get-output-string out)))])
|
|
(call-empty-arg "")
|
|
(call-empty-arg #""))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; nested tests
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-values (r w id e f)
|
|
(apply values (process* self
|
|
"-e"
|
|
"(let loop () (unless (eof-object? (eval (read))) (loop)))")))
|
|
|
|
(define (test-line out in)
|
|
(fprintf w "~a\n" in)
|
|
(flush-output w)
|
|
(when out
|
|
(test out (lambda (ignored) (read-line r)) in)))
|
|
|
|
(test-line "17" "(display 17) (newline) (flush-output)")
|
|
|
|
(close-input-port r)
|
|
(close-input-port e)
|
|
(close-output-port w)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; custodians
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(let ([try
|
|
(lambda (post-shutdown)
|
|
(let ([c (make-custodian)])
|
|
(let ([l (parameterize ([current-custodian c])
|
|
(process* self
|
|
"-e"
|
|
"(let loop () (loop))"))])
|
|
(test 'running (list-ref l 4) 'status)
|
|
(custodian-shutdown-all c)
|
|
(sleep 0.1)
|
|
(test post-shutdown (list-ref l 4) 'status)
|
|
((list-ref l 4) 'kill))))])
|
|
(try 'running)
|
|
(parameterize ([current-subprocess-custodian-mode 'kill])
|
|
(try 'done-error))
|
|
(parameterize ([current-subprocess-custodian-mode 'interrupt])
|
|
(try (if (eq? 'windows (system-type)) 'running 'done-error))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; process groups
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(unless (eq? 'windows (system-type))
|
|
(let ([try
|
|
(lambda (post-shutdown?)
|
|
(let ([l (parameterize ([subprocess-group-enabled (not post-shutdown?)])
|
|
(process* self
|
|
"-e"
|
|
(format "(define l (process* \"~a\" \"-e\" \"(let loop () (loop))\"))" self)
|
|
"-e"
|
|
"(displayln (list-ref l 2))"
|
|
"-e"
|
|
"(flush-output)"
|
|
"-e"
|
|
"(let loop () (loop))"))]
|
|
[running? (lambda (sub-pid)
|
|
(equal?
|
|
(list (number->string sub-pid))
|
|
(regexp-match
|
|
(format "(?m:^ *~a(?=[^0-9]))" sub-pid)
|
|
(let ([s (open-output-string)])
|
|
(parameterize ([current-output-port s]
|
|
[current-input-port (open-input-string "")])
|
|
(system (format "ps x")))
|
|
(get-output-string s)))))])
|
|
(let ([sub-pid (read (car l))])
|
|
(test 'running (list-ref l 4) 'status)
|
|
(test #t running? sub-pid)
|
|
((list-ref l 4) 'kill)
|
|
((list-ref l 4) 'wait)
|
|
(test 'done-error (list-ref l 4) 'status)
|
|
(test post-shutdown? running? sub-pid)
|
|
(when post-shutdown?
|
|
(parameterize ([current-input-port (open-input-string "")])
|
|
(system (format "kill ~a" sub-pid)))))))])
|
|
(try #t)
|
|
(try #f)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(report-errs)
|