Browse Source
G-176 marked active (user-directed). New src/tests/modules/punk/libunknown/testsuites/discovery/packageoverride.test pins the CURRENT punk::libunknown ::package override ahead of the increment-2 migration onto commandstack::rename_command. BEHAVIOUR pins (must stay green byte-identically through the migration): 'package epoch tm|pkg' single-arg forms, indexed '<which> <index> ?key?' queries, the four error arms, the filtered forget arm (real-ifneeded forgotten, no-ifneeded filtered out, tcl/Tcl/tcl::oo/tk denied, mixed lists partially applied), abbreviation acceptance (ep/epo/epoc + fo routing, with the parked builtin's rejection of 'ep' pinned as the override's deliberate delta), delegation pass-through, and the re-init no-op contract (stderr notice captured via a child ::puts shim). MARKED-TO-FLIP pins (comment-fenced to the increment-2 commit and no other): the install shape (::package origin = the ::punk::libunknown::package namespace import; :📦: parked and functional) and the two-override packagepreference interop children in BOTH real-world install orders (punkshell's pkgpref-first: stack count 1 + import origin; make.tcl's libunknown-first: stack count 1 + ::package proc origin). Children are fresh interps sourcing the source-tree libunknown/commandstack/packagepreference by path via a shared highest-version locator (discovery.test pattern). All 11 pins green on the first run against the live implementation. Tests AGENTS.md index updated; goal file gains its Progress entry. testbody_lint 1699 clean; goals_lint clean (80 active-index / 96 archived); modules tree 1346 total / 1335 pass / 11 constraint-skipped / 0 fail (zig-built tclsh90s 9.0.5). Claude-Session: https://claude.ai/code/session_01QgaxV27VZkmEec7oNbEVFc Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
4 changed files with 309 additions and 3 deletions
@ -0,0 +1,289 @@
|
||||
# -*- tcl -*- |
||||
# Characterization tests for the punk::libunknown ::package override itself - |
||||
# the install shape, the epoch/forget/abbreviation arms and delegation - as a |
||||
# pre-migration safety net for G-176 increment 2 (migration of the override |
||||
# onto commandstack::rename_command). See goals/G-176-commandstack-doc-integration.md. |
||||
# |
||||
# Pin classes: |
||||
# - BEHAVIOUR pins: must stay green byte-identically through the migration. |
||||
# - MARKED-TO-FLIP pins: assert the CURRENT install mechanism (::package is a |
||||
# namespace import of ::punk::libunknown::package; the previous |
||||
# implementation is parked at ::package::; commandstack sees only the |
||||
# packagepreference record when both overrides are live). These flip in the |
||||
# G-176 increment-2 commit and in no other. |
||||
# |
||||
# Children are fresh interps sourcing the SOURCE-TREE modules by path (same |
||||
# rationale and locator pattern as discovery.test in this directory). |
||||
# |
||||
# Run: tclsh src/tests/runtests.tcl -report compact -show-passes 0 -include-paths modules/punk/libunknown/** packageoverride.test |
||||
|
||||
package require tcltest |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
|
||||
variable script_dir [file dirname [file normalize [info script]]] |
||||
variable srcmodules [file normalize [file join $script_dir .. .. .. .. .. .. modules]] |
||||
|
||||
#pick the highest-version source-tree copy should multiple coexist |
||||
proc locate_srcmodule {globpat} { |
||||
variable srcmodules |
||||
set best "" |
||||
set bestver "" |
||||
foreach candidate [glob -nocomplain [file join $srcmodules {*}$globpat]] { |
||||
set thisver [file rootname [lindex [split [file tail $candidate] -] 1]] |
||||
if {$best eq "" || [package vcompare $thisver $bestver] == 1} { |
||||
set best $candidate |
||||
set bestver $thisver |
||||
} |
||||
} |
||||
return $best |
||||
} |
||||
variable libunknown_src [locate_srcmodule {punk libunknown-*.tm}] |
||||
variable commandstack_src [locate_srcmodule {commandstack-*.tm}] |
||||
variable pkgpref_src [locate_srcmodule {punk packagepreference-*.tm}] |
||||
|
||||
testConstraint pko_sources [expr {$libunknown_src ne ""}] |
||||
testConstraint pko_interopsources [expr {$libunknown_src ne "" && $commandstack_src ne "" && $pkgpref_src ne ""}] |
||||
if {$libunknown_src eq ""} { |
||||
puts stderr "packageoverride.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 sourced and |
||||
# init run (override installed). No tm paths are added - the epoch state stays |
||||
# at its init values, so epoch pins are deterministic. Child deleted after. |
||||
# ------------------------------------------------------------------------- |
||||
proc pko_probe {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 $script |
||||
} finally { |
||||
interp delete $i |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Interop probe: both live ::package overrides in the given install order. |
||||
# pkgpref_first - punkshell boot order: packagepreference installs its |
||||
# wrapper via commandstack first, libunknown's plain |
||||
# rename+import lands on top. |
||||
# libunknown_first - make.tcl order: libunknown alone first, then |
||||
# packagepreference's commandstack wrapper on top. |
||||
# ------------------------------------------------------------------------- |
||||
proc pko_interop {order script} { |
||||
variable libunknown_src |
||||
variable commandstack_src |
||||
variable pkgpref_src |
||||
set i [interp create] |
||||
try { |
||||
interp eval $i {package prefer latest} |
||||
interp eval $i {tcl::tm::remove {*}[tcl::tm::list]} |
||||
if {$order eq "pkgpref_first"} { |
||||
interp eval $i [list source $commandstack_src] |
||||
interp eval $i [list source $pkgpref_src] |
||||
interp eval $i {punk::packagepreference::install} |
||||
interp eval $i [list source $libunknown_src] |
||||
interp eval $i {punk::libunknown::init} |
||||
} else { |
||||
interp eval $i [list source $libunknown_src] |
||||
interp eval $i {punk::libunknown::init} |
||||
interp eval $i [list source $commandstack_src] |
||||
interp eval $i [list source $pkgpref_src] |
||||
interp eval $i {punk::packagepreference::install} |
||||
} |
||||
interp eval $i $script |
||||
} finally { |
||||
interp delete $i |
||||
} |
||||
} |
||||
|
||||
#added 2026-08-08 (agent, G-176 increment 1) - pre-migration characterisation of the |
||||
#current ::package override. BEHAVIOUR pins below survive the migration unchanged. |
||||
|
||||
# -- 'package epoch' query forms (previously only the 0-arg form was pinned) -- |
||||
|
||||
test override_epoch_singlearg_forms {package epoch tm / package epoch pkg return a one-entry dict keyed by the current epoch, value carrying the epoch record}\ |
||||
-constraints pko_sources -body { |
||||
pko_probe { |
||||
set full [package epoch] |
||||
set curtm [dict get $full tm] |
||||
set curpkg [dict get $full pkg] |
||||
set dtm [package epoch tm] |
||||
set dpkg [package epoch pkg] |
||||
list [dict size $dtm] [expr {[lindex [dict keys $dtm] 0] eq $curtm}] [dict exists $dtm $curtm added]\ |
||||
[dict size $dpkg] [expr {[lindex [dict keys $dpkg] 0] eq $curpkg}] [dict exists $dpkg $curpkg added] |
||||
} |
||||
} -result {1 1 1 1 1 1} |
||||
|
||||
test override_epoch_indexed_queries {package epoch <which> <index> returns the epoch record; a trailing key path walks into it}\ |
||||
-constraints pko_sources -body { |
||||
pko_probe { |
||||
list [dict exists [package epoch tm 0] added]\ |
||||
[package epoch tm 0 added]\ |
||||
[dict exists [package epoch pkg 0] added] |
||||
} |
||||
} -result {1 {} 1} |
||||
|
||||
test override_epoch_error_arms {unsupported option, bad index, unsupported pair and missing key each raise their documented message}\ |
||||
-constraints pko_sources -body { |
||||
pko_probe { |
||||
set r [list] |
||||
lappend r [catch {package epoch bogus} m] [string match "*unsupported - known options: tm pkg incr*" $m] |
||||
lappend r [catch {package epoch tm 99} m] [string match "*unable to use index 99*" $m] |
||||
lappend r [catch {package epoch xx 5} m] [string match "*unsupported - expected 'pkg incr' or 'tm incr'*" $m] |
||||
lappend r [catch {package epoch tm 0 nosuchkey} m] [string match "*not found. Toplevel keys:*" $m] |
||||
set r |
||||
} |
||||
} -result {1 1 1 1 1 1 1 1} |
||||
|
||||
# -- the forget arm (previously untested) ------------------------------------ |
||||
|
||||
test override_forget_filtered {a provided package with a real ifneeded script is forgotten; a provided package with no ifneeded script is filtered out (not forgotten)}\ |
||||
-constraints pko_sources -body { |
||||
pko_probe { |
||||
package ifneeded pko_fake 1.0 {package provide pko_fake 1.0} |
||||
package require pko_fake |
||||
package provide pko_bare 1.0 |
||||
set r [list] |
||||
lappend r [package provide pko_fake] |
||||
package forget pko_fake |
||||
lappend r [package provide pko_fake] |
||||
package forget pko_bare |
||||
lappend r [package provide pko_bare] |
||||
set r |
||||
} |
||||
} -result {1.0 {} 1.0} |
||||
|
||||
test override_forget_denied_names {tcl/Tcl/tcl::oo/tk are never forgotten - an all-denied call is a silent no-op and a mixed call forgets only the allowed names}\ |
||||
-constraints pko_sources -body { |
||||
pko_probe { |
||||
package ifneeded pko_fake2 1.0 {package provide pko_fake2 1.0} |
||||
package require pko_fake2 |
||||
set r [list] |
||||
lappend r [expr {[package forget tcl Tcl tcl::oo tk] eq ""}] |
||||
lappend r [expr {[package provide Tcl] ne ""}] |
||||
package forget Tcl pko_fake2 |
||||
lappend r [expr {[package provide Tcl] ne ""}] [package provide pko_fake2] |
||||
set r |
||||
} |
||||
} -result {1 1 1 {}} |
||||
|
||||
# -- abbreviation acceptance (a behaviour delta the override introduces) ------ |
||||
|
||||
test override_abbreviations {ep/epo/epoc reach the epoch arm and fo routes to the filtered forget arm - while the parked builtin rejects the same abbreviation}\ |
||||
-constraints pko_sources -body { |
||||
pko_probe { |
||||
set full [package epoch] |
||||
set r [list] |
||||
foreach a {ep epo epoc} { |
||||
lappend r [expr {[package $a] eq $full}] |
||||
} |
||||
package ifneeded pko_fake3 1.0 {package provide pko_fake3 1.0} |
||||
package require pko_fake3 |
||||
package fo pko_fake3 |
||||
lappend r [package provide pko_fake3] |
||||
lappend r [catch {::package:: ep}] |
||||
set r |
||||
} |
||||
} -result {1 1 1 {} 1} |
||||
|
||||
# -- delegation pass-through -------------------------------------------------- |
||||
|
||||
test override_delegation_passthrough {subcommands outside the intercepted arms delegate to the previous implementation unchanged}\ |
||||
-constraints pko_sources -body { |
||||
pko_probe { |
||||
package provide pko_dele 2.5 |
||||
list [package vcompare 1.2 1.3]\ |
||||
[package vsatisfies 1.2 1.0-]\ |
||||
[package provide pko_dele]\ |
||||
[expr {[package provide Tcl] ne ""}] |
||||
} |
||||
} -result {-1 1 2.5 1} |
||||
|
||||
# -- install shape ------------------------------------------------------------ |
||||
#MARKED-TO-FLIP (G-176 increment 2): these pin the CURRENT rename+import install |
||||
#mechanism - ::package is a namespace import of ::punk::libunknown::package and |
||||
#the previous implementation is parked at ::package::. The migration commit |
||||
#flips them to the commandstack-installed shape (real proc at ::package, no |
||||
#::package:: residue) and nothing else may. |
||||
|
||||
test override_install_shape {current mechanism: ::package is an import of punk::libunknown::package and ::package:: holds the working previous implementation}\ |
||||
-constraints pko_sources -body { |
||||
pko_probe { |
||||
list [namespace origin ::package]\ |
||||
[llength [info commands ::package::]]\ |
||||
[expr {[::package:: provide Tcl] ne ""}] |
||||
} |
||||
} -result {::punk::libunknown::package 1 1} |
||||
|
||||
# -- re-init guard ------------------------------------------------------------ |
||||
#The no-op contract (second init returns empty and leaves the install alone) is |
||||
#BEHAVIOUR and survives the migration. The message text and the import-shaped |
||||
#origin element are install-mechanism detail - MARKED-TO-FLIP with increment 2 |
||||
#if the migrated guard reports differently. |
||||
|
||||
test override_reinit_guard {a second init call is a no-op: empty return, an 'already done' stderr notice, install unchanged}\ |
||||
-constraints pko_sources -body { |
||||
pko_probe { |
||||
rename ::puts ::pko_origputs |
||||
proc ::puts args { |
||||
if {[llength $args] >= 2 && [lindex $args 0] eq "stderr"} { |
||||
append ::pko_captured [lindex $args 1] \n |
||||
return |
||||
} |
||||
tailcall ::pko_origputs {*}$args |
||||
} |
||||
set ::pko_captured "" |
||||
set second [punk::libunknown::init] |
||||
rename ::puts "" |
||||
rename ::pko_origputs ::puts |
||||
list [expr {$second eq ""}]\ |
||||
[string match "*already done*" $::pko_captured]\ |
||||
[namespace origin ::package] |
||||
} |
||||
} -result {1 1 ::punk::libunknown::package} |
||||
|
||||
# -- packagepreference interop - both real-world install orders --------------- |
||||
#punkshell boot: packagepreference (commandstack) first, libunknown on top. |
||||
#make.tcl: libunknown alone (packagepreference may arrive later). |
||||
#BEHAVIOUR pins: epoch answers and require chains down to the builtin in BOTH |
||||
#orders. MARKED-TO-FLIP pins: the commandstack ::package stack sees only the |
||||
#packagepreference record (1) while libunknown's rename is unmanaged, and in |
||||
#pkgpref_first order ::package is libunknown's import - increment 2 flips the |
||||
#stack count to 2 and the origin to the commandstack-installed proc. |
||||
|
||||
test override_interop_pkgpref_first {punkshell order: both overrides live - epoch and require both work; stack sees only the managed record (flips to 2)}\ |
||||
-constraints pko_interopsources -body { |
||||
pko_interop pkgpref_first { |
||||
set r [list] |
||||
set e [package epoch] |
||||
lappend r [expr {[dict exists $e tm] && [dict exists $e pkg]}] |
||||
package ifneeded pko_x 1.0 {package provide pko_x 1.0} |
||||
lappend r [package require pko_x] |
||||
lappend r [llength [commandstack::get_stack ::package]] |
||||
lappend r [namespace origin ::package] |
||||
set r |
||||
} |
||||
} -result {1 1.0 1 ::punk::libunknown::package} |
||||
|
||||
test override_interop_libunknown_first {make.tcl order then packagepreference on top: epoch reaches through the wrapper's delegation and require works; stack sees only the managed record (flips to 2)}\ |
||||
-constraints pko_interopsources -body { |
||||
pko_interop libunknown_first { |
||||
set r [list] |
||||
set e [package epoch] |
||||
lappend r [expr {[dict exists $e tm] && [dict exists $e pkg]}] |
||||
package ifneeded pko_y 1.0 {package provide pko_y 1.0} |
||||
lappend r [package require pko_y] |
||||
lappend r [llength [commandstack::get_stack ::package]] |
||||
lappend r [namespace origin ::package] |
||||
set r |
||||
} |
||||
} -result {1 1.0 1 ::package} |
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary line. |
||||
Loading…
Reference in new issue