Browse Source
20 pins for the previously near-unpinned punk::ns primitive region: nsparts/nsprefix/nstail/nsjoin/nsjoinall string behaviour incl weird colon-run (:::) splitting, trailing-colon parse ambiguity, round-trip exceptions; divergence pins proving nsparts1/nsprefix1/nsprefix_orig/ nstail1/nstail_orig are not drop-in twins (safe-deletion evidence); nseval create-on-eval + evaluator caching and the native-vs-punk p:::x resolution divergence; nseval_ifexists/nsexists/nschildren/nstree_raw on genuinely weird namespaces; globmatchns */**/? semantics (stale "should be fixed" comment above nsglob_as_re noted - behaviour fixed); nspath_to_absolute/nspath_here_absolute caller resolution. Warts recorded for the pass: nsjoinall error message says "nsjoin:". Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
2 changed files with 371 additions and 1 deletions
@ -0,0 +1,370 @@
|
||||
package require tcltest |
||||
|
||||
package require punk::ns |
||||
|
||||
namespace eval ::testspace { |
||||
namespace import ::tcltest::* |
||||
variable common { |
||||
set result "" |
||||
} |
||||
|
||||
#added 2026-07-14 (agent) - characterization pins for the punk::ns name/path string primitives and eval variants, coverage precondition for the planned punk::ns hygiene pass |
||||
#The primitive region of punk::ns contains variant/deprecated twins (nsparts1, nsprefix1, nsprefix_orig, nstail1, nstail_orig) that are |
||||
#consolidation candidates. The pins below record the exported primitives' behaviour AND where the twins diverge from them, so any |
||||
#dead-code removal during the hygiene pass is deliberate rather than assumed-equivalent. |
||||
#nsjoin/nsjoinall/nsprefix/nstail/nsparts are pure string functions - none of the namespaces used in these string pins need to exist. |
||||
|
||||
test nsparts_standard {nsparts splits well-formed paths - leading empty element marks fully qualified, :::: collapses to ::, spaces preserved}\ |
||||
-setup $common -body { |
||||
lappend result [punk::ns::nsparts ""] |
||||
lappend result [punk::ns::nsparts a] |
||||
lappend result [punk::ns::nsparts a::b] |
||||
lappend result [punk::ns::nsparts ::a::b] |
||||
lappend result [punk::ns::nsparts ::] |
||||
lappend result [punk::ns::nsparts ::a::::b] |
||||
lappend result [punk::ns::nsparts {::a b::c}] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{} a {a b} {{} a b} {{} {}} {{} a b} {{} {a b} c} |
||||
] |
||||
|
||||
test nsparts_weird_colons {nsparts on odd colon runs - leading-colon-greedy splitting of :::, trailing colons, bare-colon segments}\ |
||||
-setup $common -body { |
||||
lappend result [punk::ns::nsparts :::] ;# {} : |
||||
lappend result [punk::ns::nsparts :::::] ;# {} : {} |
||||
lappend result [punk::ns::nsparts ::::::] ;# {} : : |
||||
lappend result [punk::ns::nsparts ::a:::b] ;# {} a :b - rightmost colon binds to the tail (leading-colon preference) |
||||
lappend result [punk::ns::nsparts ::a:::::b] ;# {} a : b - bare-colon middle segment |
||||
lappend result [punk::ns::nsparts ::a::::::b] ;# {} a : :b |
||||
lappend result [punk::ns::nsparts a:::::b] ;# a : b - relative path (no leading empty element) |
||||
lappend result [punk::ns::nsparts :x] ;# single segment with leading colon |
||||
lappend result [punk::ns::nsparts :::x] ;# {} :x |
||||
lappend result [punk::ns::nsparts ::x:] ;# {} x: - trailing colon stays in the segment |
||||
lappend result [punk::ns::nsparts ::x::] ;# {} x {} - trailing :: gives empty tail |
||||
lappend result [punk::ns::nsparts ::a::b:::] ;# {} a b : |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{{} :} {{} : {}} {{} : :} {{} a :b} {{} a : b} {{} a : :b} {a : b} :x {{} :x} {{} x:} {{} x {}} {{} a b :} |
||||
] |
||||
|
||||
test nsparts1_divergence {nsparts1 is NOT equivalent to nsparts - its blanket ::::->:: collapse merges colon runs before splitting}\ |
||||
-setup $common -body { |
||||
lappend result [punk::ns::nsparts1 ::a:::b] ;# {} a :b - same as nsparts here |
||||
lappend result [punk::ns::nsparts1 ::a:::::b] ;# {} a :b - DIFFERS (nsparts: {} a : b) |
||||
lappend result [punk::ns::nsparts1 ::a::::::b] ;# {} a {} b - DIFFERS (nsparts: {} a : :b) - produces an empty middle segment |
||||
lappend result [punk::ns::nsparts1 :::::] ;# {} : - DIFFERS (nsparts: {} : {}) |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{{} a :b} {{} a :b} {{} a {} b} {{} :} |
||||
] |
||||
|
||||
test nsparts_cached_coherence {nsparts_cached returns the same as nsparts for plain and weird paths}\ |
||||
-setup $common -body { |
||||
foreach p [list "" ::a::b ::a:::::b ::x: {::a b::c}] { |
||||
lappend result [expr {[punk::ns::nsparts_cached $p] eq [punk::ns::nsparts $p]}] |
||||
} |
||||
set result |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
1 1 1 1 1 |
||||
] |
||||
|
||||
test nstail_standard_and_weird {nstail returns the last nsparts segment - unlike 'namespace tail' it preserves leading/trailing colons in the tail}\ |
||||
-setup $common -body { |
||||
lappend result [punk::ns::nstail ""] |
||||
lappend result [punk::ns::nstail ::] |
||||
lappend result [punk::ns::nstail ::a] |
||||
lappend result [punk::ns::nstail ::a::b] |
||||
lappend result [punk::ns::nstail ::a:::b] ;# :b ('namespace tail' would give b) |
||||
lappend result [punk::ns::nstail :::a] ;# :a |
||||
lappend result [punk::ns::nstail ::::::a] ;# :a |
||||
lappend result [punk::ns::nstail ::a::b:] ;# b: |
||||
lappend result [punk::ns::nstail ::a::b::] ;# empty - trailing :: is an empty tail |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
{} {} a b :b :a :a b: {} |
||||
] |
||||
|
||||
test nstail_variant_divergence {nstail1/nstail_orig diverge from nstail on long colon runs; nstail1 -strict errors on unpaired colons}\ |
||||
-setup $common -body { |
||||
lappend result [punk::ns::nstail1 ::::::a] ;# a - DIFFERS from nstail (:a) |
||||
lappend result [punk::ns::nstail_orig ::::::a] ;# a - DIFFERS from nstail (:a) |
||||
lappend result [punk::ns::nstail1 ::a:::b] ;# :b - same as nstail here |
||||
lappend result [catch {punk::ns::nstail1 ::a:::b -strict 1} emsg] $emsg |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
a a :b 1 {nstail unpaired colon ':' in ::a:::b} |
||||
] |
||||
|
||||
test nsprefix_variant_divergence {nsprefix1/nsprefix_orig diverge from nsprefix on colon runs of 5+ (they collapse, nsprefix keeps bare-colon segments)}\ |
||||
-setup $common -body { |
||||
lappend result [punk::ns::nsprefix :::::a] ;# ::: (as pinned in basic.test) |
||||
lappend result [punk::ns::nsprefix1 :::::a] ;# :: - DIFFERS |
||||
lappend result [punk::ns::nsprefix_orig :::::a] ;# :: - DIFFERS |
||||
lappend result [punk::ns::nsprefix ::a::::::b] ;# ::a::: |
||||
lappend result [punk::ns::nsprefix1 ::a::::::b] ;# ::a - DIFFERS |
||||
lappend result [punk::ns::nsprefix_orig ::a::::::b] ;# ::a:: - DIFFERS (and differs from nsprefix1) |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
::: :: :: ::a::: ::a ::a:: |
||||
] |
||||
|
||||
test nsjoin_edges {nsjoin edge cases - empty prefix absolutizes, empty name gives trailing :: (fq form of empty command name), absolute name rejects non-empty prefix}\ |
||||
-setup $common -body { |
||||
lappend result [punk::ns::nsjoin {} x] ;# ::x - empty prefix produces an ABSOLUTE path |
||||
lappend result [punk::ns::nsjoin {} ::x] ;# ::x - absolute name passes through when prefix empty |
||||
lappend result [punk::ns::nsjoin :: x] ;# ::x |
||||
lappend result [punk::ns::nsjoin :: {}] ;# :: |
||||
lappend result [punk::ns::nsjoin ::x::y {}] ;# ::x::y:: - fully qualified form used to call a command named as the empty string |
||||
lappend result [punk::ns::nsjoin x y] ;# x::y - relative prefix stays relative |
||||
lappend result [punk::ns::nsjoin ::x :y] ;# ::x:::y |
||||
lappend result [catch {punk::ns::nsjoin ::x ::y} emsg] $emsg |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
::x ::x ::x :: ::x::y:: x::y ::x:::y 1 {nsjoin: won't join non-empty prefix to absolute namespace path '::y'} |
||||
] |
||||
|
||||
test nsjoin_parse_stability {a leading-colon tail rejoins/reparses losslessly, but a trailing-colon prefix produces the same joined string and reparses differently}\ |
||||
-setup $common -body { |
||||
lappend result [punk::ns::nsjoin ::x :y] ;# ::x:::y |
||||
lappend result [punk::ns::nsparts [punk::ns::nsjoin ::x :y]] ;# {} x :y - round trips |
||||
lappend result [punk::ns::nsjoin ::x: y] ;# ::x:::y - SAME string as above (the documented trailing-colon ambiguity) |
||||
lappend result [punk::ns::nsparts [punk::ns::nsjoin ::x: y]] ;# {} x :y - NOT {{} x: y} - leading-colon preference reassociates the colon |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
::x:::y {{} x :y} ::x:::y {{} x :y} |
||||
] |
||||
|
||||
test nsprefix_nstail_nsjoin_roundtrip {nsjoin [nsprefix p] [nstail p] reassembles most inputs - exceptions are empty/bare-relative names (absolutized) and :::: collapse}\ |
||||
-setup $common -body { |
||||
foreach p [list :: ::a ::a::b a::b ::a:::b :::a :::::a ::a::b:: ::a::b: ::a::b:::c] { |
||||
set rejoined [punk::ns::nsjoin [punk::ns::nsprefix $p] [punk::ns::nstail $p]] |
||||
lappend result [expr {$rejoined eq $p}] |
||||
} |
||||
#non-round-trip cases |
||||
lappend result [punk::ns::nsjoin [punk::ns::nsprefix ""] [punk::ns::nstail ""]] ;# "" -> :: |
||||
lappend result [punk::ns::nsjoin [punk::ns::nsprefix a] [punk::ns::nstail a]] ;# a -> ::a (absolutized) |
||||
lappend result [punk::ns::nsjoin [punk::ns::nsprefix ::::a] [punk::ns::nstail ::::a]] ;# ::::a -> ::a (collapsed) |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
1 1 1 1 1 1 1 1 1 1 :: ::a ::a |
||||
] |
||||
|
||||
test nsjoinall_edges {nsjoinall - multiple segments, empty segments dropped, absolute arg allowed only while all preceding segments empty; error message says 'nsjoin:'}\ |
||||
-setup $common -body { |
||||
lappend result [punk::ns::nsjoinall ::] |
||||
lappend result [punk::ns::nsjoinall :: a b] |
||||
lappend result [punk::ns::nsjoinall ::x y z] |
||||
lappend result [punk::ns::nsjoinall a b::c d] |
||||
lappend result [punk::ns::nsjoinall :: {} b] ;# empty segments dropped |
||||
lappend result [punk::ns::nsjoinall ::x {}] |
||||
lappend result [punk::ns::nsjoinall a] ;# single arg passes through |
||||
lappend result [punk::ns::nsjoinall {}] |
||||
lappend result [punk::ns::nsjoinall {} {} ::y] ;# absolute arg accepted - everything before it is empty |
||||
#note the error message prefix is 'nsjoin:' not 'nsjoinall:' (wart - candidate for the hygiene pass) |
||||
lappend result [catch {punk::ns::nsjoinall ::x ::y} emsg] $emsg |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
:: ::a::b ::x::y::z a::b::c::d ::b ::x a {} ::y 1 {nsjoin: won't join non-empty namespace prefix to absolute namespace path '::y'} |
||||
] |
||||
|
||||
test nseval_creates_and_caches_evaluator {nseval requires a fully qualified ns, CREATES it if missing (documented WARNING), and caches a generated evaluator proc}\ |
||||
-setup $common -body { |
||||
lappend result [catch {punk::ns::nseval relns {string cat hi}} emsg] $emsg |
||||
lappend result [namespace exists ::punknstest_ev1] |
||||
lappend result [punk::ns::nseval ::punknstest_ev1 {::tcl::namespace::current}] |
||||
lappend result [namespace exists ::punknstest_ev1] ;# 1 - created as a side effect of evaluation |
||||
lappend result [llength [info commands ::punk::ns::evaluator::eval-_NS_punknstest_ev1]] |
||||
}\ |
||||
-cleanup { |
||||
catch {namespace delete ::punknstest_ev1} |
||||
catch {rename ::punk::ns::evaluator::eval-_NS_punknstest_ev1 ""} |
||||
}\ |
||||
-result [list\ |
||||
1 {nseval only accepts a fully qualified namespace} 0 ::punknstest_ev1 1 1 |
||||
] |
||||
|
||||
test nseval_weird_path_diverges_from_native {native 'namespace eval' resolves p:::x to child x - punk::ns::nseval parses it leading-colon-greedy and creates/reaches literal child :x}\ |
||||
-setup $common -body { |
||||
#native Tcl treats the ::: run as a separator to a child named x |
||||
lappend result [namespace eval ::punknstest_v:::x {namespace current}] ;# ::punknstest_v::x |
||||
lappend result [namespace children ::punknstest_v] ;# ::punknstest_v::x |
||||
#punk::ns::nseval on the same string form reaches (and creates) a child literally named :x |
||||
lappend result [punk::ns::nseval ::punknstest_v2:::x {::tcl::namespace::current}] |
||||
lappend result [namespace children ::punknstest_v2] ;# ::punknstest_v2:::x |
||||
}\ |
||||
-cleanup { |
||||
catch {namespace delete ::punknstest_v} |
||||
catch {namespace delete ::punknstest_v2} |
||||
catch {rename {::punk::ns::evaluator::eval-_NS_punknstest_v2_NS_:x} ""} |
||||
}\ |
||||
-result [list\ |
||||
::punknstest_v::x ::punknstest_v::x ::punknstest_v2:::x ::punknstest_v2:::x |
||||
] |
||||
|
||||
test nseval_ifexists_plain {nseval_ifexists on plain paths - evaluates in existing ns with script errors propagating, returns empty (no creation) for missing ns}\ |
||||
-setup { |
||||
set result "" |
||||
namespace eval ::punknstest_ie {variable marker 42} |
||||
}\ |
||||
-body { |
||||
lappend result [punk::ns::nseval_ifexists ::punknstest_ie {set marker}] |
||||
lappend result [catch {punk::ns::nseval_ifexists ::punknstest_ie {error boom}} emsg] $emsg |
||||
lappend result [punk::ns::nseval_ifexists ::punknstest_missing {set marker}] |
||||
lappend result [namespace exists ::punknstest_missing] ;# 0 - not created |
||||
}\ |
||||
-cleanup { |
||||
catch {namespace delete ::punknstest_ie} |
||||
}\ |
||||
-result [list\ |
||||
42 1 boom {} 0 |
||||
] |
||||
|
||||
test nseval_ifexists_weird {nseval_ifexists on a genuinely weird ns (child literally named :odd) - reaches it, script errors propagate, missing weird path returns empty without creating}\ |
||||
-setup { |
||||
set result "" |
||||
namespace eval ::punknstest_w {namespace eval {:odd} {variable marker 42}} |
||||
}\ |
||||
-body { |
||||
#native children display is the ambiguous string form - indistinguishable from a child odd of a ns named punknstest_w: |
||||
lappend result [namespace children ::punknstest_w] |
||||
lappend result [punk::ns::nschildren ::punknstest_w] |
||||
lappend result [punk::ns::nseval_ifexists ::punknstest_w:::odd {set marker}] |
||||
lappend result [punk::ns::nseval_ifexists ::punknstest_w:::odd {info vars}] |
||||
lappend result [catch {punk::ns::nseval_ifexists ::punknstest_w:::odd {error boom}} emsg] $emsg |
||||
lappend result [punk::ns::nseval_ifexists ::punknstest_w:::nope {set marker}] |
||||
lappend result [namespace eval ::punknstest_w {namespace exists {:nope}}] ;# 0 - not created |
||||
}\ |
||||
-cleanup { |
||||
catch {namespace delete ::punknstest_w} |
||||
}\ |
||||
-result [list\ |
||||
::punknstest_w:::odd ::punknstest_w:::odd 42 marker 1 boom {} 0 |
||||
] |
||||
|
||||
test nsexists_pins {nsexists - empty string false, global true, weird ns findable, relative paths resolve against the caller namespace}\ |
||||
-setup { |
||||
set result "" |
||||
namespace eval ::punknstest_e { |
||||
namespace eval {:odd} {} |
||||
namespace eval child {} |
||||
} |
||||
}\ |
||||
-body { |
||||
lappend result [punk::ns::nsexists ""] |
||||
lappend result [punk::ns::nsexists ::] |
||||
lappend result [punk::ns::nsexists ::punknstest_e] |
||||
lappend result [punk::ns::nsexists ::punknstest_e_missing] |
||||
lappend result [punk::ns::nsexists ::punknstest_e:::odd] ;# 1 - weird ns found via punk string parsing |
||||
lappend result [namespace eval ::punknstest_e {punk::ns::nsexists child}] |
||||
lappend result [namespace eval ::punknstest_e {punk::ns::nsexists nochild}] |
||||
}\ |
||||
-cleanup { |
||||
catch {namespace delete ::punknstest_e} |
||||
}\ |
||||
-result [list\ |
||||
0 1 1 0 1 1 0 |
||||
] |
||||
|
||||
test nschildren_sort {nschildren -sort choices - default natural, ascii lsort, none unpinned order; relative ns resolves against caller}\ |
||||
-setup { |
||||
set result "" |
||||
namespace eval ::punknstest_c { |
||||
namespace eval b2 {} |
||||
namespace eval b10 {} |
||||
namespace eval a {namespace eval g {}} |
||||
} |
||||
}\ |
||||
-body { |
||||
lappend result [punk::ns::nschildren ::punknstest_c] ;# natural: b2 before b10 |
||||
lappend result [punk::ns::nschildren -sort ascii ::punknstest_c] ;# ascii: b10 before b2 |
||||
lappend result [lsort [punk::ns::nschildren -sort none ::punknstest_c]] ;# -sort none order is tcl-internal - pin membership only |
||||
lappend result [namespace eval ::punknstest_c {punk::ns::nschildren a}] ;# relative resolves against caller |
||||
}\ |
||||
-cleanup { |
||||
catch {namespace delete ::punknstest_c} |
||||
}\ |
||||
-result [list\ |
||||
{::punknstest_c::a ::punknstest_c::b2 ::punknstest_c::b10}\ |
||||
{::punknstest_c::a ::punknstest_c::b10 ::punknstest_c::b2}\ |
||||
{::punknstest_c::a ::punknstest_c::b10 ::punknstest_c::b2}\ |
||||
::punknstest_c::a::g |
||||
] |
||||
|
||||
test nstree_raw_pins {nstree_raw requires a fully qualified ns and lists weird children literally}\ |
||||
-setup { |
||||
set result "" |
||||
namespace eval ::punknstest_t { |
||||
namespace eval sub {} |
||||
namespace eval {:odd} {} |
||||
} |
||||
}\ |
||||
-body { |
||||
lappend result [catch {punk::ns::nstree_raw punknstest_t} emsg] $emsg |
||||
lappend result [lsort [punk::ns::nstree_raw ::punknstest_t]] |
||||
}\ |
||||
-cleanup { |
||||
catch {namespace delete ::punknstest_t} |
||||
}\ |
||||
-result [list\ |
||||
1 {nstree_raw requires a fully qualified namespace}\ |
||||
{::punknstest_t ::punknstest_t:::odd ::punknstest_t::sub} |
||||
] |
||||
|
||||
test globmatchns_pins {globmatchns - * matches within a level (including a single inner colon) but not across ::, ** crosses levels, ? matches one non-colon char}\ |
||||
-setup $common -body { |
||||
lappend result [punk::ns::globmatchns ::a::* ::a::b] |
||||
lappend result [punk::ns::globmatchns ::a::* ::a::b::c] ;# 0 - * does not cross :: |
||||
lappend result [punk::ns::globmatchns ::a::** ::a::b::c] ;# 1 - ** crosses :: |
||||
lappend result [punk::ns::globmatchns ::g*t ::got:it] ;# 1 - * matches a single inner colon (the 'should be fixed' comment above nsglob_as_re is stale - behaviour is fixed) |
||||
lappend result [punk::ns::globmatchns ::a::? ::a::b] |
||||
lappend result [punk::ns::globmatchns ::a::? ::a::bc] ;# 0 - ? is a single char |
||||
lappend result [punk::ns::globmatchns ::w::* {::w:::odd}] ;# 1 - * at a level also matches a leading-colon (weird) child |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
1 0 1 1 1 0 1 |
||||
] |
||||
|
||||
test nspath_absolute_helpers {nspath_to_absolute joins relative paths to a base; nspath_here_absolute resolves against the caller ns with empty-name trailing :: form}\ |
||||
-setup $common -body { |
||||
#namespace current is ::testspace |
||||
lappend result [punk::ns::nspath_to_absolute x ::base] |
||||
lappend result [punk::ns::nspath_to_absolute ::x ::base] |
||||
lappend result [punk::ns::nspath_to_absolute {} ::base] |
||||
lappend result [punk::ns::nspath_here_absolute] |
||||
lappend result [punk::ns::nspath_here_absolute {}] ;# trailing :: - fq form of empty command name in caller ns |
||||
lappend result [punk::ns::nspath_here_absolute v] |
||||
lappend result [punk::ns::nspath_here_absolute ::v] |
||||
}\ |
||||
-cleanup { |
||||
}\ |
||||
-result [list\ |
||||
::base::x ::x ::base ::testspace ::testspace:: ::testspace::v ::v |
||||
] |
||||
|
||||
} |
||||
tcltest::cleanupTests ;#needed to produce test summary. |
||||
Loading…
Reference in new issue