Adjust run/collect and adding test

collects/meta/drdr/run-collect.ss

@@ -14,15 +14,6 @@
                   (list* cmd
                          args))))
 
-(define (read-until-evt port-evt k)
-  (if port-evt
-      (handle-evt port-evt
-                  (lambda (bs)
-                    (if (eof-object? bs)
-                        (k)
-                        (k bs))))
-      never-evt))
-
 (define (run/collect/wait 
          #:env env
          #:timeout timeout
@@ -40,7 +31,7 @@
   (define-values
     (the-process stdout stdin stderr)
     (apply subprocess
-           #f #f #f 
+           #f #f #f
            new-command 
            new-args))
   
@@ -49,48 +40,58 @@
   ; Run it without input
   (close-output-port stdin)
   
-  ; Wait for all the output, then the process death or timeout
+  ; Wait for all the output and the process death or timeout
   (local
     [(define the-alarm
-       (alarm-evt (+ (current-inexact-milliseconds)
+       (alarm-evt (+ start-time (* 1000 timeout))))
-                     (* 1000 timeout))))
+     
-     (define (slurp-output-evt loop stdout stderr log)
+     (define line-ch (make-channel))
-       (choice-evt
+     (define (read-port-t make port)
-        (read-until-evt stdout
+       (thread
-                        (case-lambda 
+        (λ ()
-                          [() 
+          (let loop ()
-                           (loop #f stderr log)]
+            (define l (read-bytes-line port))
-                          [(bs)
+            (if (eof-object? l)
-                           (loop stdout stderr (list* (make-stdout bs) log))]))
+                (channel-put line-ch l)
-        (read-until-evt stderr
+                (begin (channel-put line-ch (make l))
-                        (case-lambda 
+                       (loop)))))))
-                          [() 
+     (define stdout-t (read-port-t make-stdout stdout))
-                           (loop stdout #f log)]
+     (define stderr-t (read-port-t make-stderr stderr))
-                          [(bs)
-                           (loop stdout stderr (list* (make-stderr bs) log))]))))
-     (define (finish-log stdout stderr log)
-       (if (or stdout stderr)
-           (sync (slurp-output-evt finish-log stdout stderr log))
-           (reverse log)))
      
      (define final-status
-       (let loop ([stdout (read-bytes-line-evt stdout)]
+       (let loop ([open-ports 2]
-                  [stderr (read-bytes-line-evt stderr)]
+                  [end-time #f]
+                  [status #f]
                   [log empty])
-         (sync (handle-evt the-alarm
+         (define process-done? (and end-time #t))
-                           (lambda (_)
+         (define output-done? (zero? open-ports))
-                             (define end-time 
+         (if (and output-done? process-done?)
-                               (current-inexact-milliseconds))
+             (if status
-                             (subprocess-kill the-process #t)
+                 (make-exit start-time end-time command-line (reverse log) status)
-                             (make-timeout start-time end-time command-line (finish-log stdout stderr log))))
+                 (make-timeout start-time end-time command-line (reverse log)))
-               (slurp-output-evt loop stdout stderr log)
+             (sync (if process-done?
-               (handle-evt the-process
+                       never-evt
-                           (lambda (_)
+                       (choice-evt 
-                             (define end-time 
+                        (handle-evt the-alarm
-                               (current-inexact-milliseconds))
+                                    (λ (_)
-                             (make-exit start-time end-time command-line
+                                      (define end-time 
-                                        (finish-log stdout stderr log)
+                                        (current-inexact-milliseconds))
-                                        (subprocess-status the-process)))))))]
+                                      (subprocess-kill the-process #t)
+                                      (loop open-ports end-time status log)))
+                        (handle-evt the-process
+                                    (λ (_)
+                                      (define end-time 
+                                        (current-inexact-milliseconds))
+                                      (loop open-ports end-time (subprocess-status the-process) log)))))
+                   (if output-done?
+                       never-evt
+                       (handle-evt line-ch
+                                   (match-lambda
+                                     [(? eof-object?)
+                                      (loop (sub1 open-ports) end-time status log)]
+                                     [l
+                                      (loop open-ports end-time status (list* l log))])))))))]
+    
     (close-input-port stdout)
     (close-input-port stderr)
     
@@ -140,6 +141,12 @@
 (provide/contract
  [command+args+env->command+args 
   (string? (listof string?) #:env (hash/c string? string?) . -> . (values string? (listof string?)))]
+ [run/collect/wait
+  (string? 
+   #:env (hash/c string? string?) 
+   #:timeout exact-nonnegative-integer? 
+   (listof string?) 
+   . -> . status?)]
  [run/collect/wait/log 
   (path-string? string? 
                 #:env (hash/c string? string?) 

collects/meta/drdr/tests/loud.rkt

@@ -0,0 +1,11 @@
+#lang racket
+
+(define n (command-line #:args (n) (string->number n)))
+
+(for ([i (in-range n)])
+  (fprintf (if (even? i)
+               (current-error-port)
+               (current-output-port))
+           "~a~n"
+           i))
+

collects/meta/drdr/tests/run-collect.rkt

@@ -0,0 +1,32 @@
+#lang racket
+(require "../run-collect.ss" 
+         "../status.ss"
+         racket/runtime-path
+         tests/eli-tester)
+
+(define-runtime-path loud-file "loud.rkt")
+
+(define (run-loud n)
+  (run/collect/wait #:env (hash)
+                    #:timeout (* 10)
+                    (path->string (find-system-path 'exec-file))
+                    (list "-t" (path->string loud-file)
+                          "--" (number->string n))))
+
+(define (test-run-loud n)
+  (test
+   #:failure-prefix (number->string n)
+   (status-output-log (run-loud n))
+   =>
+   (for/list ([i (in-range n)])
+     ((if (even? i)
+          make-stderr
+          make-stdout)
+      (string->bytes/utf-8
+       (number->string i))))))
+
+(test
+ (for ([n (in-range 10)])
+   (test-run-loud n)))
+
+(run-loud 10)