#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