Merge branch 'master' of git:plt

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)

src/worksp/gracket/gracket.manifest

@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8" standalone="yes"?> 
 <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> 
 <assemblyIdentity 
-version="4.2.5.10" 
+version="4.2.5.14" 
 processorArchitecture="X86" 
 name="Org.PLT-Scheme.GRacket" 
 type="win32" 

src/worksp/gracket/gracket.rc

@@ -20,8 +20,8 @@ APPLICATION             ICON    DISCARDABLE     "gracket.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,5,10
+ FILEVERSION 4,2,5,14
- PRODUCTVERSION 4,2,5,10
+ PRODUCTVERSION 4,2,5,14
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -39,11 +39,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "Racket GUI application\0"
             VALUE "InternalName", "GRacket\0"
-            VALUE "FileVersion", "4, 2, 5, 10\0"
+            VALUE "FileVersion", "4, 2, 5, 14\0"
             VALUE "LegalCopyright", "Copyright © 1995-2010\0"
             VALUE "OriginalFilename", "GRacket.exe\0"
             VALUE "ProductName", "Racket\0"
-            VALUE "ProductVersion", "4, 2, 5, 10\0"
+            VALUE "ProductVersion", "4, 2, 5, 14\0"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/mzcom/mzcom.rc

@@ -53,8 +53,8 @@ END
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,5,10
+ FILEVERSION 4,2,5,14
- PRODUCTVERSION 4,2,5,10
+ PRODUCTVERSION 4,2,5,14
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -70,12 +70,12 @@ BEGIN
         BLOCK "040904b0"
         BEGIN
             VALUE "FileDescription", "MzCOM Module"
-            VALUE "FileVersion", "4, 2, 5, 10"
+            VALUE "FileVersion", "4, 2, 5, 14"
             VALUE "InternalName", "MzCOM"
             VALUE "LegalCopyright", "Copyright 2000-2010 PLT (Paul Steckler)"
             VALUE "OriginalFilename", "MzCOM.EXE"
             VALUE "ProductName", "MzCOM Module"
-            VALUE "ProductVersion", "4, 2, 5, 10"
+            VALUE "ProductVersion", "4, 2, 5, 14"
         END
     END
     BLOCK "VarFileInfo"
@@ -108,7 +108,7 @@ BEGIN
     CTEXT           "MzCOM v. 4.2",IDC_STATIC,71,8,61,8
     CTEXT           "Copyright (c) 2000-2010 PLT (Paul Steckler)",IDC_STATIC,
                     41,20,146,9
-    CTEXT           "MzScheme v. 4.2",IDC_STATIC,64,35,75,8
+    CTEXT           "Racket v. 4.2",IDC_STATIC,64,35,75,8
     CTEXT           "Copyright (c) 1995-2010 PLT Inc.",IDC_STATIC,
                     30,47,143,8
     ICON            MZICON,IDC_STATIC,11,16,20,20

src/worksp/mzcom/mzobj.rgs

@@ -1,19 +1,19 @@
 HKCR
 {
-	MzCOM.MzObj.4.2.5.10 = s 'MzObj Class'
+	MzCOM.MzObj.4.2.5.14 = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
 	}
 	MzCOM.MzObj = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
-		CurVer = s 'MzCOM.MzObj.4.2.5.10'
+		CurVer = s 'MzCOM.MzObj.4.2.5.14'
 	}
 	NoRemove CLSID
 	{
 		ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
 		{
-			ProgID = s 'MzCOM.MzObj.4.2.5.10'
+			ProgID = s 'MzCOM.MzObj.4.2.5.14'
 			VersionIndependentProgID = s 'MzCOM.MzObj'
 			ForceRemove 'Programmable'
 			LocalServer32 = s '%MODULE%'

src/worksp/racket/racket.rc

@@ -29,8 +29,8 @@ APPLICATION             ICON    DISCARDABLE     "racket.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,5,10
+ FILEVERSION 4,2,5,14
- PRODUCTVERSION 4,2,5,10
+ PRODUCTVERSION 4,2,5,14
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -48,11 +48,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "Racket application\0"
             VALUE "InternalName", "Racket\0"
-            VALUE "FileVersion", "4, 2, 5, 10\0"
+            VALUE "FileVersion", "4, 2, 5, 14\0"
             VALUE "LegalCopyright", "Copyright <20>© 1995-2010\0"
             VALUE "OriginalFilename", "racket.exe\0"
             VALUE "ProductName", "Racket\0"
-            VALUE "ProductVersion", "4, 2, 5, 10\0"
+            VALUE "ProductVersion", "4, 2, 5, 14\0"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/starters/start.rc

@@ -22,8 +22,8 @@ APPLICATION             ICON    DISCARDABLE     "mzstart.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,2,5,10
+ FILEVERSION 4,2,5,14
- PRODUCTVERSION 4,2,5,10
+ PRODUCTVERSION 4,2,5,14
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -45,7 +45,7 @@ BEGIN
 #ifdef MZSTART
             VALUE "FileDescription", "Racket Launcher\0"
 #endif
-            VALUE "FileVersion", "4, 2, 5, 10\0"
+            VALUE "FileVersion", "4, 2, 5, 14\0"
 #ifdef MRSTART
             VALUE "InternalName", "mrstart\0"
 #endif
@@ -60,7 +60,7 @@ BEGIN
             VALUE "OriginalFilename", "MzStart.exe\0"
 #endif
             VALUE "ProductName", "Racket\0"
-            VALUE "ProductVersion", "4, 2, 5, 10\0"
+            VALUE "ProductVersion", "4, 2, 5, 14\0"
         END
     END
     BLOCK "VarFileInfo"