Browse Source
Saves are write-temp-then-atomic-rename with bounded retry for Windows
sharing violations; load_records_from_file retries transient open
denials during a writer's replace window (parse errors stay strict -
they mean real corruption). Readers gain torn-read immunity with no
reader-side protocol.
New punkcheck::lock namespace (PUNKARGS-documented): advisory sibling
lockfile <punkcheckfile>.lock via open {WRONLY CREAT EXCL}, contents
naming holder pid/host/installer/timestamp, channel held open for the
duration, in-process reference-counted re-acquisition (sequential
make.tcl installers over one root must not self-deadlock). start_event
acquires; event end / installtrack destroy releases; flushes and
chokepoint saves outside an event take a transient lock. Contention
retries with backoff to -timeout (env PUNKCHECK_LOCK_TIMEOUT, default
15s) then errors naming the holder; stale locks break on provably-dead
holder pid (twapi process_exists / kill -0, capability-gated) or age
(-staleage / PUNKCHECK_LOCK_STALEAGE, default 300s).
Deferred flushes merge own records (INSTALLER by -name, touched
FILEINFO by -targets) into freshly-loaded file state under the lock
instead of wholesale overwrite; an mtime/size tripwire warns when a
non-protocol writer (e.g. older vendored punkcheck) touched the file
between load and save.
Duplicate-INSTALLER recovery: clean actionable error when stdin is
non-interactive (punkcheck::lib::stdin_is_interactive - strict twapi
GetConsoleMode on the real stdin handle on Windows, -inputmode probe /
test -t 0 on unix); the interactive prompt gains the synced-targets
deletion-wedge caveat. default_excludefiletail_core adds .punkcheck.*
so protocol siblings are never installable content.
Consumers verified without edits: cli and five make.tcl sites end their
events (lock released at end); make.tcl's vfs/bin kit flows destroy
their installers on every path (destructor releases).
New concurrency.test (6 tests): two child installer processes with a
polling reader (no parse errors, both installers survive, no duplicate
INSTALLERs, no lock/tmp leftovers), lock timeout naming the holder then
success after release, dead-pid and age stale-breaks against planted
lockfiles, non-interactive duplicate-INSTALLER error via pipe-stdin
child, protocol-sibling exclusion pin.
Matrix: Windows Tcl 9.0.3 84/84 (runtests), Windows Tcl 8.6.17 84/84
(direct tcltest drive - the runtests harness itself needs lpop under
native 8.6), linux WSL tclsh 8.6.14 84/84 (native-FS staged run).
punk/mix subtree unaffected (150 pass / 1 known constraint-skip).
Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com
master
3 changed files with 784 additions and 55 deletions
@ -0,0 +1,319 @@
|
||||
# -*- tcl -*- |
||||
# G-095 concurrency tests for punkcheck: atomic saves, advisory event-scoped locking, |
||||
# stale-lock breaking, and the non-interactive duplicate-INSTALLER recovery. |
||||
# Drives real child processes of the same interpreter against one .punkcheck folder. |
||||
# Run: tclsh src/tests/runtests.tcl -report compact -show-passes 0 -include-paths modules/punkcheck/*** concurrency.test |
||||
|
||||
package require tcltest |
||||
package require punkcheck |
||||
package require punk::lib |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Capability constraints |
||||
# ------------------------------------------------------------------------- |
||||
# child-process facility: can we exec the running interpreter with a script? |
||||
set can_exec_child 0 |
||||
set probe_script [file join [punk::lib::tempdir_newfolder -prefix pkccprobe] probe.tcl] |
||||
set fd [open $probe_script w] |
||||
puts $fd {puts PROBE-OK} |
||||
close $fd |
||||
if {![catch {exec [info nameofexecutable] $probe_script} probe_out] && [string match *PROBE-OK* $probe_out]} { |
||||
set can_exec_child 1 |
||||
} |
||||
file delete -force [file dirname $probe_script] |
||||
tcltest::testConstraint canexecchild $can_exec_child |
||||
|
||||
# pid-liveness capability (twapi on windows, kill -0 on unix) - the dead-pid stale-break |
||||
# test depends on a confident 'dead' verdict being available |
||||
tcltest::testConstraint haspidliveness [expr {[punkcheck::lock::pid_liveness [pid]] eq "alive"}] |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Helpers |
||||
# ------------------------------------------------------------------------- |
||||
proc make_workspace {} { |
||||
set root [punk::lib::tempdir_newfolder -prefix pkconctest] |
||||
set punkcheck_file [file join $root .punkcheck] |
||||
set srcdir [file join $root src] |
||||
set tgtdir [file join $root tgt] |
||||
file mkdir $srcdir $tgtdir |
||||
return [dict create root $root punkcheck_file $punkcheck_file srcdir $srcdir tgtdir $tgtdir] |
||||
} |
||||
proc write_file {path content} { |
||||
file mkdir [file dirname $path] |
||||
set fd [open $path w] |
||||
chan configure $fd -translation lf |
||||
try { puts -nonewline $fd $content } finally { close $fd } |
||||
return $path |
||||
} |
||||
#script preamble reproducing this interpreter's module search state in a child process |
||||
proc child_preamble {} { |
||||
set preamble "package prefer latest\n" |
||||
foreach p [lreverse [tcl::tm::path list]] { |
||||
append preamble "tcl::tm::path add [list $p]\n" |
||||
} |
||||
append preamble "set ::auto_path [list $::auto_path]\n" |
||||
append preamble "package require punkcheck\n" |
||||
return $preamble |
||||
} |
||||
#poll for a condition script returning true; fail with $what after $deadline_ms |
||||
proc poll_until {condition deadline_ms what} { |
||||
set deadline [expr {[clock milliseconds] + $deadline_ms}] |
||||
while {![uplevel 1 $condition]} { |
||||
if {[clock milliseconds] >= $deadline} { |
||||
error "timeout waiting for: $what" |
||||
} |
||||
after 25 |
||||
} |
||||
} |
||||
|
||||
#added 2026-07-21 (agent, G-095) - concurrency suite: atomic saves, advisory event lock, stale-break, non-interactive recovery |
||||
|
||||
# ========================================================================= |
||||
# --- two concurrent installer processes: no corruption, no lost records --- |
||||
# ========================================================================= |
||||
|
||||
test concurrency_two_writers_no_corruption {two child installer processes: file parses throughout, both installers' records survive, no duplicate INSTALLERs}\ |
||||
-constraints canexecchild\ |
||||
-body { |
||||
set ws [make_workspace] |
||||
set root [dict get $ws root] |
||||
set pf [dict get $ws punkcheck_file] |
||||
write_file [file join $root common_src.txt] "shared-source-content" |
||||
set writer [file join $root writer.tcl] |
||||
set script [child_preamble] |
||||
append script { |
||||
lassign $argv pf root name |
||||
for {set ev 0} {$ev < 3} {incr ev} { |
||||
set installer [punkcheck::installtrack new $name $pf] |
||||
$installer set_source_target $root/src $root/tgt |
||||
set event [$installer start_event [list -step $name$ev]] |
||||
foreach t {a b} { |
||||
set target ${name}_${ev}_${t}.txt |
||||
$event targetset_init INSTALL $target |
||||
$event targetset_addsource $root/common_src.txt |
||||
$event targetset_started |
||||
set fd [open $root/$target w] |
||||
puts -nonewline $fd "payload-$name-$ev-$t" |
||||
close $fd |
||||
$event targetset_end OK |
||||
} |
||||
$installer end_event |
||||
$installer destroy |
||||
after 10 |
||||
} |
||||
set fd [open $root/done_$name w] |
||||
close $fd |
||||
puts DONE-$name |
||||
} |
||||
write_file $writer $script |
||||
set exe [info nameofexecutable] |
||||
exec $exe $writer $pf $root WRA > $root/outA.log 2>@1 & |
||||
exec $exe $writer $pf $root WRB > $root/outB.log 2>@1 & |
||||
#polling reader: every load must parse cleanly (atomic renames - no torn reads) |
||||
set parse_errors [list] |
||||
set observed_loads 0 |
||||
set deadline [expr {[clock milliseconds] + 60000}] |
||||
while {!([file exists $root/done_WRA] && [file exists $root/done_WRB])} { |
||||
if {[clock milliseconds] >= $deadline} { |
||||
set loga "" ; set logb "" |
||||
catch {set loga [punk::mix::util::fcat $root/outA.log]} |
||||
catch {set logb [punk::mix::util::fcat $root/outB.log]} |
||||
error "timeout waiting for writer children. A: $loga B: $logb" |
||||
} |
||||
if {[file exists $pf]} { |
||||
if {[catch {punkcheck::load_records_from_file $pf} r]} { |
||||
lappend parse_errors $r |
||||
} else { |
||||
incr observed_loads |
||||
} |
||||
} |
||||
after 20 |
||||
} |
||||
set records [punkcheck::load_records_from_file $pf] |
||||
#get_installer_record errors on duplicates - catch result 0 + found position proves exactly one |
||||
set dup_or_missing [list] |
||||
foreach name {WRA WRB} { |
||||
if {[catch {punkcheck::recordlist::get_installer_record $name $records} info]} { |
||||
lappend dup_or_missing "$name: $info" |
||||
} elseif {[dict get $info position] == -1} { |
||||
lappend dup_or_missing "$name: missing" |
||||
} |
||||
} |
||||
set missing_targets [list] |
||||
foreach name {WRA WRB} { |
||||
for {set ev 0} {$ev < 3} {incr ev} { |
||||
foreach t {a b} { |
||||
set target ${name}_${ev}_${t}.txt |
||||
if {[dict get [punkcheck::recordlist::get_file_record $target $records] position] == -1} { |
||||
lappend missing_targets $target |
||||
} |
||||
} |
||||
} |
||||
} |
||||
set leftovers [glob -nocomplain -tails -dir $root .punkcheck.lock .punkcheck.tmp.*] |
||||
list parse_errors [llength $parse_errors] reader_ran [expr {$observed_loads > 0}] installer_problems $dup_or_missing missing_targets $missing_targets leftovers $leftovers |
||||
}\ |
||||
-cleanup { |
||||
file delete -force [dict get $ws root] |
||||
}\ |
||||
-result {parse_errors 0 reader_ran 1 installer_problems {} missing_targets {} leftovers {}} |
||||
|
||||
# ========================================================================= |
||||
# --- lock contention: waiting and timeout naming the holder --- |
||||
# ========================================================================= |
||||
|
||||
test concurrency_lock_timeout_names_holder {second writer times out with a message naming the holder from lockfile contents, then succeeds after release}\ |
||||
-constraints canexecchild\ |
||||
-body { |
||||
set ws [make_workspace] |
||||
set root [dict get $ws root] |
||||
set pf [dict get $ws punkcheck_file] |
||||
set holder [file join $root holder.tcl] |
||||
set script [child_preamble] |
||||
append script { |
||||
lassign $argv pf root |
||||
set tok [punkcheck::lock::acquire $pf -installer HOLDER-CHILD] |
||||
set fd [open $root/held w]; close $fd |
||||
after 2500 |
||||
punkcheck::lock::release $tok |
||||
set fd [open $root/released w]; close $fd |
||||
} |
||||
write_file $holder $script |
||||
exec [info nameofexecutable] $holder $pf $root > $root/holder.log 2>@1 & |
||||
poll_until {expr {[file exists $root/held]}} 30000 "holder child to acquire the lock" |
||||
#contended attempt with a short timeout - must error naming the holder |
||||
set errcaught [catch {punkcheck::lock::acquire $pf -installer IMPATIENT -timeout 400} errmsg erropts] |
||||
set code_ok [expr {[lrange [dict get $erropts -errorcode] 0 2] eq [list PUNKCHECK LOCK TIMEOUT]}] |
||||
poll_until {expr {[file exists $root/released]}} 30000 "holder child to release the lock" |
||||
#after release the same acquisition succeeds (the waiting side of the contract) |
||||
set tok [punkcheck::lock::acquire $pf -installer IMPATIENT -timeout 5000] |
||||
punkcheck::lock::release $tok |
||||
list errcaught $errcaught code_ok $code_ok names_holder [string match "*held by:*HOLDER-CHILD*" $errmsg] lock_cleared [expr {![file exists $pf.lock]}] |
||||
}\ |
||||
-cleanup { |
||||
file delete -force [dict get $ws root] |
||||
}\ |
||||
-result {errcaught 1 code_ok 1 names_holder 1 lock_cleared 1} |
||||
|
||||
# ========================================================================= |
||||
# --- stale-lock breaking: dead holder pid, and age --- |
||||
# ========================================================================= |
||||
|
||||
test concurrency_stale_break_dead_pid {planted lockfile from a provably-dead pid on this host is broken immediately with a warning}\ |
||||
-constraints {canexecchild haspidliveness}\ |
||||
-body { |
||||
set ws [make_workspace] |
||||
set root [dict get $ws root] |
||||
set pf [dict get $ws punkcheck_file] |
||||
#obtain a genuinely dead pid: a child that just printed its pid and exited |
||||
set pidscript [write_file [file join $root printpid.tcl] {puts [pid]}] |
||||
set deadpid [string trim [exec [info nameofexecutable] $pidscript]] |
||||
#plant a FRESH lockfile naming the dead pid - only liveness (not age) can explain a break |
||||
write_file $pf.lock [dict create pid $deadpid host [info hostname] installer GHOST tsiso [clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] ts [clock microseconds]] |
||||
set warnlog [file join $root warn.log] |
||||
set wchan [open $warnlog w] |
||||
set tok [punkcheck::lock::acquire $pf -installer BREAKER -timeout 3000 -warnchannel $wchan] |
||||
close $wchan |
||||
set warning [punk::mix::util::fcat $warnlog] |
||||
punkcheck::lock::release $tok |
||||
list acquired 1 warned_dead [string match "*no longer running*" $warning] names_ghost [string match "*GHOST*" $warning] lock_cleared [expr {![file exists $pf.lock]}] |
||||
}\ |
||||
-cleanup { |
||||
file delete -force [dict get $ws root] |
||||
}\ |
||||
-result {acquired 1 warned_dead 1 names_ghost 1 lock_cleared 1} |
||||
|
||||
test concurrency_stale_break_age {planted old lockfile from another host is broken on age with a warning}\ |
||||
-body { |
||||
set ws [make_workspace] |
||||
set root [dict get $ws root] |
||||
set pf [dict get $ws punkcheck_file] |
||||
#host mismatch keeps the liveness probe out of it - age alone must explain the break |
||||
write_file $pf.lock [dict create pid 99999999 host not-this-host-[pid] installer GHOST tsiso 2026-01-01T00:00:00 ts 0] |
||||
file mtime $pf.lock [expr {[clock seconds] - 3600}] |
||||
set warnlog [file join $root warn.log] |
||||
set wchan [open $warnlog w] |
||||
set tok [punkcheck::lock::acquire $pf -installer BREAKER -timeout 3000 -staleage 5 -warnchannel $wchan] |
||||
close $wchan |
||||
set warning [punk::mix::util::fcat $warnlog] |
||||
punkcheck::lock::release $tok |
||||
list acquired 1 warned_age [string match "*older than 5s*" $warning] lock_cleared [expr {![file exists $pf.lock]}] |
||||
}\ |
||||
-cleanup { |
||||
file delete -force [dict get $ws root] |
||||
}\ |
||||
-result {acquired 1 warned_age 1 lock_cleared 1} |
||||
|
||||
# ========================================================================= |
||||
# --- duplicate-INSTALLER sanity: clean error when stdin is non-interactive --- |
||||
# ========================================================================= |
||||
|
||||
test concurrency_dup_installer_noninteractive_error {duplicate INSTALLER records raise a clean actionable error in a non-interactive child (no prompt, no hang)}\ |
||||
-constraints canexecchild\ |
||||
-body { |
||||
set ws [make_workspace] |
||||
set root [dict get $ws root] |
||||
set pf [dict get $ws punkcheck_file] |
||||
#craft a .punkcheck with two INSTALLER records sharing one name |
||||
set r1 [punkcheck::recordlist::new_installer_record dupname] |
||||
set r2 [punkcheck::recordlist::new_installer_record dupname] |
||||
punkcheck::save_records_to_file [list $r1 $r2] $pf "test dup plant" |
||||
set probe [file join $root dupprobe.tcl] |
||||
set script [child_preamble] |
||||
append script { |
||||
lassign $argv pf |
||||
if {[catch {punkcheck::installtrack new dupname $pf} err]} { |
||||
puts "ERR: $err" |
||||
} else { |
||||
puts "NOERROR" |
||||
} |
||||
exit 0 |
||||
} |
||||
write_file $probe $script |
||||
#r+ pipe: the child's stdin is a pipe, so the non-interactive path must engage |
||||
set chan [open |[list [info nameofexecutable] $probe $pf] r+] |
||||
set outlines [list] |
||||
set deadline [expr {[clock milliseconds] + 30000}] |
||||
chan configure $chan -blocking 0 |
||||
while {![chan eof $chan]} { |
||||
if {[clock milliseconds] >= $deadline} { |
||||
catch {close $chan} |
||||
error "timeout: dup-installer child did not complete (prompt hang?)" |
||||
} |
||||
set line [gets $chan] |
||||
if {$line ne ""} { |
||||
lappend outlines $line |
||||
} |
||||
after 20 |
||||
} |
||||
catch {close $chan} |
||||
set out [join $outlines \n] |
||||
list errored [string match "ERR:*" $out] mentions_dup [string match "*multiple INSTALLER records*" $out] noninteractive [string match "*non-interactive*" $out] actionable [string match "*Recovery:*" $out] |
||||
}\ |
||||
-cleanup { |
||||
file delete -force [dict get $ws root] |
||||
}\ |
||||
-result {errored 1 mentions_dup 1 noninteractive 1 actionable 1} |
||||
|
||||
# ========================================================================= |
||||
# --- protocol siblings are excluded from install content --- |
||||
# ========================================================================= |
||||
|
||||
test concurrency_protocol_files_not_installed {a .punkcheck.lock in the source tree is not copied by punkcheck::install (default core exclusions)}\ |
||||
-body { |
||||
set ws [make_workspace] |
||||
write_file [file join [dict get $ws srcdir] keep.txt] "k" |
||||
write_file [file join [dict get $ws srcdir] .punkcheck.lock] "planted" |
||||
write_file [file join [dict get $ws srcdir] .punkcheck.tmp.1234] "planted" |
||||
punkcheck::install [dict get $ws srcdir] [dict get $ws tgtdir] -overwrite all-targets |
||||
list copied_lock [file exists [file join [dict get $ws tgtdir] .punkcheck.lock.copiedcheck]] lock_at_tgt [file exists [file join [dict get $ws tgtdir] .punkcheck.lock]] tmp_at_tgt [file exists [file join [dict get $ws tgtdir] .punkcheck.tmp.1234]] keep_at_tgt [file exists [file join [dict get $ws tgtdir] keep.txt]] |
||||
}\ |
||||
-cleanup { |
||||
file delete -force [dict get $ws root] |
||||
}\ |
||||
-result {copied_lock 0 lock_at_tgt 0 tmp_at_tgt 0 keep_at_tgt 1} |
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary line. |
||||
Loading…
Reference in new issue