Browse Source
punk::libunknown gains register_all_tm: walks every tcl:™️:list path
recursively and registers ifneeded scripts for .tm modules at every
namespace depth (the tm unknown handler only registers siblings at the
requested depth, leaving never-requested subfolders like test::* invisible
to 'package names'). First registration wins - parity with the handler and
the shadowing pins. Reuses/populates the per-epoch directory index cache
(zipfs whole-tree listing; per-dir globs for filesystem paths; #modpod-*,
#tarjar-* and _build skipped) and runs at most once per tm epoch per
interp - the guard is the interp-local tm_fullscan variable, deliberately
not in the shareable epoch dict since ifneeded registrations are
interp-local.
punk::mix::commandset::loadedlib 0.2.0: search runs register_all_tm plus
the auto_path pkgIndex sweep by default when punk::libunknown is active,
so 'dev lib.search test' now shows deep modules without -refresh.
-refresh is repurposed to mean a genuine filesystem re-scan: package epoch
incr (invalidating the scan caches) then rediscovery - picking up .tm
files added/removed on disk. Without punk::libunknown (or with an older
copy lacking register_all_tm) -refresh falls back to the previous
dummy-require deep walk. Dependency fixes: highlight ansi computed only
when -highlight 1 via qualified punk::ansi with inline require (previously
relied on the shell-global a+ alias unconditionally and errored in bare
interps), inline requires for punk::path (fallback walk) and textblock
(table output).
New test suites (green under tclsh90 and tclsh87):
- modules/punk/libunknown/testsuites/discovery/discovery.test: lazy-depth
sibling registration, register_all_tm all-depths/cached-per-epoch/
head-wins-parity, package epoch shape and trace-driven increments,
epoch-cache short-circuit + incr recipe, and a GAP pin of
zipfs_tclPkgUnknown clobbering a user global 'dir' variable (stock
tclPkgUnknown keeps dir proc-local; fix candidate).
- modules/punk/mix/testsuites/loadedlib/libsearch.test: search match
semantics, default deep discovery, -refresh re-scan contract, highlight
without shell-global ansi aliases.
Both suites source the source-tree punk::libunknown directly by path:
'package require' would tie-break the same-version bootsupport copy by tm
path order (testinterp order favours bootsupport; child-interp
'tm::add {*}list' reverses precedence).
Verified live in 'punk902z src'. Build artifacts synced via make.tcl
packages + vfscommonupdate (loadedlib-0.2.0.tm, libunknown-0.1.tm).
Note: src/bootsupport copy of punk::libunknown intentionally untouched -
becomes stale until the next 'make.tcl bootsupport' sync; loadedlib
degrades gracefully against it. punk::libunknown remains manually
versioned at 0.1.
punkshell 0.10.0 (see CHANGELOG.md; also records the 0.9.1 doc-only
-refresh help rewrite).
Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.com
master
10 changed files with 1008 additions and 38 deletions
@ -1,3 +1,3 @@
|
||||
[project] |
||||
name = "punkshell" |
||||
version = "0.9.0" |
||||
version = "0.10.0" |
||||
|
||||
@ -1,3 +1,7 @@
|
||||
0.1.0 |
||||
0.2.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
#0.2.0 - search now performs deep module discovery by default when punk::libunknown is active: calls new punk::libunknown::register_all_tm (registers .tm modules at every namespace depth, cached per 'package epoch') plus the pkgIndex.tcl sweep of ::auto_path - so namespaced modules in never-requested subfolders (e.g test::*) appear without -refresh |
||||
#0.2.0 - -refresh repurposed to mean a genuine filesystem re-scan: increments the package epoch first (invalidating punk::libunknown's scan caches) then re-runs discovery, picking up .tm files added/removed on disk and re-sourcing pkgIndex.tcl files; without punk::libunknown (or with an older copy lacking register_all_tm) -refresh falls back to the previous behaviour (deep discovery walk via dummy package require calls at each namespace depth) |
||||
#0.2.0 - dependency fixes: highlight ansi codes now computed only when -highlight 1 using fully-qualified punk::ansi::a+/a with an inline package require (previously relied on shell-global a+ alias unconditionally and errored in bare interps even with -highlight 0); inline package require punk::path in the fallback -refresh walk and package require textblock in the table/tableobject return branch (previously assumed the shell environment had loaded them) |
||||
#0.1.1 - doc-only: rewrote 'search -refresh' PUNKARGS help to document actual semantics - a deep tm discovery pass (dummy requires at each namespace depth so ifneeded scripts get registered for .tm modules in never-requested subfolders), not a filesystem re-scan; within an epoch the punk::libunknown index cache short-circuits re-globbing of already-scanned dirs (run 'package epoch incr' first for a genuine re-scan); tm/auto_path list changes are handled automatically by epoch traces and don't need the flag |
||||
|
||||
@ -0,0 +1,319 @@
|
||||
# -*- 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) |
||||
# ------------------------------------------------------------------------- |
||||
variable fixture_error "" |
||||
variable fixdir "" |
||||
variable mutdir "" |
||||
variable mut2dir "" |
||||
variable sdirA "" |
||||
variable sdirB "" |
||||
variable epochextra "" |
||||
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] |
||||
file mkdir [file join $fixdir pkluns subns] $mutdir $mut2dir $sdirA $sdirB $epochextra |
||||
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 |
||||
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' would tie-break the same-version (0.1) |
||||
#copies in src/modules and src/bootsupport/modules by 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). |
||||
variable libunknown_src "" |
||||
variable script_dir [file dirname [file normalize [info script]]] |
||||
set srcmodules [file normalize [file join $script_dir .. .. .. .. .. .. modules]] |
||||
set candidates [lsort [glob -nocomplain [file join $srcmodules punk libunknown-*.tm]]] |
||||
if {[llength $candidates]} { |
||||
set libunknown_src [lindex $candidates end] |
||||
} |
||||
testConstraint libunknownavailable [expr {$libunknown_src ne ""}] |
||||
if {$libunknown_src eq ""} { |
||||
puts stderr "discovery.test: cannot locate src/modules/punk/libunknown-*.tm relative to [info script] (tests will be skipped)" |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Probe: fresh child interp with the source-tree 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 |
||||
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 $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} |
||||
|
||||
#GAP: pins a divergence from stock Tcl that is a candidate for fixing. |
||||
#Stock tclPkgUnknown keeps 'dir' proc-local (pkgIndex.tcl files are sourced |
||||
#in the proc's scope). punk::libunknown::zipfs_tclPkgUnknown sources index |
||||
#files at :: scope and therefore declares 'global dir' - clobbering any |
||||
#user global named 'dir' whenever a package require falls through to the |
||||
#pkg unknown handler. If that is fixed (e.g save/restore ::dir), the |
||||
#expected result flips to 1. |
||||
test libunknown_GAP_pkgunknown_clobbers_global_dir {a global 'dir' variable is overwritten by 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 0 |
||||
|
||||
# cleanup fixture |
||||
variable tempbase |
||||
if {[info exists tempbase] && $tempbase ne "" && [file isdirectory $tempbase]} { |
||||
catch {file delete -force $tempbase} |
||||
} |
||||
} |
||||
|
||||
tcltest::cleanupTests |
||||
namespace delete ::testspace |
||||
@ -0,0 +1,213 @@
|
||||
# -*- tcl -*- |
||||
# Tests for punk::mix::commandset::loadedlib::search ('dev lib.search'): |
||||
# match semantics (-return list) and the -refresh deep-discovery contract, |
||||
# exercised in an isolated child interp with punk::libunknown active and |
||||
# fixture-only tm search paths. |
||||
# |
||||
# Contract (loadedlib 0.2.0): with punk::libunknown active, search performs |
||||
# deep module discovery by default (punk::libunknown::register_all_tm - cached |
||||
# per 'package epoch'), so .tm modules at every namespace depth are found |
||||
# without -refresh. -refresh means a genuine filesystem re-scan: it increments |
||||
# the package epoch (invalidating the scan caches) then re-runs discovery. |
||||
# |
||||
# Environment note: loadedlib 0.2.0 no longer needs the shell-provided global |
||||
# 'a+'/'a' aliases or a pre-loaded punk::path - the child setup below |
||||
# deliberately provides neither, pinning that self-containment. (punk::ansi is |
||||
# pre-required in the child only because the fixture-trimmed tm paths cannot |
||||
# resolve it later; the highlight test exercises search's own qualified |
||||
# punk::ansi calls without any global alias.) |
||||
# |
||||
# ORDERING NOTE: tests share one provisioned child interp (building it is the |
||||
# expensive part - punk::ns/punk::lib/punk::ansi loads). Package registration |
||||
# is cumulative and -refresh increments the shared child's package epoch, so |
||||
# the -refresh re-scan test runs LAST. |
||||
# |
||||
# Run: tclsh src/tests/runtests.tcl -report compact -show-passes 0 -include-paths modules/punk/mix/** libsearch.test |
||||
|
||||
package require tcltest |
||||
package require punk::lib |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Fixture tm tree (distinctive pklsr_ prefix so 'package names' deltas are |
||||
# unambiguous among the child's real loaded packages): |
||||
# fix/pklsr_topmod-1.0.tm, -1.1.tm (two versions) |
||||
# fix/pklsr_topsib-1.0.tm |
||||
# fix/pklsrns/leafmod-1.0.tm (pklsrns::leafmod) |
||||
# fix/pklsrns/leafsib-1.0.tm (pklsrns::leafsib) |
||||
# fix/pklsrns/subns/verydeep-1.0.tm (pklsrns::subns::verydeep) |
||||
# mut/pklsr_mtop-1.0.tm (mutation dir for epoch test) |
||||
# ------------------------------------------------------------------------- |
||||
variable fixture_error "" |
||||
variable fixdir "" |
||||
variable mutdir "" |
||||
try { |
||||
set base [punk::lib::tempdir_newfolder -prefix pklibsearch] |
||||
set fixdir [file join $base fix] |
||||
set mutdir [file join $base mut] |
||||
file mkdir [file join $fixdir pklsrns subns] $mutdir |
||||
foreach {relpath content} { |
||||
{pklsr_topmod-1.0.tm} {package provide pklsr_topmod 1.0} |
||||
{pklsr_topmod-1.1.tm} {package provide pklsr_topmod 1.1} |
||||
{pklsr_topsib-1.0.tm} {package provide pklsr_topsib 1.0} |
||||
{pklsrns/leafmod-1.0.tm} {package provide pklsrns::leafmod 1.0} |
||||
{pklsrns/leafsib-1.0.tm} {package provide pklsrns::leafsib 1.0} |
||||
{pklsrns/subns/verydeep-1.0.tm} {package provide pklsrns::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 pklsr_mtop-1.0.tm] w] |
||||
puts $fd {package provide pklsr_mtop 1.0} |
||||
close $fd |
||||
variable tempbase $base |
||||
} on error {result} { |
||||
set fixture_error $result |
||||
} |
||||
if {$fixture_error ne ""} { |
||||
puts stderr "libsearch.test fixture setup failed (tests will be skipped): $fixture_error" |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Shared child interp: punk::libunknown active, loadedlib + its shell-env |
||||
# assumptions provided, then tm paths trimmed to the fixture dirs so |
||||
# searches and -refresh walks are deterministic and fast. |
||||
# ------------------------------------------------------------------------- |
||||
#The SOURCE-TREE punk::libunknown, located relative to this test file. |
||||
#A 'package require punk::libunknown' would tie-break the same-version (0.1) |
||||
#copies in src/modules and src/bootsupport/modules by tm path order - these |
||||
#tests need register_all_tm from the source copy, so it is sourced directly |
||||
#by path (as punk_main.tcl loads it). The other punk requires below are dev |
||||
#alpha versions (999999.0a1.0), which 'package prefer latest' selects |
||||
#deterministically regardless of tm path order. |
||||
variable libunknown_src "" |
||||
variable script_dir [file dirname [file normalize [info script]]] |
||||
set srcmodules [file normalize [file join $script_dir .. .. .. .. .. .. modules]] |
||||
set candidates [lsort [glob -nocomplain [file join $srcmodules punk libunknown-*.tm]]] |
||||
if {[llength $candidates]} { |
||||
set libunknown_src [lindex $candidates end] |
||||
} |
||||
|
||||
variable child "" |
||||
variable child_error "" |
||||
if {$fixture_error eq "" && $libunknown_src eq ""} { |
||||
set child_error "cannot locate src/modules/punk/libunknown-*.tm relative to [info script]" |
||||
puts stderr "libsearch.test: $child_error (tests will be skipped)" |
||||
} |
||||
if {$fixture_error eq "" && $child_error eq ""} { |
||||
try { |
||||
set child [interp create] |
||||
interp eval $child {package prefer latest} |
||||
interp eval $child {tcl::tm::remove {*}[tcl::tm::list]} |
||||
interp eval $child [list tcl::tm::add {*}[tcl::tm::list]] |
||||
interp eval $child [list set ::auto_path $::auto_path] |
||||
interp eval $child [list source $libunknown_src] |
||||
interp eval $child { |
||||
punk::libunknown::init |
||||
package require punk::mix::commandset::loadedlib |
||||
#punk::ansi pre-required only because the fixture-trimmed tm paths below |
||||
#cannot resolve it later; deliberately NO global a+/a aliases and NO |
||||
#punk::path - loadedlib 0.2.0 must not need the shell environment |
||||
package require punk::ansi |
||||
} |
||||
#trim search paths to the fixture: deterministic 'package names' |
||||
#deltas and fast -refresh walks / pkgIndex sweeps |
||||
interp eval $child {tcl::tm::remove {*}[tcl::tm::list]} |
||||
interp eval $child [list tcl::tm::add $fixdir $mutdir] |
||||
interp eval $child {set ::auto_path [list [info library]]} |
||||
#top-level scan: registers pklsr_topmod/pklsr_topsib/pklsr_mtop |
||||
#(sibling registration across all tm paths at root depth) |
||||
interp eval $child {package require pklsr_topmod} |
||||
} on error {result} { |
||||
set child_error $result |
||||
puts stderr "libsearch.test child interp setup failed (tests will be skipped): $child_error" |
||||
} |
||||
} |
||||
testConstraint searchchild [expr {$fixture_error eq "" && $child_error eq ""}] |
||||
|
||||
proc csearch {args} { |
||||
variable child |
||||
interp eval $child [list punk::mix::commandset::loadedlib::search -return list -highlight 0 {*}$args] |
||||
} |
||||
|
||||
#added 2026-07-11 (agent) - coverage prep for lib.search deep-discovery work (punk::mix::commandset::loadedlib) |
||||
|
||||
# -- match semantics ----------------------------------------------------------- |
||||
|
||||
test libsearch_substring_wrapped {a searchstring without glob chars is wrapped *name* (substring match)}\ |
||||
-constraints searchchild -body { |
||||
csearch sr_topsi |
||||
} -result {{pklsr_topsib 1.0}} |
||||
|
||||
test libsearch_versions_aggregated {all registered versions listed, vcompare-sorted}\ |
||||
-constraints searchchild -body { |
||||
csearch =pklsr_topmod |
||||
} -result {{pklsr_topmod {1.0 1.1}}} |
||||
|
||||
test libsearch_exact_prefix {=name searches exact - no wrapping, no partial match}\ |
||||
-constraints searchchild -body { |
||||
list [csearch =pklsr_topsib] [csearch =pklsr_topsi] |
||||
} -result {{{pklsr_topsib 1.0}} {}} |
||||
|
||||
test libsearch_case_insensitive_except_exact {non-exact search is nocase, =exact is case sensitive}\ |
||||
-constraints searchchild -body { |
||||
list [csearch PKLSR_TOPSIB] [csearch =PKLSR_TOPSIB] |
||||
} -result {{{pklsr_topsib 1.0}} {}} |
||||
|
||||
test libsearch_explicit_glob_not_wrapped {a searchstring containing glob chars is used as-is (anchored)}\ |
||||
-constraints searchchild -body { |
||||
list [lsort [lmap m [csearch pklsr_top*] {lindex $m 0}]] [csearch sr_top*] |
||||
} -result {{pklsr_topmod pklsr_topsib} {}} |
||||
|
||||
# -- highlight self-containment --------------------------------------------------- |
||||
|
||||
#added 2026-07-11 (agent) - pins the loadedlib 0.2.0 dependency fix: highlight uses |
||||
#qualified punk::ansi calls (no shell-global a+ alias exists in this child) |
||||
test libsearch_highlight_no_global_ansi_alias {-highlight 1 works without the shell-global a+ alias}\ |
||||
-constraints searchchild -body { |
||||
variable child |
||||
set r [interp eval $child [list punk::mix::commandset::loadedlib::search -return list -highlight 1 =pklsr_topmod]] |
||||
#pklsr_topmod 1.1 is loaded in the child - its version entry gets ansi-wrapped |
||||
list [llength $r] [string match "*pklsr_topmod*" $r] [string match "*\x1b*" $r] |
||||
} -result {1 1 1} |
||||
|
||||
# -- deep discovery / -refresh contract ------------------------------------------ |
||||
|
||||
#flipped 2026-07-11 (agent) from libsearch_GAP_default_misses_unscanned_deep_tm: |
||||
#deep discovery is now the default when punk::libunknown is active |
||||
test libsearch_default_deep_discovery {.tm modules at every namespace depth found without -refresh; registration persists}\ |
||||
-constraints searchchild -body { |
||||
#the second query pins that registration persists across searches |
||||
list [csearch leafsib] [csearch verydeep] |
||||
} -result {{{pklsrns::leafsib 1.0}} {{pklsrns::subns::verydeep 1.0}}} |
||||
|
||||
test libsearch_refresh_rescans_filesystem {default search misses .tm files added to already-scanned dirs (epoch cache); -refresh re-scans and finds them}\ |
||||
-constraints searchchild -body { |
||||
variable mutdir |
||||
#mut dir was scanned within the current epoch (deep discovery above); |
||||
#a module added on disk afterwards is behind the epoch index cache |
||||
set fd [open [file join $mutdir pklsr_newmod-1.0.tm] w] |
||||
puts $fd {package provide pklsr_newmod 1.0} |
||||
close $fd |
||||
set result [list] |
||||
lappend result [csearch sr_newmod] |
||||
#-refresh = package epoch incr + re-run discovery |
||||
lappend result [csearch -refresh sr_newmod] |
||||
} -result {{} {{pklsr_newmod 1.0}}} |
||||
|
||||
# cleanup |
||||
variable child |
||||
if {$child ne "" && [interp exists $child]} { |
||||
interp delete $child |
||||
} |
||||
variable tempbase |
||||
if {[info exists tempbase] && $tempbase ne "" && [file isdirectory $tempbase]} { |
||||
catch {file delete -force $tempbase} |
||||
} |
||||
} |
||||
|
||||
tcltest::cleanupTests |
||||
namespace delete ::testspace |
||||
Loading…
Reference in new issue