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