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