Browse Source
src/make.tcl kit icon seam (G-057): mechanism selection is now punkres-first - kiticon::punkres_available (memoized; binary presence at bin/punkres(.exe) is the selection signal) + kit_icon_embed_punkres (exec wrapper; punkres verifies its own output). twapi arm unchanged as fallback; when NEITHER serves the skip notice combines both reasons and names the 'make.tcl tool build punkres' remedy. Sidecar embedding value gains 'punkres' (bin/AGENTS.md format doc, ARCHITECTURE.md kit-icon bullet updated; architecture_lint clean). Live-bake fallback matrix on punkluck86 (win32-ix86 = PE32 arm live): punkres present -> embedded via punkres, kit boots + smoke OK; punkres absent + twapi loadable -> via twapi; both absent -> unavailable with combined notice, embedding none (exact pre-G-128 degradation). Live parity: both arms' baked kits listing-identical (codepage host-ACP noise finding recorded in the goal detail) with byte-identical extracted icons. New src/tests/shell/testsuites/punkexe/punkres.test (7/7 under the tclsh9.0.5-punk runner; self-gates on bin/punkres + store fixture): overlay- unsafe refusal exit 3 with untouched input, consented file-relative shift with convention preserved, payload intact via punk::zip members + crc-verified extraction, icon replaced (extract-ico == punkshell.ico), idempotent re-stamp byte-identical, make.tcl tool info punkres provenance records. Full punkexe suite 83 tests 0 failed (no collateral). Goal detail: Notes findings (codepage noise, root-vendorlib twapi fragility, nested tclsfe payload, metakit move-safety -> G-101 pointer updated) + Progress increment 1 with the two remaining acceptance items (non-windows-host e2e, punkbin publication route) and one acceptance-wording flag for the user (metakit 'kit' shape vs 'zip overlay' clause). punkshell 0.30.1 + CHANGELOG. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
7 changed files with 452 additions and 32 deletions
@ -1,4 +1,4 @@ |
|||||||
[project] |
[project] |
||||||
name = "punkshell" |
name = "punkshell" |
||||||
version = "0.30.0" |
version = "0.30.1" |
||||||
license = "BSD-2-Clause" |
license = "BSD-2-Clause" |
||||||
|
|||||||
@ -0,0 +1,234 @@ |
|||||||
|
package require tcltest |
||||||
|
|
||||||
|
#Characterization of the vendored punkres portable PE resource stamper (goal |
||||||
|
#G-128) against a REAL artifact: the file-relative prefixed runtime |
||||||
|
#bin/runtime/win32-x86_64/tclsh90b4_piperepl.exe (the same store fixture the |
||||||
|
#punk::zip accelerator parity suite uses). Pins the G-128 acceptance behaviours |
||||||
|
#on scratch COPIES (store originals are never modified): |
||||||
|
# - overlay-unsafe refusal: a file-relative zip payload is REFUSED by default |
||||||
|
# (exit 3) with the reason and both remedies named |
||||||
|
# - consented stamp: -allow-file-relative-shift stamps, the offset convention |
||||||
|
# is PRESERVED (punk::zip::archive_info offsetstyle still 'file'), the |
||||||
|
# member count is unchanged and member data crc-verifies (payload intact) |
||||||
|
# - icon replaced: extract-ico of the stamped copy is byte-identical to |
||||||
|
# src/runtime/punkshell.ico |
||||||
|
# - idempotent: re-stamping the stamped copy is byte-identical (convergence) |
||||||
|
# - make.tcl tool discovery: 'tool info punkres' reports the PROVENANCE.md |
||||||
|
# records (run via the punk executable's script subcommand, as |
||||||
|
# maketcltool.test does for punkzip) |
||||||
|
#All punkres tests self-gate on bin/punkres(.exe) being built (zig stays |
||||||
|
#OPTIONAL - an unbuilt tree skips them) and on the store fixture being present. |
||||||
|
# |
||||||
|
#Target punk executable for the make.tcl test resolved from |
||||||
|
#env(PUNK_SHELL_TEST_EXE), else <projectroot>/bin/punk902z.exe then |
||||||
|
#<projectroot>/bin/punkshell902. |
||||||
|
|
||||||
|
namespace eval ::testspace { |
||||||
|
namespace import ::tcltest::* |
||||||
|
|
||||||
|
variable testdir [file dirname [file normalize [info script]]] |
||||||
|
#<projectroot>/src/tests/shell/testsuites/punkexe -> 5 levels up to <projectroot> |
||||||
|
variable projectroot [file normalize [file join $testdir .. .. .. .. ..]] |
||||||
|
variable maketcl [file join $projectroot src make.tcl] |
||||||
|
|
||||||
|
variable punkresexe "" |
||||||
|
foreach candidate [list [file join $projectroot bin punkres.exe] [file join $projectroot bin punkres]] { |
||||||
|
if {[file isfile $candidate]} { |
||||||
|
set punkresexe $candidate |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
variable fixture [file join $projectroot bin runtime win32-x86_64 tclsh90b4_piperepl.exe] |
||||||
|
variable srcicon [file join $projectroot src runtime punkshell.ico] |
||||||
|
|
||||||
|
testConstraint punkresavailable [expr {$punkresexe ne ""}] |
||||||
|
testConstraint punkresfixture [expr {$punkresexe ne "" && [file isfile $fixture] && [file isfile $srcicon]}] |
||||||
|
testConstraint punkzipmodule [expr {![catch {package require punk::zip}]}] |
||||||
|
|
||||||
|
variable punkexe "" |
||||||
|
if {[info exists ::env(PUNK_SHELL_TEST_EXE)] && $::env(PUNK_SHELL_TEST_EXE) ne ""} { |
||||||
|
set punkexe [file normalize $::env(PUNK_SHELL_TEST_EXE)] |
||||||
|
} else { |
||||||
|
foreach candidate [list [file join $projectroot bin punk902z.exe] [file join $projectroot bin punkshell902]] { |
||||||
|
if {[file exists $candidate]} { |
||||||
|
set punkexe $candidate |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
testConstraint punkexeavailable [expr {$punkexe ne "" && [file exists $punkexe]}] |
||||||
|
|
||||||
|
#run punkres with stderr merged; returns {exitcode output}. exec raises on |
||||||
|
#nonzero exit with CHILDSTATUS carrying the code. |
||||||
|
proc run_punkres {args} { |
||||||
|
variable punkresexe |
||||||
|
set rc 0 |
||||||
|
set out "" |
||||||
|
if {[catch {exec [file nativename $punkresexe] {*}$args 2>@1} out errdict]} { |
||||||
|
if {[lindex [dict get $errdict -errorcode] 0] eq "CHILDSTATUS"} { |
||||||
|
set rc [lindex [dict get $errdict -errorcode] end] |
||||||
|
} else { |
||||||
|
set rc -1 |
||||||
|
} |
||||||
|
} |
||||||
|
return [list $rc $out] |
||||||
|
} |
||||||
|
|
||||||
|
proc readbin {path} { |
||||||
|
set f [open $path rb] |
||||||
|
set data [read $f] |
||||||
|
close $f |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
variable workdir [temporaryDirectory] |
||||||
|
variable frcopy [file join $workdir punkres_frcopy.exe] |
||||||
|
variable frcopy2 [file join $workdir punkres_frcopy2.exe] |
||||||
|
variable exico [file join $workdir punkres_extracted.ico] |
||||||
|
|
||||||
|
#added 2026-07-29 (agent, G-128) |
||||||
|
test punkres_info_fixture {info -porcelain classifies the store piperepl runtime: zip payload, file-relative offsets} -constraints {punkresfixture} -body { |
||||||
|
variable fixture |
||||||
|
lassign [run_punkres info -porcelain [file nativename $fixture]] rc out |
||||||
|
set result [list rc $rc] |
||||||
|
lappend result versionline [regexp {(?n)^punkres_info_v1$} $out] |
||||||
|
lappend result kind [regexp {(?n)^overlay_kind zip$} $out] |
||||||
|
lappend result style [regexp {(?n)^zip_style file$} $out] |
||||||
|
lappend result base0 [regexp {(?n)^zip_base 0$} $out] |
||||||
|
lappend result members [regexp {(?n)^zip_members [1-9][0-9]*$} $out] |
||||||
|
set result |
||||||
|
} -result {rc 0 versionline 1 kind 1 style 1 base0 1 members 1} |
||||||
|
|
||||||
|
#added 2026-07-29 (agent, G-128) |
||||||
|
test punkres_refuse_file_relative {set-icon on a file-relative payload copy is refused by default: exit 3, reason + both remedies} -constraints {punkresfixture} -body { |
||||||
|
variable fixture; variable frcopy; variable srcicon |
||||||
|
file copy -force $fixture $frcopy |
||||||
|
lassign [run_punkres set-icon [file nativename $frcopy] [file nativename $srcicon]] rc out |
||||||
|
set result [list rc $rc] |
||||||
|
lappend result refused [regexp {REFUSED: appended zip payload records FILE-relative member offsets} $out] |
||||||
|
lappend result remedyflag [regexp -- {-allow-file-relative-shift} $out] |
||||||
|
lappend result remedyrewrap [regexp {rewrap the artifact archive-relative} $out] |
||||||
|
#refusal happened before any write: the copy is untouched |
||||||
|
lappend result untouched [string equal [readbin $frcopy] [readbin $fixture]] |
||||||
|
set result |
||||||
|
} -result {rc 3 refused 1 remedyflag 1 remedyrewrap 1 untouched 1} |
||||||
|
|
||||||
|
#added 2026-07-29 (agent, G-128) |
||||||
|
test punkres_consent_shift {consented stamp preserves the file-relative convention with all offsets rewritten} -constraints {punkresfixture} -body { |
||||||
|
variable frcopy; variable srcicon |
||||||
|
lassign [run_punkres set-icon -allow-file-relative-shift [file nativename $frcopy] [file nativename $srcicon]] rc out |
||||||
|
set result [list rc $rc] |
||||||
|
lappend result moved [regexp {overlay: zip file-relative, [0-9]+ bytes moved by [0-9]+; [0-9]+ central-directory offsets and the EOCD directory offset rewritten \(non-standard convention PRESERVED\)} $out] |
||||||
|
lappend result verified [regexp {verify: resources re-read OK; zip overlay file-relative preserved, [0-9]+ members, all local headers at rewritten offsets} $out] |
||||||
|
set result |
||||||
|
} -result {rc 0 moved 1 verified 1} |
||||||
|
|
||||||
|
#added 2026-07-29 (agent, G-128) |
||||||
|
test punkres_payload_intact {stamped copy's payload: offsetstyle still file, member count unchanged, member data crc-verifies} -constraints {punkresfixture punkzipmodule} -body { |
||||||
|
variable fixture; variable frcopy; variable workdir |
||||||
|
set orig_info [punk::zip::archive_info $fixture] |
||||||
|
set new_info [punk::zip::archive_info $frcopy] |
||||||
|
set result [list] |
||||||
|
lappend result offsetstyle [dict get $new_info offsetstyle] |
||||||
|
lappend result members_match [expr {[llength [punk::zip::members $frcopy]] == [llength [punk::zip::members $fixture]]}] |
||||||
|
#crc-verified extraction of a member subset proves data intact through |
||||||
|
#the shift (-verify defaults to 1: a crc mismatch raises) |
||||||
|
set exdir [file join $workdir punkres_exdir] |
||||||
|
file delete -force $exdir |
||||||
|
file mkdir $exdir |
||||||
|
punk::zip::unzip $frcopy $exdir tcl_library/init.tcl |
||||||
|
lappend result extracted [file isfile [file join $exdir tcl_library init.tcl]] |
||||||
|
file delete -force $exdir |
||||||
|
set result |
||||||
|
} -result {offsetstyle file members_match 1 extracted 1} |
||||||
|
|
||||||
|
#added 2026-07-29 (agent, G-128) |
||||||
|
test punkres_icon_replaced {extract-ico of the stamped copy is byte-identical to the source punkshell.ico} -constraints {punkresfixture} -body { |
||||||
|
variable frcopy; variable exico; variable srcicon |
||||||
|
file delete -force $exico |
||||||
|
lassign [run_punkres extract-ico [file nativename $frcopy] [file nativename $exico]] rc out |
||||||
|
set result [list rc $rc] |
||||||
|
lappend result identical [string equal [readbin $exico] [readbin $srcicon]] |
||||||
|
set result |
||||||
|
} -cleanup { |
||||||
|
file delete -force $exico |
||||||
|
} -result {rc 0 identical 1} |
||||||
|
|
||||||
|
#added 2026-07-29 (agent, G-128) |
||||||
|
test punkres_idempotent {re-stamping the stamped copy converges byte-identically (rebuild mode, no accumulation)} -constraints {punkresfixture} -body { |
||||||
|
variable frcopy; variable frcopy2; variable srcicon |
||||||
|
lassign [run_punkres set-icon -o [file nativename $frcopy2] -allow-file-relative-shift [file nativename $frcopy] [file nativename $srcicon]] rc out |
||||||
|
set result [list rc $rc] |
||||||
|
lappend result rebuildmode [regexp {mode: rebuild section \.prsrc in place} $out] |
||||||
|
lappend result identical [string equal [readbin $frcopy] [readbin $frcopy2]] |
||||||
|
set result |
||||||
|
} -cleanup { |
||||||
|
file delete -force $frcopy $frcopy2 |
||||||
|
} -result {rc 0 rebuildmode 1 identical 1} |
||||||
|
|
||||||
|
# -- make.tcl tool discovery (same piped pattern as maketcltool.test) -- |
||||||
|
|
||||||
|
variable maketcl_run_timeout_ms 60000 |
||||||
|
variable runstate |
||||||
|
array set runstate {} |
||||||
|
|
||||||
|
proc maketcl_run_read {chan} { |
||||||
|
variable runstate |
||||||
|
append runstate(output) [read $chan] |
||||||
|
if {[chan eof $chan]} { |
||||||
|
chan event $chan readable {} |
||||||
|
set runstate(done) eof |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc maketcl_run {cmdargs} { |
||||||
|
variable runstate |
||||||
|
variable maketcl_run_timeout_ms |
||||||
|
variable punkexe |
||||||
|
variable maketcl |
||||||
|
array unset runstate |
||||||
|
set runstate(output) "" |
||||||
|
set runstate(done) "" |
||||||
|
|
||||||
|
set chan [open |[list $punkexe script $maketcl {*}$cmdargs 2>@1] r+] |
||||||
|
chan configure $chan -blocking 0 -translation binary |
||||||
|
catch {chan close $chan write} ;#no stdin for the child - immediate EOF |
||||||
|
set timerid [after $maketcl_run_timeout_ms [list set [namespace current]::runstate(done) timeout]] |
||||||
|
chan event $chan readable [list [namespace current]::maketcl_run_read $chan] |
||||||
|
while {$runstate(done) eq ""} { |
||||||
|
vwait [namespace current]::runstate(done) |
||||||
|
} |
||||||
|
after cancel $timerid |
||||||
|
set timedout [expr {$runstate(done) eq "timeout"}] |
||||||
|
set exitcode "" |
||||||
|
if {$timedout} { |
||||||
|
catch {exec {*}[auto_execok taskkill] /F /T /PID [lindex [pid $chan] 0]} |
||||||
|
catch {chan close $chan} |
||||||
|
} else { |
||||||
|
chan configure $chan -blocking 1 |
||||||
|
if {[catch {chan close $chan} errdata errdict]} { |
||||||
|
set exitcode [lindex [dict get $errdict -errorcode] end] |
||||||
|
} else { |
||||||
|
set exitcode 0 |
||||||
|
} |
||||||
|
} |
||||||
|
return [dict create timedout $timedout exitcode $exitcode output $runstate(output)] |
||||||
|
} |
||||||
|
|
||||||
|
#added 2026-07-29 (agent, G-128) |
||||||
|
test maketcl_tool_info_punkres {tool info punkres reports the PROVENANCE.md records (zero-edit discovery of the second tool)} -constraints {punkexeavailable} -body { |
||||||
|
set r [maketcl_run {tool info punkres}] |
||||||
|
set out [dict get $r output] |
||||||
|
set result [list] |
||||||
|
lappend result timedout [dict get $r timedout] exitcode [dict get $r exitcode] |
||||||
|
lappend result toolline [regexp {(?n)^tool: punkres\s*$} $out] |
||||||
|
lappend result upstream [regexp {(?n)^ upstream:\s+\S+} $out] |
||||||
|
lappend result commit [regexp {(?n)^ vendored commit: [0-9a-f]{40}\s*$} $out] |
||||||
|
lappend result provfile [regexp {(?n)^ provenance:\s+\S+PROVENANCE\.md\s*$} $out] |
||||||
|
lappend result floor [regexp {(?n)^ zig floor:\s+>= 0\.16\.0\s*$} $out] |
||||||
|
set result |
||||||
|
} -result {timedout 0 exitcode 0 toolline 1 upstream 1 commit 1 provfile 1 floor 1} |
||||||
|
|
||||||
|
cleanupTests |
||||||
|
} |
||||||
|
namespace delete ::testspace |
||||||
Loading…
Reference in new issue