Browse Source
Tar-era connection API removed from modpod (connect/disconnect/get, system::connect_if_not/myname/myfullname - broken since the tarjar era, no callers anywhere); is_valid_tm_version fixed (versionparts substitution error); make_mountable_zip debug output removed (the undeclared ansistring dependency made -offsettype file error under the module's declared deps; stray ::last_header global gone); struct::set dependency dropped; module greps tarjar-free. The load stub gains the unwrapped #modpod-<pkg>-<ver> redirect: an extracted folder beside the .tm is sourced directly - loads with neither zipfs nor vfs::zip available. Re-vendored 0.1.6 through the established channels (modpod checkout mint -> vendormodules -> bootsupport -> modules staging -> vfscommon). First modpod testsuite at src/tests/modules/modpod/testsuites/modpod/roundtrip.test: wrap/load round-trips - real-disk + zipfs module paths, both -offsettype forms, unwrapped redirect, probe-discovered binary payload (no committed binaries). Green: punk91 tcl9.1 kit 7/7, native tclsh90 7/7, punk86 8.6.17 6/7 (zipfs-container test skips on 8.6 - recorded per G-034). G-111 activated at user request (activation overlap survey recorded); per-defect dispositions, run evidence and tarjar-artifact assessment proposals in goals/G-111-modpod-tidy-tests.md - artifact dispositions await user confirmation. GOALS.md G-111 Scope version reference repaired to glob form per goals-system v3 drift rule. Claude-Session: https://claude.ai/code/session_0156PuejSCGjgeGb7jiABrDU Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
9 changed files with 586 additions and 875 deletions
@ -0,0 +1,279 @@
|
||||
# modpod wrap/load round-trip baseline (G-111) |
||||
# Pins the surviving zip-based modpod surface characterized 2026-07-21 (G-066 Notes): |
||||
# - modpod::lib::make_zip_modpod wrap, then package require of the wrapped .tm |
||||
# from a real-disk module path (stub self-mounts via zipfs, or vfs::zip fallback on 8.6) |
||||
# - the unwrapped #modpod-<pkg>-<ver> redirect form (extracted folder beside the .tm wins, no mount) |
||||
# - both -offsettype forms (archive | file) |
||||
# - a binary (shared lib) payload loading from the mounted pod |
||||
# - the .tm itself residing on a zipfs module path (zip-in-zip, tcl9+) |
||||
# Fixture pods are generated per run (no committed binaries); the binary payload is a |
||||
# dll discovered by a child-process probe (packages not already loaded in a bare child). |
||||
package require tcltest |
||||
namespace import ::tcltest::* |
||||
|
||||
package require punk::zip |
||||
package require modpod 0.1.6- |
||||
|
||||
#added 2026-08-03 (agent, G-111) - first modpod test baseline (all tests in this file) |
||||
|
||||
namespace eval ::modpodtest { |
||||
variable workdir [tcltest::makeDirectory modpodwork] |
||||
variable suitedir [file dirname [file normalize [info script]]] |
||||
variable projroot [file normalize [file join $suitedir .. .. .. .. .. ..]] |
||||
variable childcmd {} |
||||
variable bincand {} |
||||
|
||||
proc writefile {path content} { |
||||
set fd [open $path w] |
||||
fconfigure $fd -translation lf |
||||
puts -nonewline $fd $content |
||||
close $fd |
||||
} |
||||
|
||||
#make a #modpod-<pkg>-<ver> source stage with a data file, zip it, wrap it into |
||||
#<workdir>/modules_<pkg>/<pkg>-<ver>.tm and return that module dir |
||||
proc make_pod {pkg ver data offsettype} { |
||||
variable workdir |
||||
set stage [file join $workdir stage_$pkg] |
||||
set poddir [file join $stage #modpod-$pkg-$ver] |
||||
file mkdir $poddir |
||||
writefile [file join $poddir $pkg-$ver.tm] [string map [list %PKG% $pkg %VER% $ver] {package provide %PKG% %VER% |
||||
namespace eval %PKG% { |
||||
variable datafile [file join [file dirname [info script]] data.txt] |
||||
variable loadedfrom [info script] |
||||
proc read_data {} {variable datafile |
||||
set fd [open $datafile r] |
||||
set d [read $fd] |
||||
close $fd |
||||
return [string trim $d] |
||||
} |
||||
proc loadedfrom {} {variable loadedfrom |
||||
return $loadedfrom |
||||
} |
||||
} |
||||
}] |
||||
writefile [file join $poddir data.txt] $data\n |
||||
set moduledir [file join $workdir modules_$pkg] |
||||
file mkdir $moduledir |
||||
set zipfile [file join $workdir $pkg.zip] |
||||
punk::zip::mkzip -base $stage -directory $poddir -- $zipfile * |
||||
modpod::lib::make_zip_modpod -offsettype $offsettype $zipfile [file join $moduledir $pkg-$ver.tm] |
||||
return $moduledir |
||||
} |
||||
|
||||
proc run_child {args} { |
||||
variable childcmd |
||||
exec {*}$childcmd {*}$args 2>@1 |
||||
} |
||||
|
||||
proc lastline {out} { |
||||
lindex [split [string trim $out] \n] end |
||||
} |
||||
} |
||||
|
||||
# --- child helper scripts --------------------------------------------------- |
||||
::modpodtest::writefile [file join $::modpodtest::workdir probe_exec.tcl] {puts PROBE-OK |
||||
exit 0 |
||||
} |
||||
|
||||
#generic pod-require child: argv = moduledir pkgname |
||||
::modpodtest::writefile [file join $::modpodtest::workdir childreq.tcl] {lassign $argv moduledir pkgname |
||||
::tcl::tm::path add $moduledir |
||||
if {[catch {package require $pkgname} err]} { |
||||
puts [list REQ-ERR $err] |
||||
exit 2 |
||||
} |
||||
puts [list REQ-OK version [package present $pkgname] data [${pkgname}::read_data] from [${pkgname}::loadedfrom]] |
||||
exit 0 |
||||
} |
||||
|
||||
#zipfs-module-path child: argv = containerzip pkgname (tcl9+: tm lives on a zipfs path) |
||||
::modpodtest::writefile [file join $::modpodtest::workdir zipfsreq.tcl] {lassign $argv containerzip pkgname |
||||
if {[info commands ::tcl::zipfs::mount] eq ""} { |
||||
puts [list REQ-ERR nozipfs] |
||||
exit 2 |
||||
} |
||||
tcl::zipfs::mount $containerzip modpodtestcontainer |
||||
::tcl::tm::path add //zipfs:/modpodtestcontainer/modules |
||||
if {[catch {package require $pkgname} err]} { |
||||
puts [list REQ-ERR $err] |
||||
exit 2 |
||||
} |
||||
puts [list REQ-OK version [package present $pkgname] data [${pkgname}::read_data] from [${pkgname}::loadedfrom]] |
||||
exit 0 |
||||
} |
||||
|
||||
#binary-candidate probe child: argv = libtree ?libtree...? (find a dll-backed package |
||||
#NOT loaded in a bare child of this executable - avoids same-prefix double-load) |
||||
::modpodtest::writefile [file join $::modpodtest::workdir binprobe.tcl] {foreach libtree $argv { |
||||
if {[file isdirectory $libtree]} {lappend ::auto_path $libtree} |
||||
} |
||||
set before [info loaded] |
||||
foreach cand {udp tclcsv tdom Memchan trofs} { |
||||
if {[catch {package require $cand}]} {continue} |
||||
foreach pair [info loaded] { |
||||
if {$pair in $before} {continue} |
||||
lassign $pair f p |
||||
if {$f ne "" && [file exists $f] && [string tolower [file extension $f]] eq [string tolower [info sharedlibextension]]} { |
||||
puts [list CAND $cand $f $p] |
||||
exit 0 |
||||
} |
||||
} |
||||
} |
||||
puts NOCAND |
||||
exit 0 |
||||
} |
||||
|
||||
#binary-pod assert child: argv = moduledir |
||||
::modpodtest::writefile [file join $::modpodtest::workdir binassert.tcl] {lassign $argv moduledir |
||||
set before [info loaded] |
||||
::tcl::tm::path add $moduledir |
||||
if {[catch {package require binpod} err]} { |
||||
puts [list BIN-ERR $err] |
||||
exit 2 |
||||
} |
||||
set newloads 0 |
||||
foreach pair [info loaded] { |
||||
if {$pair ni $before} {incr newloads} |
||||
} |
||||
set podpath 0 |
||||
foreach pair [info loaded] { |
||||
lassign $pair f p |
||||
if {[string match "*#mounted-modpod-binpod*" $f]} {set podpath 1} |
||||
} |
||||
puts [list BIN-OK version [package present binpod] newloads $newloads podpath $podpath] |
||||
exit 0 |
||||
} |
||||
|
||||
# --- constraints ------------------------------------------------------------ |
||||
#child spawn capability: kits dispatch subcommands (use their 'script' subcommand); |
||||
#a native tclsh takes the script file directly. Probe script-form first - a native |
||||
#tclsh fails it fast (no file named 'script'), whereas probing the plain form first |
||||
#could start an interactive kit shell. |
||||
apply {{} { |
||||
set probefile [file join $::modpodtest::workdir probe_exec.tcl] |
||||
set exe [info nameofexecutable] |
||||
if {![catch {exec $exe script $probefile 2>@1} out] && [string match *PROBE-OK* $out]} { |
||||
set ::modpodtest::childcmd [list $exe script] |
||||
} elseif {![catch {exec $exe $probefile 2>@1} out] && [string match *PROBE-OK* $out]} { |
||||
set ::modpodtest::childcmd [list $exe] |
||||
} |
||||
}} |
||||
testConstraint childexec [expr {[llength $::modpodtest::childcmd] > 0}] |
||||
testConstraint childzipfs [expr {[testConstraint childexec] && [info commands ::tcl::zipfs::mount] ne ""}] |
||||
|
||||
#binary payload candidate (probe child; repo lib trees offered as extra auto_path) |
||||
apply {{} { |
||||
if {![testConstraint childexec]} {return} |
||||
set libtrees {} |
||||
set major [lindex [split [info tclversion] .] 0] |
||||
if {[file exists [file join $::modpodtest::projroot punkproject.toml]]} { |
||||
set libtrees [glob -nocomplain -directory [file join $::modpodtest::projroot lib_tcl$major] -type d *] |
||||
} |
||||
if {[catch {::modpodtest::run_child [file join $::modpodtest::workdir binprobe.tcl] {*}$libtrees} out]} {return} |
||||
set line [::modpodtest::lastline $out] |
||||
if {[string match "CAND *" $line]} { |
||||
set ::modpodtest::bincand [lrange $line 1 end] |
||||
} |
||||
}} |
||||
testConstraint binarycand [expr {[llength $::modpodtest::bincand] > 0}] |
||||
|
||||
# --- fixtures --------------------------------------------------------------- |
||||
set ::modpodtest::mod_arch [::modpodtest::make_pod podarch 0.1 DATA-ARCH archive] |
||||
set ::modpodtest::mod_file [::modpodtest::make_pod podfile 0.1 DATA-FILE file] |
||||
set ::modpodtest::mod_redir [::modpodtest::make_pod podredir 0.2 DATA-REDIR archive] |
||||
#redirect form: manually "unzip in place" - the wrapped .tm is itself a valid |
||||
#prefix-attached zip, so extract it beside itself (punk::zip reads both offset shapes) |
||||
punk::zip::unzip [file join $::modpodtest::mod_redir podredir-0.2.tm] $::modpodtest::mod_redir |
||||
|
||||
# --- tests ------------------------------------------------------------------ |
||||
|
||||
test modpod-1.1 {make_zip_modpod emits stub-prefixed zip .tm (archive offsets)} -body { |
||||
set tmfile [file join $::modpodtest::mod_arch podarch-0.1.tm] |
||||
set fd [open $tmfile r] |
||||
fconfigure $fd -encoding iso8859-1 -translation binary |
||||
set head [read $fd 8192] |
||||
close $fd |
||||
set result {} |
||||
lappend result [file exists $tmfile] |
||||
lappend result [expr {[string first "modpod::lib::make_zip_modpod" $head] >= 0}] ;#stub marker comment |
||||
lappend result [expr {[string first \x1A $head] > 0}] ;#stub/zip separator |
||||
lappend result [expr {[string first "PK\x03\x04" $head] > 0}] ;#zip local header after stub |
||||
} -result {1 1 1 1} |
||||
|
||||
test modpod-1.2 {is_valid_tm_version accepts vcompare-valid, rejects invalid} -body { |
||||
list [modpod::lib::is_valid_tm_version 1.2.3] \ |
||||
[modpod::lib::is_valid_tm_version 0.1a2] \ |
||||
[modpod::lib::is_valid_tm_version 1..2] \ |
||||
[modpod::lib::is_valid_tm_version notaversion] |
||||
} -result {1 1 0 0} |
||||
|
||||
test modpod-2.1 {require wrapped pod from real-disk module path (archive offsets)} -constraints childexec -body { |
||||
set out [::modpodtest::run_child [file join $::modpodtest::workdir childreq.tcl] $::modpodtest::mod_arch podarch] |
||||
set line [::modpodtest::lastline $out] |
||||
lassign $line tag _v version _d data _f from |
||||
if {$tag ne "REQ-OK"} {return $line} |
||||
list $tag $version $data [expr {$from ne ""}] [string match "*#mounted-modpod-podarch*" $from] |
||||
} -result {REQ-OK 0.1 DATA-ARCH 1 1} |
||||
|
||||
test modpod-2.2 {require wrapped pod built with -offsettype file} -constraints childexec -body { |
||||
set out [::modpodtest::run_child [file join $::modpodtest::workdir childreq.tcl] $::modpodtest::mod_file podfile] |
||||
set line [::modpodtest::lastline $out] |
||||
lassign $line tag _v version _d data _f from |
||||
if {$tag ne "REQ-OK"} {return $line} |
||||
list $tag $version $data [string match "*#mounted-modpod-podfile*" $from] |
||||
} -result {REQ-OK 0.1 DATA-FILE 1} |
||||
|
||||
test modpod-2.3 {unwrapped #modpod-folder redirect form wins over mounting} -constraints childexec -body { |
||||
set out [::modpodtest::run_child [file join $::modpodtest::workdir childreq.tcl] $::modpodtest::mod_redir podredir] |
||||
set line [::modpodtest::lastline $out] |
||||
lassign $line tag _v version _d data _f from |
||||
if {$tag ne "REQ-OK"} {return $line} |
||||
set expected [file join $::modpodtest::mod_redir #modpod-podredir-0.2 podredir-0.2.tm] |
||||
set fromdisk [string equal [string tolower [file normalize $from]] [string tolower [file normalize $expected]]] |
||||
list $tag $version $data $fromdisk [string match "*#mounted-modpod-*" $from] |
||||
} -result {REQ-OK 0.2 DATA-REDIR 1 0} |
||||
|
||||
test modpod-3.1 {binary payload (probed dll) loads from mounted pod in fresh child} -constraints {childexec binarycand} -body { |
||||
lassign $::modpodtest::bincand candpkg canddll candprefix |
||||
#stage a pod carrying the dll; inner tm loads it relative to [info script] |
||||
set stage [file join $::modpodtest::workdir stage_binpod] |
||||
set poddir [file join $stage #modpod-binpod-0.1] |
||||
file mkdir $poddir |
||||
set dlltail [file tail $canddll] |
||||
file copy -force $canddll [file join $poddir $dlltail] |
||||
::modpodtest::writefile [file join $poddir binpod-0.1.tm] [string map [list %DLL% $dlltail %PREFIX% $candprefix] {load [file join [file dirname [info script]] %DLL%] %PREFIX% |
||||
package provide binpod 0.1 |
||||
}] |
||||
set moduledir [file join $::modpodtest::workdir modules_binpod] |
||||
file mkdir $moduledir |
||||
set zipfile [file join $::modpodtest::workdir binpod.zip] |
||||
punk::zip::mkzip -base $stage -directory $poddir -- $zipfile * |
||||
modpod::lib::make_zip_modpod $zipfile [file join $moduledir binpod-0.1.tm] |
||||
|
||||
set out [::modpodtest::run_child [file join $::modpodtest::workdir binassert.tcl] $moduledir] |
||||
set line [::modpodtest::lastline $out] |
||||
lassign $line tag _v version _n newloads _p podpath |
||||
if {$tag ne "BIN-OK"} {return $line} |
||||
#zipfs runtimes report the pod-mounted path in [info loaded]; non-zipfs (vfs::zip) |
||||
#fallback evidence is the load registering at all in the fresh child |
||||
set via_pod [expr {$podpath == 1 || (![testConstraint childzipfs] && $newloads >= 1)}] |
||||
list $tag $version [expr {$newloads >= 1}] $via_pod |
||||
} -result {BIN-OK 0.1 1 1} |
||||
|
||||
test modpod-4.1 {require wrapped pod from zipfs module path (tm inside a zip container)} -constraints {childexec childzipfs} -body { |
||||
#container zip holds modules/podzip-0.1.tm (a wrapped pod) - zip-in-zip load |
||||
set contmod [::modpodtest::make_pod podzip 0.1 DATA-ZIPFS archive] |
||||
set contstage [file join $::modpodtest::workdir container] |
||||
file mkdir [file join $contstage modules] |
||||
file copy -force [file join $contmod podzip-0.1.tm] [file join $contstage modules podzip-0.1.tm] |
||||
set containerzip [file join $::modpodtest::workdir container.zip] |
||||
punk::zip::mkzip -base $contstage -directory $contstage -- $containerzip * |
||||
set out [::modpodtest::run_child [file join $::modpodtest::workdir zipfsreq.tcl] $containerzip podzip] |
||||
set line [::modpodtest::lastline $out] |
||||
lassign $line tag _v version _d data _f from |
||||
if {$tag ne "REQ-OK"} {return $line} |
||||
list $tag $version $data [string match "//zipfs:/*" $from] |
||||
} -result {REQ-OK 0.1 DATA-ZIPFS 1} |
||||
|
||||
tcltest::cleanupTests |
||||
Loading…
Reference in new issue