commit 15f1a49a5f1b34c6d571fe2d4561b3005c418592
from: Sven M. Hallberg <pesco@khjk.org>
date: Wed Jul 16 15:14:02 2025 UTC

add -j option (concurrent jobs)

commit - ad438e39091f0b135bb9d964b2a92e8afb158f8e
commit + 15f1a49a5f1b34c6d571fe2d4561b3005c418592
blob - 6412d3ac001eec975c236cf75e58896b406b7507
blob + ebd39c4f42ec24c30364eb06cbd987c5e20c9f57
--- exercise
+++ exercise
@@ -9,6 +9,7 @@ package require Tcl 8.4
 
 # config options
 set opts(-B) .                  ;# basedir
+set opts(-j) 1                  ;# number of concurrent jobs
 set opts(-pd) {*}               ;# pattern for test search directories
 set opts(-ps) {*.ts}            ;# pattern for test suite executable files
 set opts(-pt) {*.t}             ;# pattern for test executable files
@@ -17,9 +18,17 @@ set opts(-q) 0                  ;# quiet mode
 
 # executing tests
 
-proc execute_test {countervar basedir path} {
-    global opts
-    upvar $countervar counters
+# A coroutine that starts the given test and yields a channel representing its
+# stdin/stdout. The initial invocation may also return the string "error" if
+# execution failed and no channel could be created. Unless an error occured,
+# subsequent invocations yield the empty string when awaiting more input or a
+# symbolic result (ok, error, or fail) to signify that the test has completed.
+#   The channel initially remains in blocking mode and may be ignored for
+# sequential operation. If set to non-blocking, an event handler should be set
+# up that resumes the coroutine whenever the channel becomes readable. When
+# the coroutine ends, the channel is closed and any event handler vanishes.
+proc execute_test {job basedir path} {
+    global opts counters
 
     # Should the test result be integrated as a nested test suite?
     set suite [string match $opts(-ps) [file tail $path]]
@@ -33,17 +42,24 @@ proc execute_test {countervar basedir path} {
     } else {
         # Capture stderr in a temporary file.
         # Unfortunately, 'chan pipe' only appears in Tcl 8.6. :(
-        set errfile "/tmp/exercise.testerr.[pid]"
+        set errfile "/tmp/exercise.[pid].$job.err"
     }
 
     set scounters {}
     if {[catch {
             # Execute the test, attaching pipes to stdin and stdout.
             set pipe [open "|$exe 2>$errfile" r+]
+            yield $pipe
 
             # Consume the test's stdout. Ignore it for normal tests.
             # Continually update the progress report for test suites.
-            while {[gets $pipe out] >= 0} {
+            while true {
+                if {[gets $pipe out] < 0} {
+                    if {[eof $pipe]} break
+                    yield                       ;# await further input and
+                    continue                    ;# try again
+                }
+
                 if {$suite} {
                     set scounters [sanitize_suite_counters $out]
                     print_progress [add_suite_counters $counters $scounters]
@@ -54,6 +70,7 @@ proc execute_test {countervar basedir path} {
             if {$suite} {check_suite_counters $scounters}
 
             # Wait for the subprocess to exit.
+            fconfigure $pipe -blocking true     ;# make sure we get CHILDSTATUS
             close $pipe
         } res opt]
     } {
@@ -121,6 +138,8 @@ proc execute_test {countervar basedir path} {
     } else {
         dict incr counters $what
     }
+
+    return $what
 }
 
 
@@ -384,16 +403,16 @@ proc getopt {argvvar optstring optvar argvar} {
 }
 
 proc main {argc argv} {
-    global opts env
+    global opts env counters J
     set counters {run 0  ok 0  fail 0  error 0}
 
     # handle environment variables
     if {[info exists env(EXERCISEDIR)]} {set opts(-D) $env(EXERCISEDIR)}
 
     # handle command line options
-    set u {[-q] [-B dir] [-C dir] [-D dir] [-p k=pattern] [path ...]}
+    set u {[-q] [-B dir] [-C dir] [-D dir] [-j n] [-p k=pattern] [path ...]}
     set prog [file tail $::argv0]
-    while {[getopt argv {B:C:D:p:q} opt arg]} {
+    while {[getopt argv {B:C:D:j:p:q} opt arg]} {
         if {$opt eq "?"} {
             puts stderr "usage: $prog $u"
             exit 1
@@ -413,6 +432,12 @@ proc main {argc argv} {
             set opt p$k
             set arg $v
         }
+        if {$opt eq "j"} {
+            if {![string is integer -strict $arg] || $arg < 1} {
+                puts stderr "$prog: -j expects positive integer argument"
+                exit 1
+            }
+        }
         set opts(-$opt) $arg
     }
     set argc [llength $argv]
@@ -434,10 +459,28 @@ proc main {argc argv} {
     # run the tests
     dict set counters run [llength $files]  ;# tentative total run count
                                             ;# might adjust when suites run
+    set J 0                                 ;# number of active jobs
+    set i 0                                 ;# running job id
     foreach file $files {
         print_progress $counters
-        execute_test counters $basedir $file
+
+        # wait for a slot to become available
+        while {$J >= $opts(-j)} {vwait J}
+
+        # start job
+        set job job[incr i]
+        set chan [coroutine $job execute_test $job $basedir $file]
+        if {$chan eq "error"} continue      ;# did not execute
+
+        # enter coroutine whenever chan becomes readable
+        fconfigure $chan -blocking false
+        fileevent $chan readable "if {\[$job\] ne {}} {incr J -1}"
+
+        incr J
     }
+    while {$J > 0} {vwait J}                ;# wait for all jobs to finish
+
+    # print final result summary
     if {!$opts(-q)} {puts [summary $counters]}
 
     # sanity-check counters, exit 127 if mismatched (should never happen)
blob - 3bf7865c8862a126c753341fbf3efd657fad3ea1
blob + 0a3258df7bafd9b42ec1f410698aca7f953052ab
--- exercise.1
+++ exercise.1
@@ -12,6 +12,7 @@
 .Op Fl B Ar dir
 .Op Fl C Ar dir
 .Op Fl D Ar dir
+.Op Fl j Ar n
 .Op Fl p Ar k Ns Sy = Ns Ar pattern
 .Op Ar path ...
 .
@@ -50,6 +51,10 @@ Execute tests from the given working directory.
 This is useful, for example, when
 .Ar dir
 contains common helper or data files for the tests to find.
+.It Fl j Ar n
+Execute up to
+.Ar n
+test jobs concurrently.
 .It Fl p Sy d= Ns Ar pattern
 When searching for tests,
 only descend into directories that match the given pattern.