You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
272 lines
13 KiB
272 lines
13 KiB
#family_check.tcl (G-103): self-containment verification for one runtime kit |
|
#family member (plain / punk / punk-bi). Run under the suite-built BUILDER shell; |
|
#the KIT exe under test is exec'd as probe children. |
|
# |
|
#Why the copy-to-scratch: beside the installed out/family location sits ../lib |
|
#(the suite prefix), which the stock tm-path setup (<exedir>/../lib) and |
|
#tcl_findLibrary's exe-relative entries would silently satisfy. The kit is copied |
|
#alone into a fresh scratch dir and probed FROM THERE with cwd=scratch, so only |
|
#the attached image can serve the probes ("no external Tcl visible"). |
|
# |
|
#The probe environment is scrubbed of every tcl redirection var (TCL_LIBRARY, |
|
#TK_LIBRARY, TCLLIBPATH, VFS_LIBRARY, TCL*_TM_PATH); TCLSH_PIPEREPL is controlled |
|
#per probe - it is the punk-vs-plain discriminator (G-096 behaviour matrix: with |
|
#the gate open the patched shell publishes ::tclsh(istty) before the startup |
|
#script runs; with TCLSH_PIPEREPL=0 or unpatched sources no ::tclsh machinery |
|
#exists). Script-arg probes never set ::tclsh(dorepl), so no probe can land in |
|
#the console-reopen repl (no hang risk). |
|
# |
|
#args: -exe <kitexe> -variant plain|punk|punk-bi -expectpatch <patchlevel> |
|
# -thread <ver> -vfs <ver> -tcllib <ver> ?-tk <patchlevel>? ?-tklib <ver>? |
|
# ?-expectrev <N>? (G-117: asserts the embedded record's revision + -r<N> name) |
|
|
|
proc fail {msg} {puts stderr "family_check FAIL: $msg"; flush stderr; exit 1} |
|
proc note {msg} {puts stdout "family_check: $msg"; flush stdout} |
|
|
|
array set opt {-exe {} -variant {} -expectpatch {} -expectrev {} -thread {} -vfs {} -tcllib {} -tk {} -tklib {}} |
|
foreach {k v} $argv { |
|
if {![info exists opt($k)]} {fail "unknown option '$k'"} |
|
set opt($k) $v |
|
} |
|
foreach req {-exe -variant -expectpatch -thread -vfs -tcllib} { |
|
if {$opt($req) eq ""} {fail "missing required option $req"} |
|
} |
|
if {$opt(-variant) ni {plain punk punk-bi}} {fail "-variant must be plain|punk|punk-bi"} |
|
if {$opt(-variant) eq "punk-bi" && ($opt(-tk) eq "" || $opt(-tklib) eq "")} { |
|
fail "punk-bi variant requires -tk and -tklib expected versions" |
|
} |
|
set exe [file normalize $opt(-exe)] |
|
if {![file exists $exe]} {fail "kit exe not found: $exe"} |
|
|
|
#-- scrub the probe environment (children inherit ::env at exec time) --------- |
|
foreach ev [array names ::env] { |
|
if {$ev in {TCL_LIBRARY TK_LIBRARY TCLLIBPATH VFS_LIBRARY TCLSH_PIPEREPL} |
|
|| [string match TCL*_TM_PATH $ev]} { |
|
unset ::env($ev) |
|
} |
|
} |
|
|
|
#-- scratch dir with the kit copied in alone --------------------------------- |
|
set scratch [file join [file tempdir] "punkfamilycheck_[pid]_[clock clicks -microseconds]"] |
|
file mkdir $scratch |
|
set kitname [file tail $exe] |
|
set kit [file join $scratch $kitname] |
|
file copy $exe $kit |
|
|
|
proc probe {name script args} { |
|
#write the probe script into the scratch dir and run the kit on it with |
|
#cwd=scratch; env pairs in $args are set for the child and removed after. |
|
#returns the child output; fails hard on nonzero exit. |
|
global scratch kit |
|
set sf [file join $scratch probe_$name.tcl] |
|
set f [open $sf w] |
|
puts $f $script |
|
close $f |
|
foreach {ev val} $args {set ::env($ev) $val} |
|
set rc [catch {exec $kit $sf 2>@1} out] |
|
foreach {ev val} $args {unset ::env($ev)} |
|
if {$rc} {fail "probe '$name' failed (kit $kit):\n$out"} |
|
return $out |
|
} |
|
proc checks {output} { |
|
#parse 'CHECK <key> <value>' lines into a dict |
|
set d [dict create] |
|
foreach line [split $output \n] { |
|
set line [string trim $line] |
|
if {[string match "CHECK *" $line]} { |
|
dict set d [lindex $line 1] [lindex $line 2] |
|
} |
|
} |
|
return $d |
|
} |
|
proc asserteq {d key expect what} { |
|
if {![dict exists $d $key]} {fail "$what: no CHECK line for '$key' (got: $d)"} |
|
set got [dict get $d $key] |
|
if {$got ne $expect} {fail "$what: $key = '$got', expected '$expect'"} |
|
} |
|
|
|
#-- probe: core batteries (all variants) ------------------------------------- |
|
#Also proves cwd independence: the probe chdirs into a subdir it creates, so |
|
#relative-path leakage from the scratch dir itself would surface. |
|
set core_script { |
|
proc out {k v} {puts [list CHECK $k $v]} |
|
out patchlevel [info patchlevel] |
|
out tcl_library $::tcl_library |
|
out library_zipfs [string match //zipfs:/app/* $::tcl_library] |
|
#attached-library facts (suite_smoke parity) |
|
out tz [expr {[catch {clock format 0 -gmt 0 -format %Z}] ? "FAIL" : "ok"}] |
|
out encoding [expr {[catch {encoding convertto cp1250 test}] ? "FAIL" : "ok"}] |
|
#tm path serves modules from the attached image (tcl9/<ver> beside tcl_library) |
|
out platform_tm [expr {[catch {package require platform} v] ? "FAIL:$v" : "ok"}] |
|
#Thread: version + functional cross-thread eval |
|
if {[catch {package require Thread} tver]} {out thread "FAIL:$tver"} else { |
|
out thread $tver |
|
set tid [thread::create] |
|
out thread_eval [thread::send $tid {expr {6*7}}] |
|
thread::release $tid |
|
} |
|
#tclvfs: version + representative vfs::* + functional zip mount round-trip |
|
#(the kit's own zipfs mkzip makes the test archive - no external tools) |
|
if {[catch {package require vfs} vver]} {out vfs "FAIL:$vver"} else { |
|
out vfs $vver |
|
out vfs_zip [expr {[catch {package require vfs::zip} zv] ? "FAIL:$zv" : $zv}] |
|
out vfs_urltype [expr {[catch {package require vfs::urltype} uv] ? "FAIL:$uv" : $uv}] |
|
set d [file join [pwd] vfstest] |
|
file mkdir $d/payload |
|
set f [open $d/payload/hello.txt w]; puts -nonewline $f "family-vfs-roundtrip"; close $f |
|
cd $d |
|
tcl::zipfs::mkzip probe.zip payload payload |
|
set mnt [vfs::zip::Mount [file join $d probe.zip] zipmnt] |
|
set f [open zipmnt/hello.txt r]; set data [read $f]; close $f |
|
vfs::zip::Unmount $mnt zipmnt |
|
out vfs_roundtrip [expr {$data eq "family-vfs-roundtrip" ? "ok" : "FAIL:$data"}] |
|
} |
|
#tcllib module + tcllibc acceleration engaged (pkg_smoke -accel parity) |
|
if {[catch {package require md5} mver]} {out md5 "FAIL:$mver"} else { |
|
out md5 $mver |
|
out tcllibc [expr {[catch {package require tcllibc} cv] ? "FAIL:$cv" : $cv}] |
|
upvar #0 ::md5::accel accelarr |
|
out md5_accel [expr {[info exists accelarr(critcl)] && $accelarr(critcl) ? 1 : 0}] |
|
} |
|
exit 0 |
|
} |
|
set d [checks [probe core $core_script]] |
|
asserteq $d patchlevel $opt(-expectpatch) "core" |
|
asserteq $d library_zipfs 1 "core (tcl_library=[dict get $d tcl_library])" |
|
asserteq $d tz ok "core" |
|
asserteq $d encoding ok "core" |
|
asserteq $d platform_tm ok "core" |
|
asserteq $d thread $opt(-thread) "core" |
|
asserteq $d thread_eval 42 "core" |
|
asserteq $d vfs $opt(-vfs) "core" |
|
asserteq $d vfs_roundtrip ok "core" |
|
asserteq $d md5_accel 1 "core (tcllibc=[expr {[dict exists $d tcllibc]?[dict get $d tcllibc]:"?"}])" |
|
foreach k {vfs_zip vfs_urltype tcllibc} { |
|
if {[string match FAIL* [dict get $d $k]]} {fail "core: $k [dict get $d $k]"} |
|
} |
|
note "core OK ($opt(-variant)): tcl [dict get $d patchlevel] library [dict get $d tcl_library] thread [dict get $d thread] vfs [dict get $d vfs] (zip [dict get $d vfs_zip], urltype [dict get $d vfs_urltype]) md5 [dict get $d md5] accel=1" |
|
|
|
#-- probe: Tk create/destroy (bi only) --------------------------------------- |
|
if {$opt(-variant) eq "punk-bi"} { |
|
set tk_script { |
|
proc out {k v} {puts [list CHECK $k $v]} |
|
if {[catch {package require Tk} tkver]} {out tk "FAIL:$tkver"; exit 0} |
|
out tk $tkver |
|
wm withdraw . |
|
button .b -text family |
|
out tk_widget [winfo exists .b] |
|
destroy .b |
|
out tk_widget_destroyed [expr {![winfo exists .b]}] |
|
destroy . |
|
out tk_done ok |
|
exit 0 |
|
} |
|
set d [checks [probe tk $tk_script]] |
|
asserteq $d tk $opt(-tk) "tk" |
|
asserteq $d tk_widget 1 "tk" |
|
asserteq $d tk_widget_destroyed 1 "tk" |
|
asserteq $d tk_done ok "tk" |
|
#tklib rides only in the bi payload |
|
set tklib_script { |
|
proc out {k v} {puts [list CHECK $k $v]} |
|
package require Tk |
|
wm withdraw . |
|
out tooltip [expr {[catch {package require tooltip} v] ? "FAIL:$v" : $v}] |
|
destroy . |
|
exit 0 |
|
} |
|
set d [checks [probe tklib $tklib_script]] |
|
if {[string match FAIL* [dict get $d tooltip]]} {fail "tklib: tooltip [dict get $d tooltip]"} |
|
note "tk OK: Tk $opt(-tk) create/destroy + tklib tooltip [dict get $d tooltip]" |
|
} |
|
|
|
#-- probe: piperepl gate (variant discriminator) ------------------------------ |
|
#tclshreopened: G-118 item 7 patch rev - gate-open punk kits publish |
|
#::tclsh(reopened) as 0 at startup (the console-reopen flip itself needs a real |
|
#console and is outside this harness) |
|
set gate_script { |
|
puts [list CHECK tclshmachinery [info exists ::tclsh(istty)]] |
|
puts [list CHECK tclshreopened [expr {[info exists ::tclsh(reopened)] ? $::tclsh(reopened) : "absent"}]] |
|
exit 0 |
|
} |
|
set d_default [checks [probe gate_default $gate_script]] |
|
set d_optout [checks [probe gate_optout $gate_script TCLSH_PIPEREPL 0]] |
|
if {$opt(-variant) eq "plain"} { |
|
#unpatched: no machinery regardless of the env var (even explicitly enabled) |
|
asserteq $d_default tclshmachinery 0 "piperepl (plain, env unset)" |
|
asserteq $d_default tclshreopened absent "piperepl (plain, env unset)" |
|
set d_on [checks [probe gate_on $gate_script TCLSH_PIPEREPL 1]] |
|
asserteq $d_on tclshmachinery 0 "piperepl (plain, TCLSH_PIPEREPL=1)" |
|
note "piperepl OK (plain): stock behaviour - no ::tclsh machinery with env unset or =1" |
|
} else { |
|
#punk kits: ACTIVE BY DEFAULT (machinery published), documented opt-out =0 |
|
asserteq $d_default tclshmachinery 1 "piperepl ($opt(-variant), env unset - default must be ON)" |
|
asserteq $d_default tclshreopened 0 "piperepl ($opt(-variant), env unset - reopened published 0 at start)" |
|
asserteq $d_optout tclshmachinery 0 "piperepl ($opt(-variant), TCLSH_PIPEREPL=0 opt-out)" |
|
asserteq $d_optout tclshreopened absent "piperepl ($opt(-variant), TCLSH_PIPEREPL=0 opt-out)" |
|
note "piperepl OK ($opt(-variant)): active by default (reopened published 0), disabled via TCLSH_PIPEREPL=0" |
|
} |
|
|
|
#-- probe: embedded artifact record (schema v2 - G-117 lineage + G-123 class) - |
|
set embed_script { |
|
proc out {k v} {puts [list CHECK $k $v]} |
|
proc rfield {rec k} { |
|
foreach line [split $rec \n] { |
|
set line [string trim $line] |
|
if {[regexp [format {^%s\s*=\s*"(.*)"\s*$} $k] $line -> v]} {return $v} |
|
if {[regexp [format {^%s\s*=\s*([0-9]+|true|false)\s*$} $k] $line -> v]} {return $v} |
|
} |
|
return "" |
|
} |
|
if {[catch {open //zipfs:/app/punkbin-artifact.toml r} f]} { |
|
out embed_exists 0 |
|
exit 0 |
|
} |
|
fconfigure $f -translation binary |
|
set rec [read $f] |
|
close $f |
|
out embed_exists 1 |
|
foreach k {schema variant tcl_patchlevel working_name name revision build_id piperepl origin packager project license build_host_platform} { |
|
out embed_$k [rfield $rec $k] |
|
} |
|
foreach line [split $rec \n] { |
|
set line [string trim $line] |
|
if {[string match "attached_batteries*" $line]} {out embed_batteries $line; break} |
|
} |
|
#G-123 schema v2: the flat rfield scan would see [artifact] class first (the |
|
#documented ordering caveat), so pin the [provenance] class as a literal line. |
|
out embed_provclass [expr {[string first {class = "suite-built"} $rec] >= 0}] |
|
exit 0 |
|
} |
|
set d [checks [probe embedrecord $embed_script]] |
|
asserteq $d embed_exists 1 "embedded record (G-117)" |
|
asserteq $d embed_schema 2 "embedded record" |
|
asserteq $d embed_provclass 1 "embedded record (\[provenance\] class = suite-built - G-123 schema v2)" |
|
asserteq $d embed_variant $opt(-variant) "embedded record" |
|
asserteq $d embed_tcl_patchlevel $opt(-expectpatch) "embedded record" |
|
asserteq $d embed_working_name $kitname "embedded record" |
|
asserteq $d embed_piperepl [expr {$opt(-variant) eq "plain" ? "false" : "true"}] "embedded record" |
|
if {[dict get $d embed_build_id] eq ""} {fail "embedded record: empty build_id"} |
|
foreach k {embed_origin embed_packager embed_project embed_license embed_build_host_platform} { |
|
if {![dict exists $d $k] || [dict get $d $k] eq ""} {fail "embedded record: missing v1 field [string range $k 6 end]"} |
|
} |
|
if {$opt(-expectrev) ne ""} { |
|
asserteq $d embed_revision $opt(-expectrev) "embedded record" |
|
if {[string match -nocase *.exe $kitname]} { |
|
set expname "[string range $kitname 0 end-4]-r$opt(-expectrev).exe" |
|
} else { |
|
set expname "$kitname-r$opt(-expectrev)" |
|
} |
|
asserteq $d embed_name $expname "embedded record" |
|
} |
|
set bl [expr {[dict exists $d embed_batteries] ? [dict get $d embed_batteries] : ""}] |
|
set expected_batteries [list Thread $opt(-thread) vfs $opt(-vfs) tcllib $opt(-tcllib) tcllibc $opt(-tcllib)] |
|
if {$opt(-variant) eq "punk-bi"} {lappend expected_batteries Tk $opt(-tk) tklib $opt(-tklib)} |
|
foreach {bn bv} $expected_batteries { |
|
if {[string first "\"$bn $bv\"" $bl] < 0} {fail "embedded record: attached_batteries missing '$bn $bv' (line: $bl)"} |
|
} |
|
note "embedded record OK: schema 2 (provenance class suite-built), name [dict get $d embed_name], build_id [dict get $d embed_build_id]" |
|
|
|
file delete -force $scratch |
|
puts "family_check OK: $opt(-variant) $kitname self-contained (scratch-dir probes, scrubbed env)" |
|
exit 0
|
|
|