You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
431 lines
22 KiB
431 lines
22 KiB
# -*- tcl -*- |
|
# Characterization tests for punk::libunknown module discovery semantics and |
|
# the epoch-based scan cache ('package epoch' machinery installed by |
|
# punk::libunknown::init). |
|
# |
|
# Behaviours pinned here (verified experimentally 2026-07-11 on Tcl 9.0.3): |
|
# 1. The tm unknown handler registers ifneeded scripts for ALL sibling .tm |
|
# files in a scanned directory - but only at the namespace depth of the |
|
# requested package. Modules in deeper (never-requested) subfolders stay |
|
# absent from 'package names'. This laziness is deliberate (minimal scan |
|
# cost in new interps/threads/subshells); punk::libunknown::register_all_tm |
|
# provides the explicit deep discovery pass (used by 'dev lib.search' by |
|
# default - see src/tests/modules/punk/mix/testsuites/loadedlib/libsearch.test). |
|
# 2. Within one epoch, directories already indexed are not re-globbed: a .tm |
|
# file added on disk to an already-scanned directory is invisible to |
|
# 'package require' until 'package epoch incr'. |
|
# 3. Traces on ::tcl::tm::paths and ::auto_path increment the tm/pkg epoch |
|
# automatically - no manual invalidation needed for path-list changes. |
|
# |
|
# Run: tclsh src/tests/runtests.tcl -report compact -show-passes 0 -include-paths modules/punk/libunknown/** discovery.test |
|
|
|
package require tcltest |
|
package require punk::lib |
|
|
|
namespace eval ::testspace { |
|
namespace import ::tcltest::* |
|
|
|
# ------------------------------------------------------------------------- |
|
# Fixture: a tm tree with distinctively named modules at three namespace |
|
# depths, plus a separate mutation dir for the epoch-cache tests. |
|
# fix/pklu_top-1.0.tm (pklu_top) |
|
# fix/pklu_sib-1.0.tm (pklu_sib) |
|
# fix/pkluns/leafmod-1.0.tm (pkluns::leafmod) |
|
# fix/pkluns/leafsib-1.0.tm (pkluns::leafsib) |
|
# fix/pkluns/subns/verydeep-1.0.tm (pkluns::subns::verydeep) |
|
# mut/pklu_mtop-1.0.tm (pklu_mtop) |
|
# mut2/pklu_m2top-1.0.tm (pklu_m2top - register_all_tm mutation tests) |
|
# sdirA/pklu_shadow-1.0.tm (impl A - register_all_tm precedence pin) |
|
# sdirB/pklu_shadow-1.0.tm (impl B - register_all_tm precedence pin) |
|
# epochextra/ (empty - target for tm::add) |
|
# libbase/ (auto_path fixture - pkgIndex.tcl contract) |
|
# pklu_pkgidx/pkgIndex.tcl + pklu_pkgidx.tcl ($dir-based ifneeded/source) |
|
# pklu_extender/pkgIndex.tcl (unqualified 'lappend auto_path' |
|
# tcllib pattern + stray unqualified |
|
# 'set pklu_leak_probe' that must NOT |
|
# reach the global namespace) |
|
# pklu_extender/sublib/pklu_ext/pkgIndex.tcl + pklu_ext.tcl |
|
# ------------------------------------------------------------------------- |
|
variable fixture_error "" |
|
variable fixdir "" |
|
variable mutdir "" |
|
variable mut2dir "" |
|
variable sdirA "" |
|
variable sdirB "" |
|
variable epochextra "" |
|
variable libbase "" |
|
try { |
|
set base [punk::lib::tempdir_newfolder -prefix pkludiscovery] |
|
set fixdir [file join $base fix] |
|
set mutdir [file join $base mut] |
|
set mut2dir [file join $base mut2] |
|
set sdirA [file join $base sdirA] |
|
set sdirB [file join $base sdirB] |
|
set epochextra [file join $base epochextra] |
|
set libbase [file join $base libbase] |
|
file mkdir [file join $fixdir pkluns subns] $mutdir $mut2dir $sdirA $sdirB $epochextra\ |
|
[file join $libbase pklu_pkgidx]\ |
|
[file join $libbase pklu_nsindex]\ |
|
[file join $libbase pklu_extender sublib pklu_ext] |
|
foreach {relpath content} { |
|
{pklu_top-1.0.tm} {package provide pklu_top 1.0} |
|
{pklu_sib-1.0.tm} {package provide pklu_sib 1.0} |
|
{pkluns/leafmod-1.0.tm} {package provide pkluns::leafmod 1.0} |
|
{pkluns/leafsib-1.0.tm} {package provide pkluns::leafsib 1.0} |
|
{pkluns/subns/verydeep-1.0.tm} {package provide pkluns::subns::verydeep 1.0} |
|
} { |
|
set fd [open [file join $fixdir {*}[file split $relpath]] w] |
|
puts $fd $content |
|
close $fd |
|
} |
|
set fd [open [file join $mutdir pklu_mtop-1.0.tm] w] |
|
puts $fd {package provide pklu_mtop 1.0} |
|
close $fd |
|
set fd [open [file join $mut2dir pklu_m2top-1.0.tm] w] |
|
puts $fd {package provide pklu_m2top 1.0} |
|
close $fd |
|
set fd [open [file join $sdirA pklu_shadow-1.0.tm] w] |
|
puts $fd {package provide pklu_shadow 1.0; proc ::pklu_shadow_whoami {} {return A}} |
|
close $fd |
|
set fd [open [file join $sdirB pklu_shadow-1.0.tm] w] |
|
puts $fd {package provide pklu_shadow 1.0; proc ::pklu_shadow_whoami {} {return B}} |
|
close $fd |
|
#auto_path/pkgIndex fixture - content braced so $dir stays literal |
|
foreach {relpath content} { |
|
{pklu_pkgidx/pkgIndex.tcl} |
|
{package ifneeded pklu_pkgidx 1.0 [list source [file join $dir pklu_pkgidx.tcl]]} |
|
{pklu_pkgidx/pklu_pkgidx.tcl} |
|
{package provide pklu_pkgidx 1.0} |
|
{pklu_nsindex/pkgIndex.tcl} |
|
{namespace eval pklu_nsindex { |
|
variable scriptdir |
|
proc set_scriptdir dir {variable scriptdir ; set scriptdir $dir} |
|
} |
|
package ifneeded pklu_nsindex 1.0 [subst { |
|
pklu_nsindex::set_scriptdir [list $dir] |
|
source [list [file join $dir pklu_nsindex.tcl]] |
|
}]} |
|
{pklu_nsindex/pklu_nsindex.tcl} |
|
{package provide pklu_nsindex 1.0} |
|
{pklu_extender/pkgIndex.tcl} |
|
{lappend auto_path [file join $dir sublib] |
|
set pklu_leak_probe leaked_value} |
|
{pklu_extender/sublib/pklu_ext/pkgIndex.tcl} |
|
{package ifneeded pklu_ext 1.0 [list source [file join $dir pklu_ext.tcl]]} |
|
{pklu_extender/sublib/pklu_ext/pklu_ext.tcl} |
|
{package provide pklu_ext 1.0} |
|
} { |
|
set fd [open [file join $libbase {*}[file split $relpath]] w] |
|
puts $fd $content |
|
close $fd |
|
} |
|
variable tempbase $base |
|
} on error {result} { |
|
set fixture_error $result |
|
} |
|
testConstraint discoveryfixture [expr {$fixture_error eq ""}] |
|
if {$fixture_error ne ""} { |
|
puts stderr "discovery.test fixture setup failed (tests will be skipped): $fixture_error" |
|
} |
|
|
|
#The SOURCE-TREE punk::libunknown, located relative to this test file. |
|
#A 'package require punk::libunknown' could resolve to another copy (e.g |
|
#bootsupport) depending on tm path order - in the testinterp that order |
|
#deliberately favours bootsupport, and in a child interp it depends on |
|
#machine-specific env tm paths. These tests must exercise the source copy, |
|
#so it is sourced directly by path (as punk_main.tcl loads it), picking the |
|
#highest version by vcompare should multiple libunknown-*.tm coexist. |
|
variable libunknown_src "" |
|
variable script_dir [file dirname [file normalize [info script]]] |
|
set srcmodules [file normalize [file join $script_dir .. .. .. .. .. .. modules]] |
|
foreach candidate [glob -nocomplain [file join $srcmodules punk libunknown-*.tm]] { |
|
set thisver [file rootname [lindex [split [file tail $candidate] -] 1]] |
|
if {$libunknown_src eq "" || [package vcompare $thisver $libunknown_ver] == 1} { |
|
set libunknown_src $candidate |
|
set libunknown_ver $thisver |
|
} |
|
} |
|
#libunknown 0.3.0 installs its ::package override via commandstack (G-176) - |
|
#init requires it, and the children's tm paths are cleared, so the source-tree |
|
#commandstack is sourced by path first (same highest-version rule) |
|
variable commandstack_src "" |
|
foreach candidate [glob -nocomplain [file join $srcmodules commandstack-*.tm]] { |
|
set thisver [file rootname [lindex [split [file tail $candidate] -] 1]] |
|
if {$commandstack_src eq "" || [package vcompare $thisver $commandstack_ver] == 1} { |
|
set commandstack_src $candidate |
|
set commandstack_ver $thisver |
|
} |
|
} |
|
testConstraint libunknownavailable [expr {$libunknown_src ne "" && $commandstack_src ne ""}] |
|
if {$libunknown_src eq "" || $commandstack_src eq ""} { |
|
puts stderr "discovery.test: cannot locate src/modules/punk/libunknown-*.tm and/or src/modules/commandstack-*.tm relative to [info script] (tests will be skipped)" |
|
} |
|
|
|
# ------------------------------------------------------------------------- |
|
# Probe: fresh child interp with the source-tree commandstack + punk::libunknown |
|
# active and tm paths set to exactly $tmdirs. Returns the script's result; |
|
# child deleted after. |
|
# ------------------------------------------------------------------------- |
|
proc libu_probe {tmdirs script} { |
|
variable libunknown_src |
|
variable commandstack_src |
|
set i [interp create] |
|
try { |
|
interp eval $i {package prefer latest} |
|
interp eval $i {tcl::tm::remove {*}[tcl::tm::list]} |
|
interp eval $i [list source $commandstack_src] |
|
interp eval $i [list source $libunknown_src] |
|
interp eval $i {punk::libunknown::init} |
|
interp eval $i [list tcl::tm::add {*}$tmdirs] |
|
interp eval $i $script |
|
} finally { |
|
interp delete $i |
|
} |
|
} |
|
|
|
#added 2026-07-11 (agent) - coverage prep for lib.search deep-discovery work (punk::mix::commandset::loadedlib) |
|
|
|
# -- handler installation --------------------------------------------------- |
|
|
|
test libunknown_init_installs_handlers {init sets package unknown to the two-handler libunknown chain}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
libu_probe [list $fixdir] {package unknown} |
|
} -result {::punk::libunknown::zipfs_tm_UnknownHandler ::punk::libunknown::zipfs_tclPkgUnknown} |
|
|
|
# -- sibling registration / lazy depth ---------------------------------------- |
|
|
|
test discovery_sibling_same_depth {requiring one module registers sibling .tm files at the same depth}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
libu_probe [list $fixdir] { |
|
package require pklu_top |
|
list [expr {"pklu_sib" in [package names]}] [package require pklu_sib] |
|
} |
|
} -result {1 1.0} |
|
|
|
test discovery_lazy_depth {deeper unrequested modules stay unregistered after a top-level scan}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
libu_probe [list $fixdir] { |
|
package require pklu_top |
|
list [expr {"pkluns::leafmod" in [package names]}]\ |
|
[expr {"pkluns::subns::verydeep" in [package names]}] |
|
} |
|
} -result {0 0} |
|
|
|
test discovery_deep_registers_requested_depth_only {requiring a deep module registers its siblings but not deeper levels}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
libu_probe [list $fixdir] { |
|
package require pkluns::leafmod |
|
list [package provide pkluns::leafmod]\ |
|
[expr {"pkluns::leafsib" in [package names]}]\ |
|
[expr {"pkluns::subns::verydeep" in [package names]}] |
|
} |
|
} -result {1.0 1 0} |
|
|
|
# -- 'package epoch' machinery ------------------------------------------------ |
|
|
|
test epoch_command_shape {package epoch returns a dict with integer tm and pkg epoch counters}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
libu_probe [list $fixdir] { |
|
set e [package epoch] |
|
list [dict exists $e tm] [dict exists $e pkg]\ |
|
[string is integer -strict [dict get $e tm]]\ |
|
[string is integer -strict [dict get $e pkg]] |
|
} |
|
} -result {1 1 1 1} |
|
|
|
test epoch_incr_on_tm_paths_change {tcl::tm::add increments the tm epoch via the paths trace}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
variable epochextra |
|
libu_probe [list $fixdir] [string map [list %DIR% [list $epochextra]] { |
|
set before [dict get [package epoch] tm] |
|
tcl::tm::add %DIR% |
|
expr {[dict get [package epoch] tm] > $before} |
|
}] |
|
} -result 1 |
|
|
|
test epoch_incr_on_auto_path_change {writing ::auto_path increments the pkg epoch via the variable trace}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
variable epochextra |
|
libu_probe [list $fixdir] [string map [list %DIR% [list $epochextra]] { |
|
set before [dict get [package epoch] pkg] |
|
lappend ::auto_path %DIR% |
|
expr {[dict get [package epoch] pkg] > $before} |
|
}] |
|
} -result 1 |
|
|
|
test epoch_incr_subcommand {package epoch incr increments both tm and pkg epochs}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
libu_probe [list $fixdir] { |
|
set before [package epoch] |
|
package epoch incr |
|
set after [package epoch] |
|
list [expr {[dict get $after tm] > [dict get $before tm]}]\ |
|
[expr {[dict get $after pkg] > [dict get $before pkg]}] |
|
} |
|
} -result {1 1} |
|
|
|
test epoch_cache_blocks_new_tm_until_incr {a .tm added to an already-scanned dir is invisible until package epoch incr}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable mutdir |
|
#the target path is string-mapped in as a literal: a child-global 'dir' |
|
#variable would be clobbered by the package unknown chain (see |
|
#libunknown_GAP_pkgunknown_clobbers_global_dir) |
|
libu_probe [list $mutdir] [string map [list %MUT% [list $mutdir]] { |
|
#scan the dir within the current epoch |
|
package require pklu_mtop |
|
#new module appears on disk after the scan |
|
set ::t_fd [open [file join %MUT% pklu_newsib-1.0.tm] w] |
|
puts $::t_fd {package provide pklu_newsib 1.0} |
|
close $::t_fd |
|
set ::t_result [list] |
|
#same epoch: the cached index short-circuits the re-glob |
|
lappend ::t_result [catch {package require pklu_newsib}] |
|
#the documented recipe: epoch incr drops non-static indexes -> rescan |
|
package epoch incr |
|
lappend ::t_result [package require pklu_newsib] |
|
}] |
|
} -result {1 1.0} |
|
|
|
# -- register_all_tm (deep discovery) ------------------------------------------- |
|
|
|
#added 2026-07-11 (agent) - punk::libunknown::register_all_tm, the deep-discovery |
|
#pass 'dev lib.search' uses by default (loadedlib 0.2.0) |
|
test register_all_tm_all_depths {register_all_tm registers .tm modules at every namespace depth in one pass}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
libu_probe [list $fixdir] { |
|
punk::libunknown::register_all_tm |
|
list [expr {"pklu_top" in [package names]}]\ |
|
[expr {"pkluns::leafmod" in [package names]}]\ |
|
[expr {"pkluns::subns::verydeep" in [package names]}]\ |
|
[package require pkluns::subns::verydeep] |
|
} |
|
} -result {1 1 1 1.0} |
|
|
|
test register_all_tm_cached_per_epoch {repeat call is a per-epoch no-op; package epoch incr re-enables a filesystem scan}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable mut2dir |
|
libu_probe [list $mut2dir] [string map [list %MUT% [list $mut2dir]] { |
|
punk::libunknown::register_all_tm |
|
#new module appears on disk after the scan |
|
set ::t_fd [open [file join %MUT% pklu_m2new-1.0.tm] w] |
|
puts $::t_fd {package provide pklu_m2new 1.0} |
|
close $::t_fd |
|
set ::t_result [list] |
|
#second call in the same epoch: cached no-op - new file not seen |
|
lappend ::t_result [dict exists [punk::libunknown::register_all_tm] cached] |
|
lappend ::t_result [expr {"pklu_m2new" in [package names]}] |
|
#new epoch: scan re-reads the filesystem |
|
package epoch incr |
|
punk::libunknown::register_all_tm |
|
lappend ::t_result [expr {"pklu_m2new" in [package names]}] |
|
}] |
|
} -result {1 0 1} |
|
|
|
test register_all_tm_headwins_parity {same name-version in two tm dirs: head of tm list wins (parity with the unknown handler)}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable sdirA |
|
variable sdirB |
|
#tcl::tm::add prepends: the LAST dir passed ends up at the head of the |
|
#tm list and must win the same-version tie (see shadowing.test pins) |
|
set r1 [libu_probe [list $sdirA $sdirB] { |
|
punk::libunknown::register_all_tm |
|
package require pklu_shadow |
|
pklu_shadow_whoami |
|
}] |
|
set r2 [libu_probe [list $sdirB $sdirA] { |
|
punk::libunknown::register_all_tm |
|
package require pklu_shadow |
|
pklu_shadow_whoami |
|
}] |
|
list $r1 $r2 |
|
} -result {B A} |
|
|
|
# -- pkgIndex.tcl sourcing scope (source_pkgindex) -------------------------------- |
|
|
|
#fixed 2026-07-11 (agent): was libunknown_GAP_pkgunknown_clobbers_global_dir |
|
#(-result 0). zipfs_tclPkgUnknown previously declared 'global dir' and sourced |
|
#pkgIndex.tcl scripts at :: scope - clobbering any user global named 'dir' and |
|
#leaking each index's helper variables into the global namespace. Index scripts |
|
#now execute in a source_pkgindex frame ($dir local, auto_path/env global links) |
|
#matching stock tclPkgUnknown's documented contract without stock's exposure of |
|
#its own proc locals. |
|
test libunknown_pkgunknown_preserves_global_dir {a global 'dir' variable survives a package unknown fallthrough}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
libu_probe [list $fixdir] { |
|
set ::dir preserved_value |
|
catch {package require pklu_nonexistent_zzz} |
|
expr {$::dir eq "preserved_value"} |
|
} |
|
} -result 1 |
|
|
|
#added 2026-07-11 (agent) - pkgIndex.tcl contract under source_pkgindex |
|
test pkgindex_dir_and_isolation {pkgIndex.tcl sees $dir; its stray unqualified sets don't leak to ::}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
variable libbase |
|
libu_probe [list $fixdir] [string map [list %LIBBASE% [list $libbase]] { |
|
set ::auto_path [list %LIBBASE%] |
|
set ::t_result [list] |
|
#the ifneeded script and its source path are built from $dir by the index |
|
lappend ::t_result [package require pklu_pkgidx] |
|
#pklu_extender/pkgIndex.tcl was swept in the same pass - its unqualified |
|
#'set pklu_leak_probe' must have stayed local to the sourcing frame |
|
lappend ::t_result [info exists ::pklu_leak_probe] |
|
}] |
|
} -result {1.0 0} |
|
|
|
#added 2026-07-27 (agent) - punk::libunknown 0.2.3 regression pin. 0.2.0 moved index |
|
#sourcing into a proc of the punk::libunknown namespace, so an index's RELATIVE |
|
#'namespace eval foo' created ::punk::libunknown::foo instead of ::foo. Indexes that |
|
#define commands at source time for their own ifneeded scripts to call then failed at |
|
#require time with 'invalid command name' - found on twapi 4.7.2 (its index defines |
|
#twapi::set_scriptdir; its ifneeded script calls it), whose pattern this fixture copies. |
|
test pkgindex_relative_namespace_is_global {a pkgIndex.tcl's relative 'namespace eval' creates a GLOBAL namespace, so commands it defines for its own ifneeded script resolve at require time}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
variable libbase |
|
libu_probe [list $fixdir] [string map [list %LIBBASE% [list $libbase]] { |
|
set ::auto_path [list %LIBBASE%] |
|
set ::t_result [list] |
|
lappend ::t_result [package require pklu_nsindex] |
|
#the index-defined command must live where the ifneeded script looks for it |
|
lappend ::t_result [info commands ::pklu_nsindex::set_scriptdir] |
|
#and the sourcing namespace must not have collected it instead |
|
lappend ::t_result [namespace exists ::punk::libunknown::pklu_nsindex] |
|
#the variable the index set through its own command is readable too |
|
lappend ::t_result [expr {[info exists ::pklu_nsindex::scriptdir] ? 1 : 0}] |
|
}] |
|
} -result {1.0 ::pklu_nsindex::set_scriptdir 0 1} |
|
|
|
test pkgindex_auto_path_extension {a pkgIndex extending auto_path with an unqualified lappend still works (tcllib pattern)}\ |
|
-constraints {discoveryfixture libunknownavailable} -body { |
|
variable fixdir |
|
variable libbase |
|
libu_probe [list $fixdir] [string map [list %LIBBASE% [list $libbase]] { |
|
set ::auto_path [list %LIBBASE%] |
|
#pklu_ext lives below sublib, reachable only via pklu_extender/pkgIndex.tcl's |
|
#'lappend auto_path' - which must reach the real ::auto_path through the |
|
#sourcing frame's global link |
|
package require pklu_ext |
|
}] |
|
} -result 1.0 |
|
|
|
# cleanup fixture |
|
variable tempbase |
|
if {[info exists tempbase] && $tempbase ne "" && [file isdirectory $tempbase]} { |
|
catch {file delete -force $tempbase} |
|
} |
|
} |
|
|
|
tcltest::cleanupTests |
|
namespace delete ::testspace
|
|
|