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.
9572 lines
519 KiB
9572 lines
519 KiB
# tcl |
|
# |
|
# punkboot - make any tclkits and modules in <projectdir>/src folders and place them and associated data files/scripts in the parent folder of src. |
|
#e.g in 'bin' and 'modules' folders at same level as 'src' folder. |
|
# --------------------------------------------------------------------------- |
|
# Terminal-aware colour/ANSI policy (G-113) - evaluated before any output. |
|
# Precedence: |
|
# 1. NO_COLOR set (any value) -> colour OFF (always wins; punk::ansi |
|
# NO_COLOR semantics: colour codes stripped, non-colour effects like bold |
|
# may remain when output goes to a terminal) |
|
# 2. PUNK_FORCE_COLOR / FORCE_COLOR set -> ANSI ON even when piped |
|
# (a value of 0/false/no/off is treated as not-set, per ecosystem convention) |
|
# 3. stdout tty probe -> colour ON only when stdout is a |
|
# terminal channel: -winsize option present (Tcl 8.7+/9 terminal channels, |
|
# mirroring the stdin_is_interactive -inputmode precedent), or - Tcl 8.6 on |
|
# windows - stdout -encoding reporting 'unicode' (utf-16), which only the |
|
# 8.6 windows console channel does (pipes/files get the system encoding). |
|
# Piped/redirected stdout (probe fails, no force) additionally pushes a strip |
|
# transform so the output is fully ESC-free - machine consumers get plain text |
|
# no matter which emitter produced it (punk::ansi's colour_disabled contract |
|
# deliberately retains non-colour SGR effects, and module-side emitters like |
|
# punkcheck summaries follow that contract - the transform is the single choke |
|
# point that guarantees zero ESC bytes). The push is PER CHANNEL and skips any |
|
# utf-16-class channel (a byte-level strip corrupts utf-16 - ESC arrives as |
|
# 1B 00; such a channel is an 8.6 console, i.e. a real terminal, and keeps its |
|
# ANSI) - e.g 'make.tcl ... > file' from an 8.6 console wraps stdout only. |
|
# Tcl 8.6 on unix has no boot-phase tty probe at all: the fail direction is |
|
# plain/OFF (safe for piped/captured agent runs - unlike stdin's |
|
# assume-interactive; use the force env vars for 8.6 unix interactive colour). |
|
# stderr colour follows the same single stdout-keyed decision. |
|
# The colour switch is ::punk::console::colour_disabled; when punk::ansi is |
|
# already loaded (punk-exe-hosted runs) its sgr cache is cleared per that |
|
# module's contract ("whatever function disables or re-enables colour should |
|
# have made a call to punk::ansi::sgr_cache -action clear"). |
|
# ::punkboot::colour_mode records the decision: one of |
|
# tty | forced | nocolor | piped-plain | tcl86-plain |
|
# --------------------------------------------------------------------------- |
|
namespace eval ::punkboot { |
|
variable colour_mode "" |
|
} |
|
namespace eval ::punkboot::ansistrip { |
|
#Write-side channel transform stripping all ANSI escape sequences (CSI incl. |
|
#SGR, OSC with BEL/ST terminators, and two-char ESC sequences). Handles |
|
#sequences split across write chunks via a per-channel carry buffer; an |
|
#unterminated sequence held at flush/finalize time is dropped (it is an |
|
#incomplete ANSI sequence - dropping it IS stripping it). |
|
variable carry [dict create] |
|
variable re_complete {\x1b(?:\[[0-9;:<=>?]*[ -/]*[@-~]|\][^\x07\x1b]*(?:\x07|\x1b\\)|[@-Z\\^_])} |
|
proc strip {chanid data} { |
|
variable carry |
|
variable re_complete |
|
if {[dict exists $carry $chanid]} { |
|
set data "[dict get $carry $chanid]$data" |
|
dict unset carry $chanid |
|
} |
|
#hold back a trailing incomplete escape sequence (conservative: from the |
|
#last ESC onward, if it is not a complete sequence it may be a prefix of |
|
#one still being written) |
|
set idx [string last \x1b $data] |
|
if {$idx >= 0} { |
|
set tail [string range $data $idx end] |
|
if {![regexp -- "^${re_complete}" $tail]} { |
|
dict set carry $chanid $tail |
|
set data [string range $data 0 $idx-1] |
|
} |
|
} |
|
regsub -all -- $re_complete $data {} data |
|
return $data |
|
} |
|
proc transchan {op chanid args} { |
|
variable carry |
|
switch -- $op { |
|
initialize { |
|
#G-145: `clear` is deliberately NOT declared. The Tcl core delivers |
|
#clear to the transform stack before EVERY write op (output-buffer |
|
#flush-down; tclIORTrans.c ReflectOutput, gated on METH_CLEAR) - core |
|
#behaviour that is intentional and test-pinned but under-documented |
|
#(doc/transchan.n and TIP 230 scope clear to seek/read-side buffers). |
|
#The old clear handler ran 'dict unset carry $chanid', discarding a |
|
#split sequence's held ESC tail at every chunk boundary; the next |
|
#chunk's ESC-less remainder ('0;1m' etc) then passed through |
|
#unstripped as orphan fragment text in piped help tables. This |
|
#transform is write-only with no read-side state, so its |
|
#contract-conformant clear is a no-op - not declaring it removes the |
|
#per-write calls entirely. finalize still drops the carry: an |
|
#incomplete sequence at end of stream is stripped by being dropped. |
|
return [list initialize finalize write flush] |
|
} |
|
write { |
|
return [strip $chanid [lindex $args 0]] |
|
} |
|
flush { |
|
return "" |
|
} |
|
finalize { |
|
dict unset carry $chanid |
|
return |
|
} |
|
} |
|
} |
|
} |
|
apply {{} { |
|
set force 0 |
|
foreach fvar {PUNK_FORCE_COLOR FORCE_COLOR} { |
|
if {[info exists ::env($fvar)] && $::env($fvar) ni {0 false FALSE no NO off OFF}} { |
|
set force 1 |
|
break |
|
} |
|
} |
|
set stdout_is_tty [expr {![catch {chan configure stdout -winsize}]}] |
|
if {!$stdout_is_tty && ![package vsatisfies [package provide Tcl] 8.7-]} { |
|
#Tcl 8.6 tty signatures (no -winsize/-inputmode exists pre-8.7): |
|
# - windows: 8.6's CONSOLE channels are the only ones that report |
|
# -encoding unicode (utf-16; pipes/files get the system encoding). This |
|
# both restores interactive colour on 8.6 consoles and is load-bearing |
|
# for the ansistrip transform below: the byte-level strip must never sit |
|
# on a utf-16 channel (ESC arrives as 1B 00 - sequences pass unstripped |
|
# and the hold-back logic defers/drops real content; field defect |
|
# 2026-07-25 mangling punk86/punksys console help output). |
|
# - unix-class (linux/WSL/mac AND msys2/cygwin-runtime builds, which report |
|
# tcl_platform(platform) unix even on a windows machine): the tty channel |
|
# type is isatty-gated and exposes the serial/tty options (-mode etc) on |
|
# real terminals only - pipes/files lack them. Verified: WSL 8.6.14 pty |
|
# -mode present / piped absent; msys2 8.6.12 interactive present / piped |
|
# absent. (-mode on a windows 8.6 stdout would mean a serial channel - |
|
# terminal-equivalent for colour purposes.) |
|
if {[chan configure stdout -encoding] eq "unicode"} { |
|
set stdout_is_tty 1 |
|
} elseif {![catch {chan configure stdout -mode}]} { |
|
set stdout_is_tty 1 |
|
} |
|
} |
|
if {[info exists ::env(NO_COLOR)]} { |
|
namespace eval ::punk::console {variable colour_disabled 1} |
|
set ::punkboot::colour_mode nocolor |
|
} elseif {$force} { |
|
namespace eval ::punk::console {variable colour_disabled 0} |
|
set ::punkboot::colour_mode forced |
|
} elseif {$stdout_is_tty} { |
|
namespace eval ::punk::console {variable colour_disabled 0} |
|
set ::punkboot::colour_mode tty |
|
} else { |
|
namespace eval ::punk::console {variable colour_disabled 1} |
|
if {[package vsatisfies [package provide Tcl] 8.7-]} { |
|
set ::punkboot::colour_mode piped-plain |
|
} else { |
|
set ::punkboot::colour_mode tcl86-plain |
|
} |
|
} |
|
#zero-ESC guarantee for piped/unknown output unless the caller forced ANSI on. |
|
#(NO_COLOR keeps punk::ansi's documented colour-only-stripping semantics on a |
|
#terminal; a NO_COLOR run with piped stdout still gets the full strip.) |
|
#Per-channel: a byte-level strip must never sit on a utf-16-class channel (the |
|
#8.6 windows console encoding) - e.g 'make.tcl ... > file' from an 8.6 console |
|
#leaves stderr ON the console; that channel is a real terminal, so it keeps its |
|
#ANSI rather than getting corrupted. ::punkboot::ansistrip_pushed records the |
|
#channels actually wrapped (the shell subcommand pops exactly those). |
|
set ::punkboot::ansistrip_pushed [list] |
|
if {!$force && !$stdout_is_tty} { |
|
foreach _ch {stdout stderr} { |
|
if {[chan configure $_ch -encoding] ni {unicode utf-16 utf-16le utf-16be}} { |
|
chan push $_ch ::punkboot::ansistrip::transchan |
|
lappend ::punkboot::ansistrip_pushed $_ch |
|
} |
|
} |
|
} |
|
#punk-exe-hosted runs arrive with punk::ansi pre-loaded and a warm sgr cache |
|
#generated under the kit's own colour state - honour the module's contract. |
|
if {[package provide punk::ansi] ne ""} { |
|
catch {punk::ansi::sgr_cache -action clear} |
|
} |
|
if {[info exists ::env(PUNKBOOT_COLOUR_DEBUG)]} { |
|
puts stderr "punkboot colour policy: mode=$::punkboot::colour_mode colour_disabled=$::punk::console::colour_disabled ansistrip=[expr {[llength $::punkboot::ansistrip_pushed] ? [join $::punkboot::ansistrip_pushed +] : 0}]" |
|
} |
|
}} |
|
# Colour-policy gate for raw-SGR emission sites that can run before |
|
# define_global_ansi / punk::ansi are available (early package-load |
|
# diagnostics and kit-bake warnings). Returns the SGR sequence, or an empty |
|
# string when colour is disabled. Empty/omitted params give the reset. |
|
proc ::punkboot::sgr {{sgrparams ""}} { |
|
if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { |
|
return "" |
|
} |
|
return "\x1b\[${sgrparams}m" |
|
} |
|
set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" |
|
puts $hashline |
|
puts " Punk Boot" |
|
puts $hashline\n |
|
|
|
package prefer latest |
|
lassign [split [info tclversion] .] tclmajorv tclminorv |
|
|
|
global A ;#UI Ansi code array |
|
array set A {} |
|
|
|
namespace eval ::punkboot { |
|
variable scriptfolder [file normalize [file dirname [info script]]] |
|
variable foldername [file tail $scriptfolder] |
|
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] |
|
variable help_flags [list -help --help /? -h] |
|
variable known_commands [list bakehouse packages modules libs bake bakelist vfslibs bin info check shell vendorupdate libfetch bootsupport vfscommonupdate projectversion workflow buildsuite tool] |
|
} |
|
|
|
|
|
|
|
namespace eval ::punkboot::lib { |
|
#for some purposes (whether a source folder is likely to have any useful content) we are interested in non dotfile/dotfolder immediate contents of a folder, but not whether a particular platform |
|
#considers them hidden or not. |
|
proc folder_nondotted_children {folder} { |
|
set normfolder [file normalize $folder] |
|
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_children error. Supplied folder '$folder' is not a directory"} |
|
set contents [glob -nocomplain -dir $folder -tails *] |
|
#some platforms (windows) return dotted entries with *, although most don't |
|
set nondotted_tails [lsearch -all -inline -not $contents .*] |
|
return [lmap ftail $nondotted_tails {file join $folder $ftail}] |
|
} |
|
proc folder_nondotted_folders {folder} { |
|
set normfolder [file normalize $folder] |
|
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_folders error. Supplied folder '$folder' is not a directory"} |
|
set contents [glob -nocomplain -dir $folder -types d -tails *] |
|
#some platforms (windows) return dotted entries with *, although most don't |
|
set nondotted_tails [lsearch -all -inline -not $contents .*] |
|
return [lmap ftail $nondotted_tails {file join $folder $ftail}] |
|
} |
|
proc folder_nondotted_files {folder} { |
|
set normfolder [file normalize $folder] |
|
if {![file isdirectory $normfolder]} {error "punkboot::lib::folder_nondotted_files error. Supplied folder '$folder' is not a directory"} |
|
set contents [glob -nocomplain -dir $folder -types f $folder -tails *] |
|
#some platforms (windows) return dotted entries with *, although most don't |
|
set nondotted_tails [lsearch -all -inline -not $contents .*] |
|
return [lmap ftail $nondotted_tails {file join $folder $ftail}] |
|
} |
|
proc tm_version_isvalid {versionpart} { |
|
#Needs to be suitable for use with Tcl's 'package vcompare' |
|
if {![catch [list package vcompare $versionpart $versionpart]]} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
proc tm_version_major {version} { |
|
if {![tm_version_isvalid $version]} { |
|
error "Invalid version '$version' is not a proper Tcl module version number" |
|
} |
|
set firstpart [lindex [split $version .] 0] |
|
#check for a/b in first segment |
|
if {[string is integer -strict $firstpart]} { |
|
return $firstpart |
|
} |
|
if {[string first a $firstpart] > 0} { |
|
return [lindex [split $firstpart a] 0] |
|
} |
|
if {[string first b $firstpart] > 0} { |
|
return [lindex [split $firstpart b] 0] |
|
} |
|
error "tm_version_major unable to determine major version from version number '$version'" |
|
} |
|
proc tm_version_canonical {ver} { |
|
#accepts a single valid version only - not a bounded or unbounded spec |
|
if {![tm_version_isvalid $ver]} { |
|
error "tm_version_canonical version '$ver' is not valid for a package version" |
|
} |
|
set parts [split $ver .] |
|
set newparts [list] |
|
foreach o $parts { |
|
set trimmed [string trimleft $o 0] |
|
set firstnonzero [string index $trimmed 0] |
|
switch -exact -- $firstnonzero { |
|
"" { |
|
lappend newparts 0 |
|
} |
|
a - b { |
|
#e.g 000bnnnn -> bnnnnn |
|
set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] |
|
if {$tailtrimmed eq ""} { |
|
set tailtrimmed 0 |
|
} |
|
lappend newparts 0$firstnonzero$tailtrimmed |
|
} |
|
default { |
|
#digit |
|
if {[string is integer -strict $trimmed]} { |
|
#e.g 0100 -> 100 |
|
lappend newparts $trimmed |
|
} else { |
|
#e.g 0100b003 -> 100b003 (still need to process tail) |
|
if {[set apos [string first a $trimmed]] > 0} { |
|
set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch |
|
set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits |
|
set rhs [string trimleft $rhs 0] |
|
if {$rhs eq ""} { |
|
set rhs 0 |
|
} |
|
lappend newparts ${lhs}a${rhs} |
|
} elseif {[set bpos [string first b $trimmed]] > 0} { |
|
set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch |
|
set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits |
|
set rhs [string trimleft $rhs 0] |
|
if {$rhs eq ""} { |
|
set rhs 0 |
|
} |
|
lappend newparts ${lhs}b${rhs} |
|
} else { |
|
#assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b |
|
error "tm_version_canonical error - trimfail - unexpected" |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return [join $newparts .] |
|
} |
|
proc tm_version_required_canonical {versionspec} { |
|
#also trim leading zero from any dottedpart? |
|
#Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. |
|
#e.g 1.01 is equivalent to 1.1 and 01.001 |
|
#also 1b3 == 1b0003 |
|
|
|
if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version |
|
set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification" |
|
if {[string first - $versionspec] < 0} { |
|
#no dash |
|
#looks like a minbounded version (ie a single version with no dash) convert to min-max form |
|
set from $versionspec |
|
if {![::punkboot::lib::tm_version_isvalid $from]} { |
|
error "$errmsg '$versionpec'" |
|
} |
|
if {![catch {::punkboot::lib::tm_version_major $from} majorv]} { |
|
set from [tm_version_canonical $from] |
|
return "${from}-[expr {$majorv +1}]" |
|
} else { |
|
error "$errmsg '$versionspec'" |
|
} |
|
} else { |
|
# min- or min-max |
|
#validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) |
|
set parts [split $versionspec -] ;#we expect only 2 parts |
|
lassign $parts from to |
|
if {![::punkboot::lib::tm_version_isvalid $from]} { |
|
error "$errmsg '$versionspec'" |
|
} |
|
set from [tm_version_canonical $from] |
|
if {[llength $parts] == 2} { |
|
if {$to ne ""} { |
|
if {![::punkboot::lib::tm_version_isvalid $to]} { |
|
error "$errmsg '$versionspec'" |
|
} |
|
set to [tm_version_canonical $to] |
|
return $from-$to |
|
} else { |
|
return $from- |
|
} |
|
} else { |
|
error "$errmsg '$versionspec'" |
|
} |
|
error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" |
|
} |
|
} |
|
#This is somewhat ugly - but we don't want to do any 'package require' operations at this stage |
|
# even for something that is available in tcl_library. |
|
#review |
|
proc platform_generic {} { |
|
#platform::generic - snipped straight from platform package |
|
global tcl_platform |
|
|
|
set plat [string tolower [lindex $tcl_platform(os) 0]] |
|
set cpu $tcl_platform(machine) |
|
|
|
switch -glob -- $cpu { |
|
sun4* { |
|
set cpu sparc |
|
} |
|
intel - |
|
ia32* - |
|
i*86* { |
|
set cpu ix86 |
|
} |
|
x86_64 { |
|
if {$tcl_platform(wordSize) == 4} { |
|
# See Example <1> at the top of this file. |
|
set cpu ix86 |
|
} |
|
} |
|
ppc - |
|
"Power*" { |
|
set cpu powerpc |
|
} |
|
"arm*" { |
|
set cpu arm |
|
} |
|
ia64 { |
|
if {$tcl_platform(wordSize) == 4} { |
|
append cpu _32 |
|
} |
|
} |
|
} |
|
|
|
switch -glob -- $plat { |
|
windows { |
|
if {$tcl_platform(platform) == "unix"} { |
|
set plat cygwin |
|
} else { |
|
set plat win32 |
|
} |
|
if {$cpu eq "amd64"} { |
|
# Do not check wordSize, win32-x64 is an IL32P64 platform. |
|
set cpu x86_64 |
|
} |
|
} |
|
sunos { |
|
set plat solaris |
|
if {[string match "ix86" $cpu]} { |
|
if {$tcl_platform(wordSize) == 8} { |
|
set cpu x86_64 |
|
} |
|
} elseif {![string match "ia64*" $cpu]} { |
|
# sparc |
|
if {$tcl_platform(wordSize) == 8} { |
|
append cpu 64 |
|
} |
|
} |
|
} |
|
darwin { |
|
set plat macosx |
|
# Correctly identify the cpu when running as a 64bit |
|
# process on a machine with a 32bit kernel |
|
if {$cpu eq "ix86"} { |
|
if {$tcl_platform(wordSize) == 8} { |
|
set cpu x86_64 |
|
} |
|
} |
|
} |
|
aix { |
|
set cpu powerpc |
|
if {$tcl_platform(wordSize) == 8} { |
|
append cpu 64 |
|
} |
|
} |
|
hp-ux { |
|
set plat hpux |
|
if {![string match "ia64*" $cpu]} { |
|
set cpu parisc |
|
if {$tcl_platform(wordSize) == 8} { |
|
append cpu 64 |
|
} |
|
} |
|
} |
|
osf1 { |
|
set plat tru64 |
|
} |
|
default { |
|
set plat [lindex [split $plat _-] 0] |
|
} |
|
} |
|
|
|
return "${plat}-${cpu}" |
|
} |
|
proc platform_normalize_os {os} { |
|
#INLINE COPY of punk::platform::normalize_os - see platform_punk below. |
|
switch -glob -- [string tolower $os] { |
|
macos {return macosx} |
|
msys - msys_nt-* {return msys} |
|
mingw32 - mingw64 - mingw_nt-* - mingw32_nt-* - mingw64_nt-* {return msys} |
|
ucrt64 - ucrt64_nt-* {return msys} |
|
clang32 - clang64 - clangarm64 - clang32_nt-* - clang64_nt-* - clangarm64_nt-* {return msys} |
|
cygwin_nt-* {return cygwin} |
|
} |
|
return $os |
|
} |
|
proc platform_punk {} { |
|
#canonical punkshell platform-dir name: platform_generic normalized. |
|
#INLINE COPY of punk::platform::normalize (src/modules/punk/platform-*.tm; |
|
#'help platforms' documents the canon) - the boot stage cannot package |
|
#require, so keep this mapping in sync with that module: |
|
#amd64->x86_64, aarch64->arm64, macos->macosx, macosx arm->arm64, |
|
#msys2 family (mingw64/mingw32/ucrt64/clang*) -> msys, CYGWIN_NT -> cygwin. |
|
set parts [split [platform_generic] -] |
|
set cpu [lindex $parts end] |
|
set os [join [lrange $parts 0 end-1] -] |
|
set os [platform_normalize_os $os] |
|
switch -- $cpu { |
|
amd64 {set cpu x86_64} |
|
aarch64 {set cpu arm64} |
|
arm {if {$os eq "macosx"} {set cpu arm64}} |
|
} |
|
return "${os}-${cpu}" |
|
} |
|
|
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
# G-122 host/target platform split. |
|
# platform_punk answers "what is THIS tclsh" (the HOST canon). Everything a |
|
# bake EMITS is a separate question keyed by TARGET: which bin/runtime/<tier> |
|
# store holds the runtime, whether artifacts carry .exe, and which process |
|
# tooling can see/kill a running artifact. The two diverge for the whole |
|
# cygwin family: an msys2/cygwin-runtime tclsh on windows reports |
|
# tcl_platform(platform) 'unix' and canonizes as msys-x86_64/cygwin-x86_64, |
|
# yet the kits it bakes are ordinary win32-x86_64 .exe binaries that only |
|
# tasklist/taskkill can manage (msys 'ps' sees only msys-descendant |
|
# processes). Host process semantics - copy commands, path handling, prompts, |
|
# filesystem case rules - stay keyed to the host. |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
#os token of a canonical platform-dir name (win32-x86_64 -> win32; macosx -> macosx) |
|
proc platform_os {platform} { |
|
set parts [split $platform -] |
|
if {[llength $parts] < 2} { |
|
return $platform |
|
} |
|
return [join [lrange $parts 0 end-1] -] |
|
} |
|
#cpu token of a canonical platform-dir name ("" for single-token names like macosx) |
|
proc platform_cpu {platform} { |
|
set parts [split $platform -] |
|
if {[llength $parts] < 2} { |
|
return "" |
|
} |
|
return [lindex $parts end] |
|
} |
|
#posix-personality runtimes hosted on windows (msys2 / cygwin) |
|
proc platform_is_cygwin_family {platform} { |
|
return [expr {[platform_os $platform] in {msys cygwin}}] |
|
} |
|
#Windows-family platforms: native win32 AND the cygwin-family personalities. |
|
#They share what matters to a bake: executables are .exe files and running |
|
#processes are windows processes (tasklist/taskkill), whatever tcl_platform says. |
|
proc platform_is_windows_family {platform} { |
|
return [expr {[platform_os $platform] in {win32 msys cygwin}}] |
|
} |
|
#Default TARGET platform for a host canon. A cygwin-family host bakes native |
|
#windows kits (there is no separate msys kit lineage - third-party msys |
|
#runtimes are addressed by an explicit per-entry target instead). |
|
proc platform_target_default {hostplatform} { |
|
if {[platform_is_cygwin_family $hostplatform]} { |
|
set cpu [platform_cpu $hostplatform] |
|
if {$cpu eq ""} {set cpu x86_64} |
|
return "win32-$cpu" |
|
} |
|
return $hostplatform |
|
} |
|
#bin/runtime store tier folder name for a target: macOS runtimes are universal |
|
#(multi-arch) binaries kept in one 'macosx' folder - see punk::platform. |
|
proc platform_store_tier {target} { |
|
if {[string match "macosx-*" $target]} { |
|
return macosx |
|
} |
|
return $target |
|
} |
|
#executable filename suffix artifacts for this target carry |
|
proc platform_exe_suffix {target} { |
|
if {[platform_is_windows_family $target]} { |
|
return ".exe" |
|
} |
|
return "" |
|
} |
|
#which process tooling manages a running artifact of this platform |
|
proc platform_process_family {platform} { |
|
if {[platform_is_windows_family $platform]} { |
|
return windows |
|
} |
|
return posix |
|
} |
|
#A target platform name must look like a platform-dir name so it can address a |
|
#store tier. Returns "" when acceptable, else a reason string. |
|
proc platform_name_problem {platform} { |
|
if {$platform eq ""} { |
|
return "empty" |
|
} |
|
if {[regexp {[\\/:*?\"<>|]} $platform]} { |
|
return "not a platform-dir name (contains a path/wildcard character)" |
|
} |
|
if {[llength [split $platform -]] < 2 && $platform ne "macosx"} { |
|
return "not an <os>-<cpu> platform-dir name ('help platforms' lists the canon)" |
|
} |
|
return "" |
|
} |
|
} |
|
|
|
#------------------------------------------------------------------------------ |
|
# Bootsupport staleness helpers — self-contained Tcl, no punk package deps. |
|
# These run in the early boot phase before punk packages are guaranteed loaded |
|
# (modeled on punk::lib::askuser but without punk::console / raw-mode deps). |
|
#------------------------------------------------------------------------------ |
|
|
|
# Classify the version delta between an old (bootsupport) and new (source) |
|
# semver as "major", "minor", or "patch". |
|
# Caller must verify new_ver > old_ver via `package vcompare` first. |
|
proc ::punkboot::lib::bootsupport_bump_level {old_ver new_ver} { |
|
set op [split $old_ver .] |
|
set np [split $new_ver .] |
|
while {[llength $op] < 3} {lappend op 0} |
|
while {[llength $np] < 3} {lappend np 0} |
|
set op [lmap s $op { |
|
set n [scan $s %d] |
|
expr {[string is integer -strict $n] ? $n : 0} |
|
}] |
|
set np [lmap s $np { |
|
set n [scan $s %d] |
|
expr {[string is integer -strict $n] ? $n : 0} |
|
}] |
|
lassign $op o_major o_minor o_patch |
|
lassign $np n_major n_minor n_patch |
|
if {$n_major > $o_major} {return "major"} |
|
if {$n_minor > $o_minor} {return "minor"} |
|
return "patch" |
|
} |
|
|
|
# stdin interactivity probe for the confirmation-prompt policy (G-030). |
|
# Tcl 8.7+/9: -inputmode is supported only on terminal channels, so a successful |
|
# query means stdin is a console. Under Tcl 8.6 there is no -inputmode anywhere and |
|
# no reliable pure-Tcl tty test in the boot phase - we return 1 (assume interactive, |
|
# the pre-G-030 behaviour of reading stdin) so a real 8.6 console still gets its |
|
# prompt. Piped/non-interactive runs under 8.6 should pass -confirm explicitly. |
|
proc ::punkboot::lib::stdin_is_interactive {} { |
|
if {![catch {chan configure stdin -inputmode}]} { |
|
return 1 |
|
} |
|
if {[package vsatisfies [package provide Tcl] 8.7-]} { |
|
return 0 |
|
} |
|
return 1 |
|
} |
|
|
|
# Self-contained y/N prompt. Returns 1 for y/yes (case-insensitive), 0 otherwise. |
|
# Used by the staleness abort path to ask the user whether to proceed past a |
|
# minor-version bump. Default is No (Enter = abort) so accidental Enter is safe. |
|
proc ::punkboot::lib::bootsupport_prompt_yesno {prompt} { |
|
puts stdout $prompt |
|
puts -nonewline stdout "Proceed anyway? (y/N) " |
|
flush stdout |
|
set stdin_state [chan configure stdin] |
|
try { |
|
chan configure stdin -blocking 1 |
|
set answer [string tolower [string trim [gets stdin]]] |
|
} finally { |
|
chan configure stdin -blocking [dict get $stdin_state -blocking] |
|
} |
|
return [expr {$answer eq "y" || $answer eq "yes"}] |
|
} |
|
|
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
# Parsed kit-mapping model (G-121). One reader family for the kit-output mapping |
|
# config - the 'bake' kit machinery, the 'bakelist' report and the bake/bakelist |
|
# argdoc choices all consume the model these helpers return, never the file |
|
# format directly. G-024: the canonical format is src/runtime/mapvfs.toml |
|
# (tomlish-parsed [kit.<name>] / [group.<name>] / [scheme.<name>] tables - the |
|
# file's own header comment is the user-facing spec); the pre-G-024 line format |
|
# src/runtime/mapvfs.config remains readable as a DEPRECATED fallback so |
|
# un-migrated trees (older generated projects) keep baking. mapvfs_locate picks |
|
# the file (toml wins when both exist); mapvfs_parse dispatches on extension. |
|
# |
|
# mapvfs_parse: pure parse - no output, no exits. Every store address, presence |
|
# probe and artifact suffix it computes is keyed by the entry's TARGET platform |
|
# (G-122), never by the driving tclsh's personality: $rtbase is the store ROOT |
|
# (bin/runtime) and each entry addresses $rtbase/<its own tier>. Returns a dict: |
|
# exists 0|1 (mapfile present) |
|
# mapfile path as supplied |
|
# format toml|legacy (which reader produced the model) |
|
# default_target target platform for entries that declare none |
|
# runtime_vfs_map runtime -> list of vfs_specs. legacy: raw specs as listed |
|
# (appname/type/target may be ""). toml: normalized 6-element |
|
# specs {vfstail appname type target smokerequires attrs} |
|
# vfs_runtime_map vfstail -> list of {runtime appname type target smokerequires |
|
# ?attrs?} (defaults applied; only vfs folders that exist on |
|
# disk - matching the historical inline parse the kit loop was |
|
# built around; smokerequires is the G-133 smoke-require package |
|
# list, may be ""). attrs (6th element, toml models only - read |
|
# via mapvfs_spec_attrs) is a dict: entry (config table label |
|
# e.g kit.punk91), group, bake_default, scheme, scheme_role. |
|
# runtime_target runtime -> resolved target platform (all runtimes, mapped order) |
|
# groups group name -> {description <text> bake_default 0|1} (toml only) |
|
# missing names of referenced-but-absent runtimes/vfs folders |
|
# missing_detail structured missing items (toml only): list of dicts |
|
# {kind runtime|vfs label <entry> name <item> target <platform>} |
|
# - the bake path's strict per-entry failure reporting (G-024) |
|
# warnings warning lines in encounter order, ready to print verbatim |
|
# (missing-item lines carry their historical WARNING: prefix) |
|
# badentries subset of warnings: malformed entry lines (these have no kit |
|
# record to carry them, so bakelist prints them; missing-item |
|
# warnings are instead surfaced as per-row state there) |
|
# configerrors fatal config problems (malformed/unresolvable declarations, |
|
# each naming its entry; duplicate runtime line; unusable or |
|
# self-contradicting target platform; caller decides whether to |
|
# abort - the bake path keeps its historical exit 3) |
|
|
|
# Locate the kit-mapping config for a src/runtime folder (G-024). |
|
# Precedence: PUNK_MAPVFS_CONFIG env override (test/characterization seam - an |
|
# alternate config exercised without editing the real one; relative paths |
|
# resolve against the runtime folder), then mapvfs.toml, then the deprecated |
|
# mapvfs.config. When neither exists the toml name is returned so no-mapping |
|
# messages name the current format. |
|
proc ::punkboot::lib::mapvfs_locate {rt_sourcefolder} { |
|
if {[info exists ::env(PUNK_MAPVFS_CONFIG)] && $::env(PUNK_MAPVFS_CONFIG) ne ""} { |
|
set override $::env(PUNK_MAPVFS_CONFIG) |
|
if {[file pathtype $override] ne "absolute"} { |
|
set override [file join $rt_sourcefolder $override] |
|
} |
|
return $override |
|
} |
|
if {[file exists $rt_sourcefolder/mapvfs.toml]} { |
|
return $rt_sourcefolder/mapvfs.toml |
|
} |
|
if {[file exists $rt_sourcefolder/mapvfs.config]} { |
|
return $rt_sourcefolder/mapvfs.config |
|
} |
|
return $rt_sourcefolder/mapvfs.toml |
|
} |
|
|
|
#tomlish::to_dict values are type-tagged (e.g {type STRING value x}, {type ARRAY value {...}}); |
|
#tables are plain nested dicts. Shared by the mapvfs toml reader, the per-.vfs |
|
#payload declarations (G-115) and any other bake-side toml consumption. |
|
proc ::punkboot::lib::toml_untag {tagged} { |
|
if {[dict get $tagged type] eq "ARRAY"} { |
|
set plain [list] |
|
foreach el [dict get $tagged value] { |
|
lappend plain [::punkboot::lib::toml_untag $el] |
|
} |
|
return $plain |
|
} |
|
return [dict get $tagged value] |
|
} |
|
|
|
# Read + parse a toml file via tomlish. Returns {ok <dict>} or {error <message>}. |
|
proc ::punkboot::lib::toml_file_to_dict {path} { |
|
if {[catch {package require tomlish} tomlish_err]} { |
|
return [list error "tomlish package unavailable ($tomlish_err)"] |
|
} |
|
if {[catch { |
|
set fd [open $path r] |
|
fconfigure $fd -encoding utf-8 |
|
set tomldata [read $fd] |
|
close $fd |
|
} readerr]} { |
|
catch {close $fd} |
|
return [list error "cannot read $path ($readerr)"] |
|
} |
|
if {[catch {tomlish::to_dict [tomlish::from_toml $tomldata]} parsed]} { |
|
return [list error "toml parse failed for $path\n$parsed"] |
|
} |
|
return [list ok $parsed] |
|
} |
|
|
|
# attrs element of a parsed vfs_spec tuple (6th element, toml models). Legacy |
|
# models carry no attrs - callers get an empty dict and defaults apply |
|
# (group "", bake_default 1, no scheme role). |
|
proc ::punkboot::lib::mapvfs_spec_attrs {vfs_spec} { |
|
if {[llength $vfs_spec] >= 6} { |
|
return [lindex $vfs_spec 5] |
|
} |
|
return [dict create] |
|
} |
|
|
|
proc ::punkboot::lib::mapvfs_model_new {mapfile default_target format} { |
|
return [dict create\ |
|
exists 0\ |
|
mapfile $mapfile\ |
|
format $format\ |
|
default_target $default_target\ |
|
runtime_vfs_map [dict create]\ |
|
vfs_runtime_map [dict create]\ |
|
runtime_target [dict create]\ |
|
groups [dict create]\ |
|
missing [list]\ |
|
missing_detail [list]\ |
|
warnings [list]\ |
|
badentries [list]\ |
|
configerrors [list]\ |
|
] |
|
} |
|
|
|
proc ::punkboot::lib::mapvfs_parse {mapfile rtbase sourcefolder default_target} { |
|
if {[string tolower [file extension $mapfile]] eq ".toml"} { |
|
return [mapvfs_parse_toml $mapfile $rtbase $sourcefolder $default_target] |
|
} |
|
return [mapvfs_parse_config $mapfile $rtbase $sourcefolder $default_target] |
|
} |
|
|
|
# Memoized front door: locate + parse once per distinct (mapfile, rtbase, |
|
# sourcefolder, target) tuple within a make.tcl invocation (2026-08-02 |
|
# consolidation) - the define-time kitname choices and every handler consume |
|
# the SAME model. mapvfs_parse is pure (no output/exits), so cached and fresh |
|
# models are interchangeable; config edits during a single run are outside the |
|
# contract. A THROWING locate/parse is deliberately not cached: each caller's |
|
# attempt diagnoses fresh (identical text for a persistent problem), and the |
|
# choices computation catches its attempt while the handlers report theirs. |
|
# The mapfile is part of the key, so a PUNK_MAPVFS_CONFIG override keys |
|
# distinctly from the tree's own config. |
|
namespace eval ::punkboot::lib { |
|
variable mapvfs_model_cache [dict create] |
|
} |
|
proc ::punkboot::lib::mapvfs_model {rt_sourcefolder rtbase sourcefolder default_target} { |
|
variable mapvfs_model_cache |
|
set mapfile [mapvfs_locate $rt_sourcefolder] |
|
set key [list $mapfile $rtbase $sourcefolder $default_target] |
|
if {![dict exists $mapvfs_model_cache $key]} { |
|
dict set mapvfs_model_cache $key [mapvfs_parse $mapfile $rtbase $sourcefolder $default_target] |
|
} |
|
return [dict get $mapvfs_model_cache $key] |
|
} |
|
|
|
# G-024 canonical reader: mapvfs.toml. Strict per-entry validation - a malformed |
|
# or unresolvable declaration lands in configerrors naming its table (the bake |
|
# path aborts on configerrors; missing-on-disk runtime/vfs items land in |
|
# warnings + missing_detail and the bake path decides fatality per entry). |
|
proc ::punkboot::lib::mapvfs_parse_toml {mapfile rtbase sourcefolder default_target} { |
|
set model [mapvfs_model_new $mapfile $default_target toml] |
|
if {![file exists $mapfile]} { |
|
return $model |
|
} |
|
dict set model exists 1 |
|
set legacy_sibling [file join [file dirname $mapfile] mapvfs.config] |
|
if {[file exists $legacy_sibling] && [file tail $mapfile] eq "mapvfs.toml"} { |
|
dict lappend model warnings "NOTE: both mapvfs.toml and mapvfs.config present in [file dirname $mapfile] - mapvfs.toml wins and the deprecated mapvfs.config is ignored (remove it, or keep it only as reference)." |
|
} |
|
lassign [toml_file_to_dict $mapfile] tstatus tpayload |
|
if {$tstatus ne "ok"} { |
|
dict lappend model configerrors "CONFIG FILE ERROR. $mapfile: $tpayload" |
|
return $model |
|
} |
|
set kit_types [list kit zip zipcat cookit cookfs] |
|
set groups [dict create] |
|
set configerrors [list] |
|
set warnings [list] |
|
set missing [list] |
|
set missing_detail [list] |
|
#top-level tables: kit / group / scheme only |
|
dict for {topkey -} $tpayload { |
|
if {$topkey ni {kit group scheme}} { |
|
lappend configerrors "CONFIG FILE ERROR. $mapfile: unknown top-level table or key '$topkey' (expected \[kit.<name>\], \[group.<name>\], \[scheme.<name>\])" |
|
} |
|
} |
|
#-- groups |
|
if {[dict exists $tpayload group]} { |
|
dict for {gname gentry} [dict get $tpayload group] { |
|
set label "group.$gname" |
|
set gdesc "" |
|
set gdefault 1 |
|
dict for {k v} $gentry { |
|
switch -- $k { |
|
description {set gdesc [toml_untag $v]} |
|
bake_default { |
|
set gdefault [toml_untag $v] |
|
if {![string is boolean -strict $gdefault]} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile: 'bake_default' must be boolean (got '$gdefault')" |
|
set gdefault 1 |
|
} |
|
} |
|
default { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile: unknown key '$k' (expected description, bake_default)" |
|
} |
|
} |
|
} |
|
dict set groups $gname [dict create description $gdesc bake_default [expr {bool($gdefault)}]] |
|
} |
|
} |
|
#-- normalized candidate entries: {label rtname vfstail appname kittype declared_target smokes attrs} |
|
set entries [list] |
|
set appnames_seen [dict create] ;#appname -> label |
|
set entry_reader {{model_varname label entry required_type} { |
|
#shared [kit.*]/[scheme.*] field reader; returns a dict or empty on fatal field errors |
|
upvar 1 configerrors configerrors kit_types kit_types groups groups mapfile mapfile |
|
set fields [dict create runtime "" vfs "" type "" target "" smokerequire [list] group "" bake_default "" scheme "" prefix ""] |
|
set badentry 0 |
|
dict for {k v} $entry { |
|
switch -- $k { |
|
runtime - vfs - type - target - group - scheme - prefix { |
|
dict set fields $k [::punkboot::lib::toml_untag $v] |
|
} |
|
smokerequire { |
|
if {[dict get $v type] eq "ARRAY"} { |
|
dict set fields smokerequire [::punkboot::lib::toml_untag $v] |
|
} else { |
|
dict set fields smokerequire [list [::punkboot::lib::toml_untag $v]] |
|
} |
|
} |
|
bake_default { |
|
set bd [::punkboot::lib::toml_untag $v] |
|
if {![string is boolean -strict $bd]} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile: 'bake_default' must be boolean (got '$bd')" |
|
set badentry 1 |
|
} else { |
|
dict set fields bake_default [expr {bool($bd)}] |
|
} |
|
} |
|
default { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile: unknown key '$k'" |
|
set badentry 1 |
|
} |
|
} |
|
} |
|
foreach reqkey {runtime vfs} { |
|
if {[dict get $fields $reqkey] eq ""} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile is missing required key '$reqkey'" |
|
set badentry 1 |
|
} |
|
} |
|
set ktype [dict get $fields type] |
|
if {$ktype eq ""} { |
|
if {$required_type} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile is missing required key 'type' (scheme entries declare their kit type explicitly; one of: [join $kit_types {, }])" |
|
set badentry 1 |
|
} else { |
|
dict set fields type kit |
|
} |
|
} elseif {$ktype ni $kit_types} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile: unknown kit type '$ktype' (expected one of: [join $kit_types {, }])" |
|
set badentry 1 |
|
} |
|
set declared [dict get $fields target] |
|
if {$declared ne ""} { |
|
set problem [::punkboot::lib::platform_name_problem $declared] |
|
if {$problem ne ""} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile declares target platform '$declared' - $problem." |
|
set badentry 1 |
|
} |
|
} |
|
#strip a superfluous windows .exe from the runtime name (legacy-format parity) |
|
set rtname [dict get $fields runtime] |
|
if {[string match -nocase *.exe $rtname]} { |
|
dict set fields runtime [string range $rtname 0 end-4] |
|
} |
|
set g [dict get $fields group] |
|
if {$g ne "" && ![dict exists $groups $g]} { |
|
#a group referenced without its own [group.<name>] table is implicitly plain |
|
dict set groups $g [dict create description "" bake_default 1] |
|
} |
|
if {$badentry} { |
|
return [dict create] |
|
} |
|
return $fields |
|
}} |
|
if {[dict exists $tpayload kit]} { |
|
dict for {kname kentry} [dict get $tpayload kit] { |
|
set label "kit.$kname" |
|
set fields [apply $entry_reader model $label $kentry 0] |
|
if {![dict size $fields]} { |
|
continue |
|
} |
|
foreach badkey {scheme prefix} { |
|
if {[dict get $fields $badkey] ne ""} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile: key '$badkey' is only valid in \[scheme.<name>\] entries" |
|
} |
|
} |
|
set g [dict get $fields group] |
|
set bd [dict get $fields bake_default] |
|
if {$bd eq ""} { |
|
set bd [expr {$g ne "" ? [dict get $groups $g bake_default] : 1}] |
|
} |
|
if {[dict exists $appnames_seen $kname]} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile: output name '$kname' already produced by [dict get $appnames_seen $kname]" |
|
continue |
|
} |
|
dict set appnames_seen $kname $label |
|
lappend entries [list $label [dict get $fields runtime] [dict get $fields vfs] $kname\ |
|
[dict get $fields type] [dict get $fields target] [dict get $fields smokerequire]\ |
|
[dict create entry $label group $g bake_default $bd scheme "" scheme_role ""]] |
|
} |
|
} |
|
#-- schemes (G-023/G-024: generative entries expanded at parse time - no version enumeration) |
|
set project_version "" |
|
set project_version_err "" |
|
if {[dict exists $tpayload scheme]} { |
|
dict for {sname sentry} [dict get $tpayload scheme] { |
|
set label "scheme.$sname" |
|
set fields [apply $entry_reader model $label $sentry 1] |
|
if {![dict size $fields]} { |
|
continue |
|
} |
|
set skind [dict get $fields scheme] |
|
if {$skind eq ""} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile is missing required key 'scheme' (known schemes: versioned)" |
|
continue |
|
} |
|
if {$skind ne "versioned"} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile: unknown scheme '$skind' (known schemes: versioned)" |
|
continue |
|
} |
|
#versioned scheme (G-023): output names derive from the punkproject.toml |
|
#project version at parse time - punk<gen>-<version>, punk<gen>-dev and the |
|
#release-gated plain punk<gen> - so one declaration tracks the version with |
|
#no per-version config edits. |
|
if {$project_version eq "" && $project_version_err eq ""} { |
|
set pptoml [file join [file dirname $sourcefolder] punkproject.toml] |
|
lassign [toml_file_to_dict $pptoml] pstatus ppayload |
|
if {$pstatus ne "ok"} { |
|
set project_version_err $ppayload |
|
} elseif {[catch {toml_untag [dict get $ppayload project version]} pver]} { |
|
set project_version_err "no \[project\] version field readable in $pptoml ($pver)" |
|
} elseif {$pver eq ""} { |
|
set project_version_err "empty \[project\] version field in $pptoml" |
|
} else { |
|
set project_version $pver |
|
} |
|
} |
|
if {$project_version eq ""} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile: cannot expand 'versioned' scheme - $project_version_err" |
|
continue |
|
} |
|
set prefix [dict get $fields prefix] |
|
if {$prefix eq ""} { |
|
set prefix $sname |
|
} |
|
set g [dict get $fields group] |
|
set bd [dict get $fields bake_default] |
|
if {$bd eq ""} { |
|
set bd [expr {$g ne "" ? [dict get $groups $g bake_default] : 1}] |
|
} |
|
foreach {appname role} [list ${prefix}-$project_version versioned ${prefix}-dev dev $prefix release] { |
|
if {[dict exists $appnames_seen $appname]} { |
|
lappend configerrors "CONFIG FILE ERROR. entry $label in $mapfile: expanded output name '$appname' already produced by [dict get $appnames_seen $appname]" |
|
continue |
|
} |
|
dict set appnames_seen $appname $label |
|
lappend entries [list "$label ($role)" [dict get $fields runtime] [dict get $fields vfs] $appname\ |
|
[dict get $fields type] [dict get $fields target] [dict get $fields smokerequire]\ |
|
[dict create entry $label group $g bake_default $bd scheme $sname scheme_role $role]] |
|
} |
|
} |
|
} |
|
#-- per-runtime target resolution (target is a property of the RUNTIME - entries |
|
#may repeat the declaration but must not disagree; legacy-format parity) |
|
set runtime_target [dict create] |
|
set runtime_first_label [dict create] |
|
foreach e $entries { |
|
lassign $e label rtname - - - declared - - |
|
if {![dict exists $runtime_first_label $rtname]} { |
|
dict set runtime_first_label $rtname $label |
|
} |
|
if {$declared eq ""} { |
|
continue |
|
} |
|
if {![dict exists $runtime_target $rtname] || [dict get $runtime_target $rtname] eq $default_target} { |
|
dict set runtime_target $rtname $declared |
|
} elseif {[dict get $runtime_target $rtname] ne $declared} { |
|
lappend configerrors "CONFIG FILE ERROR. runtime: $rtname declares conflicting target platforms ('[dict get $runtime_target $rtname]' and '$declared') in $mapfile - a runtime has one target." |
|
} |
|
} |
|
foreach rtname [dict keys $runtime_first_label] { |
|
if {![dict exists $runtime_target $rtname]} { |
|
dict set runtime_target $rtname $default_target |
|
} |
|
} |
|
#-- runtime presence (one check per runtime, in first-reference order) |
|
foreach rtname [dict keys $runtime_first_label] { |
|
if {$rtname eq "-"} { |
|
continue |
|
} |
|
set rt_target [dict get $runtime_target $rtname] |
|
set rtdir [file join $rtbase [platform_store_tier $rt_target]] |
|
set runtime_test $rtname[platform_exe_suffix $rt_target] |
|
if {![file exists [file join $rtdir $runtime_test]]} { |
|
lappend warnings "WARNING: Missing runtime file $rtdir/$runtime_test (entry [dict get $runtime_first_label $rtname] in $mapfile)" |
|
lappend missing $rtname |
|
lappend missing_detail [dict create kind runtime label [dict get $runtime_first_label $rtname] name $rtname target $rt_target] |
|
} |
|
} |
|
#-- build the maps (entry order preserved; vfs existence filtering matches the |
|
#historical inline parse the kit loop was built around) |
|
set runtime_vfs_map [dict create] |
|
set vfs_runtime_map [dict create] |
|
foreach e $entries { |
|
lassign $e label rtname vfstail appname kittype - smokes attrs |
|
set rt_target [dict get $runtime_target $rtname] |
|
set spec [list $vfstail $appname $kittype $rt_target $smokes $attrs] |
|
dict lappend runtime_vfs_map $rtname $spec |
|
if {![file isdirectory [file join $sourcefolder vfs $vfstail]]} { |
|
lappend warnings "WARNING: Missing vfs folder [file join $sourcefolder vfs $vfstail] specified in $mapfile for entry $label" |
|
if {$vfstail ni $missing} { |
|
lappend missing $vfstail |
|
} |
|
lappend missing_detail [dict create kind vfs label $label name $vfstail target $rt_target] |
|
} else { |
|
dict lappend vfs_runtime_map $vfstail [list $rtname $appname $kittype $rt_target $smokes $attrs] |
|
} |
|
} |
|
dict set model runtime_vfs_map $runtime_vfs_map |
|
dict set model vfs_runtime_map $vfs_runtime_map |
|
dict set model runtime_target $runtime_target |
|
dict set model groups $groups |
|
dict set model missing $missing |
|
dict set model missing_detail $missing_detail |
|
dict set model warnings [concat [dict get $model warnings] $warnings] |
|
dict set model configerrors $configerrors |
|
return $model |
|
} |
|
|
|
# DEPRECATED legacy reader: the pre-G-024 mapvfs.config line format |
|
# (<runtime> {vfsfolder ?kitname? ?kittype? ?targetplatform? ?smokerequires?} ...). |
|
# Kept so un-migrated trees (older generated projects) keep baking; behaviour is |
|
# unchanged from before the toml conversion apart from the deprecation NOTE. |
|
proc ::punkboot::lib::mapvfs_parse_config {mapfile rtbase sourcefolder default_target} { |
|
set model [mapvfs_model_new $mapfile $default_target legacy] |
|
if {![file exists $mapfile]} { |
|
return $model |
|
} |
|
dict set model exists 1 |
|
dict lappend model warnings "NOTE: $mapfile uses the deprecated mapvfs.config line format - convert to mapvfs.toml (the file header of src/runtime/mapvfs.toml in the punkshell tree is the format spec; when both files exist the toml file wins)." |
|
set fdmap [open $mapfile r] |
|
fconfigure $fdmap -translation binary |
|
set mapdata [read $fdmap] |
|
close $fdmap |
|
set mapdata [string map [list \r\n \n] $mapdata] |
|
set runtime_vfs_map [dict create] |
|
set vfs_runtime_map [dict create] |
|
set runtime_target [dict create] |
|
set missing [list] |
|
set warnings [list] |
|
set badentries [list] |
|
set configerrors [list] |
|
foreach ln [split $mapdata \n] { |
|
set ln [string trim $ln] |
|
if {$ln eq "" || [string match #* $ln]} { |
|
continue |
|
} |
|
set vfs_specs [lassign $ln runtime] |
|
if {[string match *.exe $runtime]} { |
|
#.exe is superfluous but allowed |
|
#drop windows .exe suffix so same config can work cross platform - extension will be re-added if necessary later |
|
set runtime [string range $runtime 0 end-4] |
|
} |
|
#Target platform is declared per kit-config entry (4th element) but is a |
|
#property of the RUNTIME: one binary lives in one store tier and has one |
|
#executable convention. Entries on a line may therefore repeat the |
|
#declaration but must not disagree. |
|
set line_target "" |
|
foreach vfsconfig $vfs_specs { |
|
if {[llength $vfsconfig] < 4} { |
|
continue |
|
} |
|
set declared [lindex $vfsconfig 3] |
|
if {$declared eq ""} { |
|
continue |
|
} |
|
if {$line_target eq ""} { |
|
set problem [platform_name_problem $declared] |
|
if {$problem ne ""} { |
|
lappend configerrors "CONFIG FILE ERROR. runtime: $runtime declares target platform '$declared' - $problem." |
|
continue |
|
} |
|
set line_target $declared |
|
} elseif {$declared ne $line_target} { |
|
lappend configerrors "CONFIG FILE ERROR. runtime: $runtime declares conflicting target platforms ('$line_target' and '$declared') in $mapfile - a runtime has one target." |
|
} |
|
} |
|
if {$line_target eq ""} { |
|
set line_target $default_target |
|
} |
|
set rtdir [file join $rtbase [platform_store_tier $line_target]] |
|
set exe_suffix [platform_exe_suffix $line_target] |
|
if {$runtime ne "-"} { |
|
set runtime_test $runtime$exe_suffix |
|
if {![file exists [file join $rtdir $runtime_test]]} { |
|
lappend warnings "WARNING: Missing runtime file $rtdir/$runtime_test (line in mapvfs.config: $ln)" |
|
lappend missing $runtime |
|
} |
|
} |
|
foreach vfsconfig $vfs_specs { |
|
switch -- [llength $vfsconfig] { |
|
1 - 2 - 3 - 4 - 5 { |
|
#5th element (G-133): smoke-require package list for the built kit - |
|
#interim line format; the schema's eventual home is the G-024 toml conversion |
|
lassign $vfsconfig vfstail appname target_kit_type - smokerequires |
|
if {![file isdirectory [file join $sourcefolder vfs $vfstail]]} { |
|
lappend warnings "WARNING: Missing vfs folder [file join $sourcefolder vfs $vfstail] specified in mapvfs.config for runtime $runtime" |
|
lappend missing $vfstail |
|
} else { |
|
if {$appname eq ""} { |
|
set appname [file rootname $vfstail] |
|
} |
|
dict lappend vfs_runtime_map $vfstail [list $runtime $appname $target_kit_type $line_target $smokerequires] |
|
} |
|
} |
|
default { |
|
set badline "bad entry in mapvfs.config - expected each entry after the runtime name to be a list of 1 to 5 elements {vfsfolder ?kitname? ?kittype? ?targetplatform? ?smokerequires?}. got: $vfsconfig ([llength $vfsconfig])" |
|
lappend warnings $badline |
|
lappend badentries $badline |
|
} |
|
} |
|
} |
|
if {[dict exists $runtime_vfs_map $runtime]} { |
|
lappend configerrors "CONFIG FILE ERROR. runtime: $runtime was specified more than once in $mapfile." |
|
} else { |
|
dict set runtime_vfs_map $runtime $vfs_specs |
|
dict set runtime_target $runtime $line_target |
|
} |
|
} |
|
dict set model runtime_vfs_map $runtime_vfs_map |
|
dict set model vfs_runtime_map $vfs_runtime_map |
|
dict set model runtime_target $runtime_target |
|
dict set model missing $missing |
|
dict set model warnings [concat [dict get $model warnings] $warnings] |
|
dict set model badentries $badentries |
|
dict set model configerrors $configerrors |
|
return $model |
|
} |
|
|
|
# Ordered kit-output enumeration over a mapvfs_parse model. |
|
# Replicates the kit loop's iteration + naming (vfs_tails glob order with map |
|
# extras appended, per-vfs runtime order from the mapping, appname defaulting to |
|
# the vfs rootname, kit_type defaulting to 'kit', '-' runtime -> <appname>.kit, |
|
# TARGET .exe suffix, duplicate appname -> <appname>_<runtime>) so listed names |
|
# match what a bake produces. Entries whose vfs folder is missing on disk never |
|
# reach the kit loop - they are appended after the bakeable set so 'bakelist' |
|
# can surface them as broken config. Duplicate-name disambiguation is per TARGET |
|
# (G-127): same-named kits for different targets coexist under their own output |
|
# tiers; a same-target duplicate assumes the config keeps appnames unique (as |
|
# the kit loop itself effectively does). |
|
# $rtbase is the store ROOT (bin/runtime): each record resolves its own tier |
|
# under it, so entries targeting different platforms report their own store |
|
# presence (G-122). Returns a list of record dicts: |
|
# kitname base output name (selection key, e.g punk91) |
|
# targetkit platform artifact name (e.g punk91.exe, or <name>.kit for '-') |
|
# kit_type kit|zip|zipcat|cookfs... as configured (defaulted to kit) |
|
# runtime runtime name as configured (unsuffixed), or "-" |
|
# runtime_file target runtime filename ("" for "-") |
|
# runtime_present 1|0 (1 for "-": no runtime needed) |
|
# runtime_dir store tier folder holding the runtime ("" for "-") |
|
# target target platform (e.g win32-x86_64) |
|
# store_tier bin/runtime tier folder name for the target |
|
# out_tier kit OUTPUT tier relative to bin/ and src/_bake/ - "" for the |
|
# default (host) target's flat locations, "kits/<platform>" for any |
|
# other target (G-127) |
|
# vfs vfs folder tail (e.g punk9wintk903.vfs) |
|
# vfs_present 1|0 |
|
# smokerequire G-133 smoke-require package list as configured ("" when undeclared) |
|
# entry config table label (toml models, e.g kit.punk91 / "scheme.punk9 (dev)"; "" legacy) |
|
# group G-024 named grouping ("" when ungrouped) |
|
# bake_default 1|0 - 0 means excluded from full (no-name) bakes; still bakeable |
|
# by name or @group selection |
|
# scheme / scheme_role scheme-expanded outputs: source scheme name and role |
|
# (versioned|dev|release); "" for explicit entries |
|
proc ::punkboot::lib::mapvfs_kit_outputs {model rtbase sourcefolder} { |
|
set runtime_vfs_map [dict get $model runtime_vfs_map] |
|
set vfs_runtime_map [dict get $model vfs_runtime_map] |
|
set runtime_target [dict get $model runtime_target] |
|
set default_target [dict get $model default_target] |
|
set vfs_tails [glob -nocomplain -dir $sourcefolder/vfs -types d -tail *.vfs] |
|
dict for {vfstail -} $vfs_runtime_map { |
|
if {$vfstail ni $vfs_tails} { |
|
lappend vfs_tails $vfstail |
|
} |
|
} |
|
set records [list] |
|
set exe_names_seen [list] |
|
set record_pair {{rtname vfstail appname target_kit_type smokerequires attrs} { |
|
upvar 1 records records exe_names_seen exe_names_seen rtbase rtbase sourcefolder sourcefolder\ |
|
runtime_target runtime_target default_target default_target |
|
if {$appname eq ""} { |
|
set appname [file rootname $vfstail] |
|
} |
|
if {$target_kit_type eq ""} { |
|
set target_kit_type "kit" |
|
} |
|
if {[dict exists $runtime_target $rtname]} { |
|
set target [dict get $runtime_target $rtname] |
|
} else { |
|
set target $default_target |
|
} |
|
set store_tier [::punkboot::lib::platform_store_tier $target] |
|
if {$rtname eq "-"} { |
|
set targetkit $appname.kit |
|
set kitname $appname |
|
set runtime_file "" |
|
set runtime_dir "" |
|
set runtime_present 1 ;#no runtime needed |
|
} else { |
|
set runtime_dir [file join $rtbase $store_tier] |
|
set runtime_file $rtname[::punkboot::lib::platform_exe_suffix $target] |
|
set targetkit ${appname}[::punkboot::lib::platform_exe_suffix $target] |
|
set kitname $appname |
|
if {[list $target $targetkit] in $exe_names_seen} { |
|
#duplicate appname configured for the same target - kit loop |
|
#disambiguates the same way (G-127: different-target namesakes |
|
#coexist under their own kits/<platform>/ output tiers instead) |
|
set targetkit ${appname}_$rtname |
|
set kitname ${appname}_$rtname |
|
} |
|
set runtime_present [file exists [file join $runtime_dir $runtime_file]] |
|
} |
|
lappend exe_names_seen [list $target $targetkit] |
|
lappend records [dict create\ |
|
kitname $kitname\ |
|
targetkit $targetkit\ |
|
kit_type $target_kit_type\ |
|
runtime $rtname\ |
|
runtime_file $runtime_file\ |
|
runtime_present $runtime_present\ |
|
runtime_dir $runtime_dir\ |
|
target $target\ |
|
store_tier $store_tier\ |
|
out_tier [expr {$target eq $default_target ? {} : "kits/$target"}]\ |
|
vfs $vfstail\ |
|
vfs_present [file isdirectory [file join $sourcefolder vfs $vfstail]]\ |
|
smokerequire $smokerequires\ |
|
entry [expr {[dict exists $attrs entry] ? [dict get $attrs entry] : ""}]\ |
|
group [expr {[dict exists $attrs group] ? [dict get $attrs group] : ""}]\ |
|
bake_default [expr {[dict exists $attrs bake_default] ? [dict get $attrs bake_default] : 1}]\ |
|
scheme [expr {[dict exists $attrs scheme] ? [dict get $attrs scheme] : ""}]\ |
|
scheme_role [expr {[dict exists $attrs scheme_role] ? [dict get $attrs scheme_role] : ""}]\ |
|
] |
|
}} |
|
foreach vfstail $vfs_tails { |
|
if {![dict exists $vfs_runtime_map $vfstail]} { |
|
continue ;#unmapped vfs folder - the kit loop derives no output names from it |
|
} |
|
set rtnames_done [list] ;#several entries may share a runtime on one vfs (toml models) - |
|
#enumerate each distinct runtime's spec set exactly once |
|
foreach rt_app [dict get $vfs_runtime_map $vfstail] { |
|
set rtname [lindex $rt_app 0] |
|
if {$rtname in $rtnames_done} { |
|
continue |
|
} |
|
lappend rtnames_done $rtname |
|
if {![dict exists $runtime_vfs_map $rtname]} { |
|
continue |
|
} |
|
foreach vfs_app [dict get $runtime_vfs_map $rtname] { |
|
lassign $vfs_app configured_vfs appname target_kit_type - smokerequires |
|
if {$configured_vfs ne $vfstail} { |
|
continue |
|
} |
|
apply $record_pair $rtname $vfstail $appname $target_kit_type $smokerequires [::punkboot::lib::mapvfs_spec_attrs $vfs_app] |
|
} |
|
} |
|
} |
|
#entries whose vfs folder is missing (excluded from vfs_runtime_map by the parse) |
|
dict for {rtname vfs_specs} $runtime_vfs_map { |
|
foreach vfsconfig $vfs_specs { |
|
if {[llength $vfsconfig] < 1 || [llength $vfsconfig] > 6} { |
|
continue |
|
} |
|
lassign $vfsconfig vfstail appname target_kit_type - smokerequires |
|
if {[dict exists $vfs_runtime_map $vfstail]} { |
|
continue ;#already enumerated above |
|
} |
|
apply $record_pair $rtname $vfstail $appname $target_kit_type $smokerequires [::punkboot::lib::mapvfs_spec_attrs $vfsconfig] |
|
} |
|
} |
|
return $records |
|
} |
|
|
|
# Match user-supplied kit names against mapvfs_kit_outputs records. |
|
# Accepts the base kit name (punk91), the platform artifact name (punk91.exe, |
|
# name.kit), or a G-024 group selector @<groupname> (selects every record in the |
|
# group). A base name matching several records - one per target, coexisting under |
|
# their own output tiers (G-127) - selects them all. |
|
# Matching is case-insensitive when the HOST filesystem is (a name the |
|
# user types is a host-side convenience - a cygwin-family host is as |
|
# case-insensitive as a native windows one, whatever it targets). Returns a dict: |
|
# selected matched records (kit-output order, deduplicated) |
|
# unknown supplied names that matched nothing |
|
proc ::punkboot::lib::mapvfs_match_outputs {kit_outputs names} { |
|
set on_windows [expr {[info exists ::punkboot::host_windows] ? $::punkboot::host_windows : ("windows" eq $::tcl_platform(platform))}] |
|
set name_eq {{on_windows a b} { |
|
expr {$on_windows ? [string equal -nocase $a $b] : [string equal $a $b]} |
|
}} |
|
set selected_idx [list] |
|
set unknown [list] |
|
foreach name $names { |
|
set found 0 |
|
if {[string match @?* $name]} { |
|
#group selector: every record carrying the group (G-024) |
|
set gname [string range $name 1 end] |
|
set i 0 |
|
foreach rec $kit_outputs { |
|
if {[dict get $rec group] ne "" && [apply $name_eq $on_windows [dict get $rec group] $gname]} { |
|
set found 1 |
|
if {$i ni $selected_idx} { |
|
lappend selected_idx $i |
|
} |
|
} |
|
incr i |
|
} |
|
if {!$found} { |
|
lappend unknown $name |
|
} |
|
continue |
|
} |
|
set base $name |
|
if {[string match -nocase *.exe $base] || [string match -nocase *.kit $base]} { |
|
set base [string range $base 0 end-4] |
|
} |
|
set i 0 |
|
foreach rec $kit_outputs { |
|
set rec_match 0 |
|
foreach candidate [list [dict get $rec kitname] [dict get $rec targetkit]] { |
|
if {$candidate eq ""} {continue} |
|
if {[apply $name_eq $on_windows $candidate $base] || [apply $name_eq $on_windows $candidate $name]} { |
|
set rec_match 1 |
|
break |
|
} |
|
} |
|
if {$rec_match} { |
|
#G-127: one kit NAME may legitimately match several records - one per |
|
#target, coexisting under their own output tiers - so a name selects |
|
#them ALL (like the @group branch), not just the first hit |
|
set found 1 |
|
if {$i ni $selected_idx} { |
|
lappend selected_idx $i |
|
} |
|
} |
|
incr i |
|
} |
|
if {!$found} { |
|
lappend unknown $name |
|
} |
|
} |
|
set selected [list] |
|
foreach i [lsort -integer $selected_idx] { |
|
lappend selected [lindex $kit_outputs $i] |
|
} |
|
return [dict create selected $selected unknown $unknown] |
|
} |
|
|
|
# Local runtime-materialization staleness core (shared by the bake-path |
|
# BAKE-WARNING and the bakelist report - the G-121 reuse of the G-103/G-117 |
|
# toml-revision metadata). Compares a punk-runtime WORKING COPY's beside-toml |
|
# revision against the highest -r<N> artifact revision present in the same |
|
# folder. Returns an empty dict when there is nothing to report (pre-family |
|
# runtime without a toml, direct -r<N> artifact reference, or no newer artifact |
|
# beside the working copy); otherwise a dict {current_rev N maxrev N maxname S}. |
|
proc ::punkboot::lib::runtime_materialization_check {rtfolder runtime_fullname} { |
|
set root $runtime_fullname |
|
if {[string match -nocase *.exe $root]} { |
|
set root [file rootname $root] |
|
} |
|
if {[regexp -- {-r\d+$} $root]} { |
|
return [dict create] ;#an immutable artifact referenced directly - not a working copy |
|
} |
|
set toml [file join $rtfolder ${root}.toml] |
|
if {![file isfile $toml]} { |
|
return [dict create] |
|
} |
|
if {[catch { |
|
set f [open $toml r] |
|
set tomldata [read $f] |
|
close $f |
|
}]} { |
|
return [dict create] |
|
} |
|
if {![regexp -line {^\s*revision\s*=\s*(\d+)} $tomldata -> current_rev]} { |
|
return [dict create] |
|
} |
|
set maxrev -1 |
|
set maxname "" |
|
foreach cand [glob -nocomplain -directory $rtfolder -tails -- "${root}-r*"] { |
|
if {[regexp -- {^.+-r(\d+)(?:\.[Ee][Xx][Ee])?$} $cand -> rev]} { |
|
if {$rev > $maxrev} { |
|
set maxrev $rev |
|
set maxname $cand |
|
} |
|
} |
|
} |
|
if {$maxrev > $current_rev} { |
|
return [dict create current_rev $current_rev maxrev $maxrev maxname $maxname] |
|
} |
|
return [dict create] |
|
} |
|
|
|
# Byte-equality of two files (chunked compare, early exit on first difference). |
|
# Used by kit_deploy_state - avoids hashing dependencies in the boot path. |
|
proc ::punkboot::lib::files_content_identical {patha pathb} { |
|
if {[file size $patha] != [file size $pathb]} { |
|
return 0 |
|
} |
|
set fa [open $patha r] |
|
set fb [open $pathb r] |
|
set same 1 |
|
try { |
|
chan configure $fa -translation binary -buffersize 262144 |
|
chan configure $fb -translation binary -buffersize 262144 |
|
while {1} { |
|
set da [read $fa 262144] |
|
set db [read $fb 262144] |
|
if {$da ne $db} { |
|
set same 0 |
|
break |
|
} |
|
if {[chan eof $fa] || [chan eof $fb]} { |
|
if {[chan eof $fa] != [chan eof $fb]} { |
|
set same 0 |
|
} |
|
break |
|
} |
|
} |
|
} finally { |
|
close $fa |
|
close $fb |
|
} |
|
return $same |
|
} |
|
|
|
# Deployed-state classification for a configured kit output (G-121 bakelist): |
|
# the deployed copy (<projectdir>/bin/<targetkit>) vs the bake product |
|
# (src/_bake/<targetkit>). |
|
# absent - no deployed copy in the bin folder |
|
# nobake - deployed copy exists but there is no bake product to compare against |
|
# current - deployed copy is byte-identical to the bake product |
|
# stale - deployed copy differs from the bake product |
|
# Size mismatch decides 'stale' cheaply; equal size + equal mtime short-circuits |
|
# to 'current' (the deploy step is a plain 'file copy'); otherwise a full content |
|
# compare decides. |
|
proc ::punkboot::lib::kit_deploy_state {bakefolder deployfolder targetkit} { |
|
set built [file join $bakefolder $targetkit] |
|
set deployed [file join $deployfolder $targetkit] |
|
if {![file isfile $deployed]} { |
|
return absent |
|
} |
|
if {![file isfile $built]} { |
|
return nobake |
|
} |
|
if {[file size $built] != [file size $deployed]} { |
|
return stale |
|
} |
|
if {[file mtime $built] == [file mtime $deployed]} { |
|
return current |
|
} |
|
if {[punkboot::lib::files_content_identical $built $deployed]} { |
|
return current |
|
} |
|
return stale |
|
} |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
if {"::try" ni [info commands ::try]} { |
|
puts stderr "Tcl interpreter possibly too old - need at least tcl 8.6 - 'try' command not found - aborting" |
|
exit 1 |
|
} |
|
|
|
#------------------------------------------------------------------------------ |
|
#Module loading from src/bootsupport or [pwd]/modules if pwd is a 'src' folder |
|
#------------------------------------------------------------------------------ |
|
#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files |
|
# - then it will attempt to preference these modules |
|
# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script |
|
# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables |
|
set startdir [pwd] |
|
|
|
#puts "SCRIPTFOLDER: $::punkboot::scriptfolder" |
|
|
|
#we are focussed on pure-tcl libs/modules in bootsupport for now. |
|
#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc |
|
#REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries |
|
# - we need to support that without binary downloads from repos unless the user explicitly asks for that. |
|
# - They may already be available in the vfs (or pointed to package paths) of the running executable. |
|
# - todo: some user prompting regarding installs with platform-appropriate package managers |
|
# - todo: some user prompting regarding building accelerators from source. |
|
|
|
# ------------------------------------------------------------------------------------- |
|
set bootsupport_module_paths [list] |
|
set bootsupport_library_paths [list] |
|
set this_platform_generic [punkboot::lib::platform_punk] ;#normalized punkshell platform-dir name (punk::platform canon) |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
#G-122 host/target split. $this_platform_generic is the HOST canon and stays the |
|
#key for everything that describes THIS interpreter (bootsupport/vendorlib |
|
#platform dirs below, diagnostics). What the bake EMITS is keyed by target: |
|
# host_platform - canon of the driving tclsh (same value, named for clarity) |
|
# target_platform - default target for kit outputs; a cygwin-family host |
|
# (msys2/cygwin runtime on windows) bakes win32 kits. |
|
# Per-entry mapvfs.config declarations override it per runtime. |
|
# host_windows - host process/filesystem semantics are windows-like |
|
# (native windows OR cygwin family): drives copy commands, |
|
# path case comparison, prompt behaviour - NOT artifact naming. |
|
set ::punkboot::host_platform $this_platform_generic |
|
set ::punkboot::target_platform [punkboot::lib::platform_target_default $this_platform_generic] |
|
set ::punkboot::host_windows [expr {[punkboot::lib::platform_process_family $this_platform_generic] eq "windows"}] |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
#we always create these lists in order of desired precedence. |
|
# - this is the same order when adding to auto_path - but will need to be reversed when using tcl:tm::add |
|
if {[file exists [file join $::punkboot::scriptfolder bootsupport]]} { |
|
set bootsupportdir [file join $::punkboot::scriptfolder bootsupport] |
|
puts stderr "Using bootsupport dir $bootsupportdir" |
|
|
|
lappend bootsupport_module_paths [file join $bootsupportdir modules_tcl$::tclmajorv] ;#more version-specific modules slightly higher in precedence order |
|
lappend bootsupport_module_paths [file join $bootsupportdir modules] |
|
lappend bootsupport_library_paths [file join $bootsupportdir lib_tcl$::tclmajorv/allplatforms] ;#more version-specific pkgs slightly higher in precedence order |
|
lappend bootsupport_library_paths [file join $bootsupportdir lib_tcl$::tclmajorv/$this_platform_generic] ;#more version-specific pkgs slightly higher in precedence order |
|
lappend bootsupport_library_paths [file join $bootsupportdir lib] |
|
} else { |
|
puts stderr "No bootsupport dir for script [info script] at [file join $::punkboot::scriptfolder bootsupport]" |
|
#G-122 host-personality diagnosis: a cygwin-family tclsh (msys2/cygwin runtime on |
|
#windows) is a POSIX Tcl - 'C:/path/make.tcl' is not an absolute path to it, so |
|
#'file normalize' silently prefixes the cwd and every derived path is wrong. The |
|
#failure that follows (missing bootsupport, then an unresolvable project root) is |
|
#unrecognisable without this note. Caller-side spelling, not something make.tcl can |
|
#safely rewrite - name the script in the host's own path syntax. |
|
if {[punkboot::lib::platform_is_cygwin_family $this_platform_generic] && [regexp {^([A-Za-z]):[/\\](.*)$} [info script] -> _cygdrive _cygrest]} { |
|
puts stderr " NOTE: this tclsh is a $this_platform_generic (msys2/cygwin-runtime) build - a POSIX Tcl, to which the windows-style path '[info script]' is NOT absolute, so it was resolved relative to the current directory." |
|
puts stderr " Re-run naming the script in this shell's own path syntax: /[string tolower $_cygdrive]/[string map {\\ /} $_cygrest]" |
|
unset -nocomplain _cygdrive _cygrest |
|
} |
|
#lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv] |
|
#lappend bootsupport_module_paths [file join $startdir bootsupport modules] |
|
#lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/allplatforms] |
|
#lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv/$this_platform_generic] |
|
#lappend bootsupport_library_paths [file join $startdir bootsupport lib] |
|
} |
|
set bootsupport_paths_exist 0 |
|
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] { |
|
if {[file exists $p]} { |
|
set bootsupport_paths_exist 1 ;#at least one exists |
|
break |
|
} |
|
} |
|
# ------------------------------------------------------------------------------------- |
|
# ------------------------------------------------------------------------------------- |
|
set sourcesupport_module_paths [list] |
|
set sourcesupport_library_paths [list] |
|
set sourcesupport_paths_exist 0 |
|
#we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir. |
|
#The <projectdir>/modules are the very modules we are minting - and may be in a broken state, which punkboot then can't fix. |
|
#The mint is generally just stamping a version instead of 999999.0a1 (plus modpod packing and doc string substitution) |
|
#(most?) Modules in src/modules etc should still be runnable directly in certain cases like this where we point to them. |
|
if {[file tail $startdir] eq "src"} { |
|
#todo - other src 'module' dirs.. |
|
foreach p [list $startdir/modules_tcl$::tclmajorv $startdir/modules $startdir/vendormodules_tcl$::tclmajorv $startdir/vendormodules] { |
|
if {[file exists $p]} { |
|
lappend sourcesupport_module_paths $p |
|
} |
|
} |
|
# -- -- -- |
|
foreach p [list $startdir/lib_tcl$::tclmajorv/allplatforms $startdir/lib_tcl$::tclmajorv/$this_platform_generic $startdir/lib $startdir/vendorlib_tcl$::tclmajorv/allplatforms $startdir/vendorlib_tcl$::tclmajorv/$this_platform_generic $startdir/vendorlib] { |
|
if {[file exists $p]} { |
|
lappend sourcesupport_library_paths $p |
|
} |
|
} |
|
# -- -- -- |
|
|
|
foreach p [list {*}$sourcesupport_module_paths {*}$sourcesupport_library_paths] { |
|
if {[file exists $p]} { |
|
set sourcesupport_paths_exist 1 |
|
break |
|
} |
|
} |
|
|
|
if {$sourcesupport_paths_exist} { |
|
#launch from <projectdir/src is also likely to be common |
|
# but we need to be loud about what's going on. |
|
puts stderr "------------------------------------------------------------------" |
|
puts stderr "Launched from within a folder ending in 'src'" |
|
puts stderr " - modules in $startdir/modules $startdir/lib (etc) may override bootsupport modules" |
|
puts stderr "------------------------------------------------------------------" |
|
} |
|
} |
|
# ------------------------------------------------------------------------------------- |
|
set original_tm_list [tcl::tm::list] |
|
set original_auto_path $::auto_path |
|
|
|
set package_paths_modified 0 |
|
if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { |
|
tcl::tm::remove {*}$original_tm_list |
|
|
|
#very basic test there is something there.. |
|
set support_contents_exist 0 |
|
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths {*}$sourcesupport_module_paths {*}$sourcesupport_library_paths] { |
|
#set contents [glob -nocomplain -dir $p -tail *] |
|
if {![file exists $p]} {continue} |
|
set contents [punkboot::lib::folder_nondotted_children $p] |
|
set readmeposn [lsearch -nocase $contents readme.md] |
|
#don't assume 'ledit' available |
|
set contents [lreplace $contents[set contents {}] $readmeposn $readmeposn] ;#list unchanged if -1 |
|
if {[llength $contents]} { |
|
set support_contents_exist 1 |
|
break |
|
} |
|
} |
|
|
|
set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk] |
|
if {$support_contents_exist} { |
|
#only forget all *unloaded* package names |
|
foreach pkg [package names] { |
|
if {$pkg in $tcl_core_packages} { |
|
continue |
|
} |
|
if {![llength [package versions $pkg]]} { |
|
#puts stderr "Got no versions for pkg $pkg" |
|
continue |
|
} |
|
if {![string length [package provide $pkg]]} { |
|
#no returned version indicates it wasn't loaded - so we can forget its index |
|
package forget $pkg |
|
} |
|
} |
|
#Deliberately omit original_tm_list and original_auto_path |
|
tcl::tm::add {*}[lreverse $bootsupport_module_paths] {*}[lreverse $sourcesupport_module_paths] ;#tm::add works like LIFO. sourcesupport_module_paths end up earliest in resulting tm list. |
|
set ::auto_path [list {*}$sourcesupport_library_paths {*}$bootsupport_library_paths] |
|
} |
|
#puts "----> auto_path $::auto_path" |
|
#puts "----> tcl::tm::list [tcl::tm::list]" |
|
|
|
#maint: also in punk::repl package |
|
#-------------------------------------------------------- |
|
set libunks [list] |
|
foreach tm_path [tcl::tm::list] { |
|
set punkdir [file join $tm_path punk] |
|
if {![file exists $punkdir]} {continue} |
|
lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] |
|
} |
|
set libunknown "" |
|
set libunknown_version_sofar "" |
|
foreach lib $libunks { |
|
#expecting to be of form libunknown-<tclversion>.tm |
|
set vtail [lindex [split [file tail $lib] -] 1] |
|
set thisver [file rootname $vtail] ;#file rootname x.y.z.tm |
|
if {$libunknown_version_sofar eq ""} { |
|
set libunknown_version_sofar $thisver |
|
set libunknown $lib |
|
} else { |
|
if {[package vcompare $thisver $libunknown_version_sofar] == 1} { |
|
set libunknown_version_sofar $thisver |
|
set libunknown $lib |
|
} |
|
} |
|
} |
|
if {$libunknown ne ""} { |
|
if {[info commands ::punk::libunknown::package] ne ""} { |
|
#libunknown already active in this interp - e.g make.tcl driven by a built punk |
|
#executable whose boot (punk_main.tcl) initialised it. init's rename of ::package |
|
#must not be repeated (its guard would emit an 'init already done' diagnostic and |
|
#return), and re-sourcing would silently swap the running copy for the bootsupport |
|
#copy - leave the active one in place. |
|
} else { |
|
source $libunknown |
|
if {[catch {punk::libunknown::init -caller make.tcl} errM]} { |
|
puts stderr "error initialising punk::libunknown\n$errM" |
|
} |
|
} |
|
#puts stdout " *** [package names]" |
|
#puts stdout " **** [dict get $::punk::libunknown::epoch pkg untracked]" |
|
} else { |
|
puts stderr "Failed to find punk::libunknown" |
|
} |
|
#-------------------------------------------------------- |
|
|
|
#package require Thread |
|
#puts "---->tcl_library [info library]" |
|
#puts "---->loaded [info loaded]" |
|
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly. |
|
|
|
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list |
|
#These are strong dependencies |
|
#package forget punk::mix |
|
#package forget punk::repo |
|
#package forget punkcheck |
|
|
|
#------------------------------------------------------------------ |
|
# Bootsupport staleness check |
|
# When make.tcl is run from project root (not from src/), bootsupport |
|
# modules are loaded in preference to source modules. If the source |
|
# modules have been updated (e.g API changes) but bootsupport hasn't |
|
# been rebuilt, make.tcl will fail with obscure errors from the stale |
|
# bootsupport versions. This check compares buildversion.txt in source |
|
# against the highest .tm version in bootsupport and warns the caller. |
|
#------------------------------------------------------------------ |
|
if {[file tail $startdir] ne "src"} { |
|
set _runtime_deps [list {*}{ |
|
} punkcheck punkcheck-buildversion.txt punkcheck-*.tm {*}{ |
|
} punk::repo punk/repo-buildversion.txt punk/repo-*.tm {*}{ |
|
} punk::mix punk/mix-buildversion.txt punk/mix-*.tm {*}{ |
|
} punk::tdl punk/tdl-buildversion.txt punk/tdl-*.tm {*}{ |
|
} punk::args punk/args-buildversion.txt punk/args-*.tm {*}{ |
|
}] |
|
set _stale_modules [list] |
|
foreach {pkg buildversion_rel bootsupport_glob} $_runtime_deps { |
|
set _src_bv_file [file join $::punkboot::scriptfolder modules $buildversion_rel] |
|
set _bs_glob_dir [file dirname [file join $::punkboot::scriptfolder bootsupport modules $bootsupport_glob]] |
|
set _bs_glob_pat [file tail $bootsupport_glob] |
|
if {![file exists $_src_bv_file]} {continue} |
|
#read source version (first line of buildversion.txt) |
|
set _fd [open $_src_bv_file r] |
|
set _src_version [string trim [lindex [split [read $_fd] \n] 0]] |
|
close $_fd |
|
#find highest version .tm in bootsupport |
|
set _bs_version "" |
|
set _prefix [string range $_bs_glob_pat 0 [string first "*" $_bs_glob_pat]-1] |
|
foreach _tm [glob -nocomplain -dir $_bs_glob_dir -- $_bs_glob_pat] { |
|
set _v [file rootname [string range [file tail $_tm] [string length $_prefix] end]] |
|
if {$_bs_version eq "" || [package vcompare $_v $_bs_version] == 1} { |
|
set _bs_version $_v |
|
} |
|
} |
|
if {$_bs_version ne "" && $_src_version ne "" && [package vcompare $_src_version $_bs_version] == 1} { |
|
set _bump [::punkboot::lib::bootsupport_bump_level $_bs_version $_src_version] |
|
lappend _stale_modules [list $pkg $_src_version $_bs_version $_bump] |
|
} |
|
} |
|
if {[llength $_stale_modules]} { |
|
set ::punkboot::stale_bootsupport $_stale_modules |
|
} |
|
unset _runtime_deps _stale_modules |
|
} |
|
|
|
package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies |
|
package require punk::mix |
|
package require punkcheck |
|
package require punk::lib |
|
#G-030 degrade rule: punk::args (declarative dispatch/help) and its tabled-rendering stack |
|
#(punk::ansi, textblock) are guarded - a stale/missing snapshot of these must never brick |
|
#the make.tcl commands used to repair it (check, bootsupport, modules). Dispatch and help |
|
#fall back to the self-contained scan / plain-text help further below when absent. |
|
foreach _optpkg {punk::args punk::ansi textblock} { |
|
if {[catch {package require $_optpkg} _opterr]} { |
|
puts stderr "make.tcl: boot package $_optpkg unavailable from bootsupport ($_opterr) - continuing degraded (plain help/argument handling)" |
|
} |
|
} |
|
unset -nocomplain _optpkg _opterr |
|
|
|
|
|
set package_paths_modified 1 |
|
|
|
#------------------------------------------------------------------------------ |
|
#puts "----> llength package names [llength [package names]]" |
|
} |
|
|
|
set ::punkboot::pkg_requirements_found [list] |
|
|
|
#we will treat 'package require <mver>.<etc>' (minbounded) as <mver>.<etc>-<mver+1> ie explicitly convert to corresponding bounded form |
|
#put some with leading zeros to test normalisation |
|
set ::punkboot::bootsupport_requirements [dict create {*}{ |
|
} punk::repo [list version {00.01.01-}] {*}{ |
|
} punk::mix [list version {}] {*}{ |
|
} punk::ansi [list] {*}{ |
|
} punk::args [list] {*}{ |
|
} overtype [list version {1.6.5-}] {*}{ |
|
} punkcheck [list] {*}{ |
|
} fauxlink [list version {0.1.1-}] {*}{ |
|
} textblock [list version 0.1.1-] {*}{ |
|
} fileutil [list] {*}{ |
|
} fileutil::traverse [list] {*}{ |
|
} struct::list [list] {*}{ |
|
} md5 [list version 2-] {*}{ |
|
} |
|
] |
|
|
|
#while we are converting plain version numbers to explicit bounded form - we'll also do some validation of the entries |
|
dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { |
|
if {[dict exists $pkginfo version]} { |
|
set ver [string trim [dict get $pkginfo version]] |
|
if {![catch {::punkboot::lib::tm_version_required_canonical $ver} canonical]} { |
|
if {$canonical ne $ver} { |
|
dict set pkginfo version $canonical ;# plain ver mapped to min-max. min- and min-max and empty left as is |
|
dict set ::punkboot::bootsupport_requirements $pkg $pkginfo |
|
} |
|
} else { |
|
puts stderr "punkboot::bootsupport_requirements - package $pkg has invalid version specification '$ver'" |
|
exit 1 |
|
} |
|
} else { |
|
#make sure each has a blank version entry if nothing was there. |
|
dict set pkginfo version "" |
|
dict set ::punkboot::bootsupport_requirements $pkg $pkginfo |
|
} |
|
} |
|
#Assert - our bootsupport_requirement version numbers should now be either empty or of the form min- or min-max |
|
#dict for {k v} $::punkboot::bootsupport_requirements { |
|
# puts "- $k $v" |
|
#} |
|
|
|
#some of our toplevel package specified in bootsupport_requirements may trigger 'package require' for dependencies that we know are optional/not required. |
|
#By listing them here we can produce better warnings |
|
set ::punkboot::bootsupport_optional [dict create {*}{ |
|
} tcllibc [list -note {improves performance significantley}] {*}{ |
|
} twapi [list] {*}{ |
|
} patternpunk [list] {*}{ |
|
} cryptkit [list -note {accelerates some packages}] {*}{ |
|
} Trf [list -note {accelerates some packages}] {*}{ |
|
}] |
|
|
|
set ::punkboot::bootsupport_recommended [dict create {*}{ |
|
}] |
|
#set ::punkboot::bootsupport_recommended [dict create {*}{ |
|
# } tcllibc [list -note {improves performance significantley}] {*}{ |
|
#}] |
|
|
|
# ** *** *** *** *** *** *** *** *** *** *** *** |
|
# create an interp in which we hijack package command |
|
# This allows us to auto-gather some dependencies (not necessarily all and not necessarily strictly required) |
|
# Note: even in a separate interp we could still possibly get side-effects if a package has compiled components - REVIEW |
|
# Hopefully the only side-effect is that a subsequent load of the package will be faster... |
|
# (punk boot is intended to operate without compiled components - but some could be pulled in by tcl modules if they're found) |
|
# (tcllibc is also highly desirable as the performance impact when not available can be dramatic.) |
|
# ... but if the binary is loaded with a different path name when we come to actually use it - there could be issues. |
|
# A truly safe way to do this might be to call out to a separate process, or to relaunch after checks. (todo?) |
|
# A truly accurate way to do this is to have dependencies properly recorded for every package - |
|
# something the package developer would have to provide - or an analyst would have to determine by looking at the code. |
|
# (to check for 'package require' statements that are actually optional, one-or-more-of-n, mutually-exclusive, anti-requirements etc) |
|
# Such information may also vary depending on what features of the package are to be used here - so it's a tricky problem. |
|
# |
|
# Nevertheless - the auto-determination can be a useful warning to the punk boot developer that something may be missing in the bootsupport. |
|
# |
|
# A further auto-determination for optionality could potentially be done in yet another interp by causing package require to fake-error on a dependency - |
|
# and see if the parent still loads. This would still be more time and complexity for a still uncertain result. |
|
# e.g a package may be a strong requirement for the package being examined iff another optional package is present (which doesn't itself require that dependency) |
|
# - it's unclear that reasonable determinations always can be made. |
|
# There are also packages that aren't required during one package's load - but are required during certain operations. |
|
# ** *** *** *** *** *** *** *** *** *** *** *** |
|
proc ::punkboot::check_package_availability {args} { |
|
#best effort at auto-determinining packages required (dependencies) based on top-level packages in the list. |
|
#Without fully parsing the package-loading Tcl scripts and examining all side-effects (an unlikely capability), |
|
# this is not going to be as accurate as the package developer providing a definitive list of which packages are required and which are optional. |
|
# 'optionality' is a contextual concept anyway depending on how the package is intended to be used. |
|
# The package developer may consider a feature optional - but it may not be optional in a particular usecase. |
|
|
|
set bootsupport_requirements [lindex $args end] |
|
set usage "punkboot::check_package_availability ?-quiet 0|1? package_list" |
|
if {![llength $bootsupport_requirements]} { |
|
error "usage: $usage" |
|
} |
|
set opts [lrange $args 0 end-1] |
|
if {[llength $opts] % 2 != 0} { |
|
error "incorrect number of arguments. usage: $usage" |
|
} |
|
set defaults [dict create {*}{ |
|
-quiet 1 |
|
}] |
|
set opts [dict merge $defaults $opts] |
|
set opt_quiet [dict get $opts -quiet] |
|
|
|
interp create testpkgs |
|
interp eval testpkgs [list package prefer [package prefer]] |
|
interp eval testpkgs { |
|
namespace eval ::test {} |
|
set ::test::pkg_requested [list] ;#list of pairs (pkgname version_requested) version_requested is 'normalised' (min- /min-max only) or empty |
|
set ::test::pkg_loaded [list] |
|
set ::test::pkg_missing [list] |
|
set ::test::pkg_broken [list] |
|
set ::test::pkg_info [dict create] |
|
tcl::tm::remove {*}[tcl::tm::list] |
|
set ::auto_path [list] |
|
} |
|
#sync interp package paths with current state of package/library paths |
|
interp eval testpkgs [list ::tcl::tm::add {*}[tcl::tm::list]] |
|
interp eval testpkgs [list set ::auto_path $::auto_path] |
|
interp eval testpkgs [list set ::test::bootsupport_requirements $bootsupport_requirements] |
|
interp eval testpkgs [list set ::argv0 $::argv0] |
|
interp eval testpkgs [list set ::opt_quiet $opt_quiet] |
|
|
|
|
|
interp eval testpkgs { |
|
#try { |
|
rename ::package ::package_orig |
|
variable ns_scanned [list] |
|
# |
|
proc ::tm_version_major {version} { |
|
#if {![tm_version_isvalid $version]} { |
|
# error "Invalid version '$version' is not a proper Tcl module version number" |
|
#} |
|
set firstpart [lindex [split $version .] 0] |
|
#check for a/b in first segment |
|
if {[string is integer -strict $firstpart]} { |
|
return $firstpart |
|
} |
|
if {[string first a $firstpart] > 0} { |
|
return [lindex [split $firstpart a] 0] |
|
} |
|
if {[string first b $firstpart] > 0} { |
|
return [lindex [split $firstpart b] 0] |
|
} |
|
error "tm_version_major unable to determine major version from version number '$version'" |
|
} |
|
proc ::package {args} { |
|
variable ns_scanned |
|
if {[lindex $args 0] eq "require"} { |
|
#review - difference between errors due to bad requirements format vs package missing/failed |
|
#we should probably still put syntax errors into the datastructure to be ultimately shown to the user |
|
if {[lindex $args 1] eq "-exact"} { |
|
set pkgname [lindex $args 2] |
|
set raw_requirements_list [lrange $args 3 end] |
|
#review - what to do with invalid extra args? Normally it would raise an error |
|
set version_requested [lindex $raw_requirements_list 0] ;#for now treat as exactly one requirement when -exact |
|
#normalise! |
|
set version_requested "$version_requested-$version_requested" |
|
lappend requirements_list $version_requested |
|
} else { |
|
set pkgname [lindex $args 1] |
|
#usually only a single requirement - but we must handle multiple |
|
set raw_requirements_list [lrange $args 2 end] ;#may be also be pattern like ver- (min-unbounded) or ver1-ver2 (bounded) (which will match >=ver1 but strictly < ver2) (or like -exact if ver1=ver2) |
|
set requirements_list [list] |
|
foreach requirement $raw_requirements_list { |
|
#set requirement [::punkboot::lib::tm_version_required_canonical $requirement] |
|
#todo - work out how to get normalisation code in interp |
|
if {[string trim $requirement] ne ""} { |
|
if {[string first - $requirement] < 0} { |
|
#plain ver - normalise to ver-nextmajor |
|
#todo - we should fully normalise as we do in main script! (e.g leading zeroes - even though these should be rare) |
|
set m [::tm_version_major $requirement] |
|
set nextm [expr {$m +1}] |
|
lappend requirements_list $requirement-$nextm |
|
} else { |
|
#has dash - we should normalize so keys match even if leading zeros! |
|
lappend requirements_list $requirement |
|
} |
|
} else { |
|
#empty or whitespace spec not allowed - should be syntax error |
|
#add it to list anyway so that the underlying package call later can fail it appropriately |
|
lappend requirements_list $requirement |
|
} |
|
} |
|
#assert - added an entry for every raw requirement - even if doesn't appear to be valid |
|
|
|
#$requirements_list may be empty = any version satisfies. |
|
} |
|
|
|
#should still distinguish: {pkgname {}} -valid vs {pkgname {{}}} due to empty string supplied in call - invalid - but leave for underlying package command to error on |
|
set pkgrequest [list $pkgname $requirements_list] |
|
if {$pkgrequest ni $::test::pkg_requested} { |
|
lappend ::test::pkg_requested $pkgrequest |
|
} |
|
|
|
# -- -- --- --- --- --- --- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
# Must ensure a scan has been done in the relevant subpath before attempting to gether package vervsion |
|
set nsquals [namespace qualifiers $pkgname] |
|
if {$nsquals ne "" && $nsquals ni $ns_scanned} { |
|
catch {::package_orig require ${nsquals}::zzz-nonexistant} ;#scan every ns encountered once - or we will get no result from 'package versions' for sub namespaces. |
|
lappend ns_scanned $nsquals |
|
} |
|
set versions [::package_orig versions $pkgname] |
|
#An empty result from versions doesn't always indicate we can't load the package! |
|
#REVIEW - known to happen with 'package versions Tcl' - what other circumstances? |
|
# -- -- --- --- --- --- --- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
#fill in a blank pinfo dict to get some consistent ordering |
|
if {[dict exists $::test::pkg_info $pkgrequest]} { |
|
set pinfo [dict get $::test::pkg_info $pkgrequest] |
|
} else { |
|
set pinfo [dict create version "" versions $versions version_requested $requirements_list required_by [list]] |
|
} |
|
if {[llength $::test::pkg_stack]} { |
|
set caller [lindex $::test::pkg_stack end] |
|
set required_by [dict get $pinfo required_by] |
|
if {$caller ni $required_by} { |
|
lappend required_by $caller |
|
} |
|
dict set pinfo required_by $required_by |
|
} |
|
lappend ::test::pkg_stack $pkgname |
|
|
|
#At this point we could short circuit if we've already classified this package/requirements combo as missing/broken from a previous require |
|
#review - there is some chance the exact pkg/requirements combo may succeed after an earlier failure if some package adjusted search paths.. |
|
#however - the pkg should maintain a failure record - treating it as successful is likely to hide relevant info |
|
if {$pkgrequest in [list {*}$::test::pkg_missing {*}$::test::pkg_broken]} { |
|
set ::test::pkg_stack [lrange $::test::pkg_stack 0 end-1] |
|
dict set ::test::pkg_info $pkgrequest $pinfo |
|
return |
|
} |
|
|
|
#use our normalised requirements instead of original args |
|
#if {[catch [list ::package_orig {*}$args] result]} {} |
|
if {[catch [list ::package_orig require $pkgname {*}$requirements_list] result]} { |
|
dict set pinfo testerror $result |
|
#package missing - or exists - but failing to initialise |
|
if {!$::opt_quiet} { |
|
set parent_path [lrange $::test::pkg_stack 0 end-1] |
|
puts stderr "[punkboot::sgr 32] $pkgname versions: $versions error: $result[punkboot::sgr]" |
|
set parent_path [join $parent_path " -> "] |
|
puts stderr "pkg requirements: $parent_path" |
|
puts stderr "error during : '$args'" |
|
puts stderr " [punkboot::sgr 93]$result[punkboot::sgr]" |
|
} |
|
|
|
#the failed package may still exist - so we could check 'package files' and 'package ifneeded' here too - REVIEW |
|
#to determine the version that we attempted to load, |
|
#- we need to look at 'pkg versions' vs -exact / ver / ver-ver (using package vsatisfies) |
|
if {![llength $versions]} { |
|
#no versions *and* we had an error - missing is our best guess. review. |
|
#'package versions Tcl' never shows any results |
|
#so requests for old versions will show as missing not broken. |
|
#This is probably better anyway. |
|
if {$pkgrequest ni $::test::pkg_missing} { |
|
lappend ::test::pkg_missing $pkgrequest |
|
} |
|
} else { |
|
if {$pkgrequest ni $::test::pkg_broken} { |
|
lappend ::test::pkg_broken $pkgrequest |
|
} |
|
|
|
#all we know about failed pkg is in the error $result |
|
#we can't reliably determine which version of possibly many it was trying to load just based on error msgs. |
|
#(we often could - but not always) |
|
#Instead - use the properly ordered versions and knowledge of which pkg 'package require' would have picked. |
|
|
|
#'package versions' does not always return ordered earliest to latest! (e.g 'package versions http' -> 2.10b1 2.9.8) |
|
set ordered_versions [lsort -command {::package_orig vcompare} [::package_orig versions $pkgname]] |
|
if {[::package_orig prefer] eq "stable"} { |
|
#to support 'package prefer' = stable we have to strip alpha/beta versions |
|
set selectable_versions [list] |
|
foreach v $ordered_versions { |
|
if {[string match *a* $v] || [string match *b* $v]} { |
|
#presence of an a or b indicates 'unstable' |
|
continue |
|
} |
|
lappend selectable_versions $v |
|
} |
|
} else { |
|
#we are operating under 'package prefer' = latest |
|
set selectable_versions $ordered_versions |
|
} |
|
|
|
if {[llength $requirements_list]} { |
|
#add one or no entry for each requirement. |
|
#pick highest at end |
|
set satisfiers [list] |
|
foreach requirement $requirements_list { |
|
foreach ver [lreverse $selectable_versions] { |
|
if {[package vsatisfies $ver $requirement]} { |
|
lappend satisfiers $ver |
|
break |
|
} |
|
} |
|
} |
|
if {[llength $satisfiers]} { |
|
set satisfiers [lsort -command {::package_orig vcompare} $satisfiers] |
|
dict set pinfo version [lindex $satisfiers end] |
|
} |
|
} else { |
|
#package require will have picked highest/latest |
|
dict set pinfo version [lindex $selectable_versions end] |
|
} |
|
} |
|
|
|
|
|
#Note that we must return without error in order to gather 'probable' dependencies. |
|
#This is not completely accurate - as a lib/module may have wrapped a 'package require' in a catch |
|
#In such a case the 'dependency' might be optional - but we currently have no way of determining this. |
|
#By not returning an error - the loaded package may not behave correctly (e.g package state variables set differently?) |
|
#- hence this is all done in a separate interp to be discarded. |
|
#Note that pkgIndex.tcl scripts may commonly just 'return' and fail to do a 'package provide' |
|
# - presumably the standard package require still raises an error in that case though - so it is different? |
|
# - e.g at least some versions of struct::list did this. resulting in "can't find package struct::list" for tcl versions not supported. |
|
# - even thoug it did find a package for struct::list. |
|
set ::test::pkg_stack [lrange $::test::pkg_stack 0 end-1] |
|
dict set ::test::pkg_info $pkgrequest $pinfo |
|
return |
|
} else { |
|
#package loaded ok |
|
lappend ::test::pkg_loaded $pkgrequest |
|
set ifneeded_script [list uplevel 1 [list ::package_orig ifneeded $pkgname]] ;#not guaranteed to be a tcl list? |
|
set pinfo [dict merge $pinfo [dict create version $result raw_ifneeded $ifneeded_script]] |
|
|
|
set ::test::pkg_stack [lrange $::test::pkg_stack 0 end-1] |
|
set relevant_files [list] |
|
if {![catch {::package_orig files Tcl} ]} { |
|
#tcl9 (also some 8.6/8.7) has 'package files' subcommand. |
|
#unfortunately, in some cases (e.g md5 when no accelerators available) this can be a huge list (1000+) showing all scanned pkgIndex.tcl files from unrelated packages. |
|
#We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour |
|
#see: https://core.tcl-lang.org/tcl/tktview/209fd9adce |
|
set all_files [::package_orig files $pkgname] |
|
#some arbitrary threshold? REVIEW |
|
if {[llength $all_files] > 10} { |
|
dict set pinfo warning "files_sourced_during_load=[llength $all_files]" |
|
} else { |
|
set relevant_files $all_files |
|
dict set pinfo packagefiles $relevant_files |
|
} |
|
} |
|
if {![llength $relevant_files]} { |
|
dict set pinfo packagefiles {} ;#default |
|
#there are all sorts of scripts, so this is not predictably structured |
|
#e.g using things like apply |
|
#we will attempt to get a trailing source .. <file> |
|
set parts [split [string trim $ifneeded_script] {;}] |
|
set trimparts [list] |
|
foreach p $parts { |
|
lappend trimparts [string trimright $p] |
|
} |
|
set last_with_text [lsearch -inline -not [lreverse $trimparts] ""] ;#could return empty if all blank |
|
#we still don't assume any line is a valid tcl list.. |
|
if {$last_with_text ne "" && [regexp -- {\S+$} $last_with_text lastword]} { |
|
#if it's a file or dir - close enough (?) |
|
#e.g tcllibc uses apply and the last entry is actuall a folder used to find the file.. |
|
#we aren't brave enough to try to work out the actual file(s) |
|
if {[file exists $lastword]} { |
|
dict set pinfo packagefiles $lastword |
|
} |
|
} |
|
} |
|
dict set ::test::pkg_info $pkgrequest $pinfo |
|
return $result |
|
} |
|
} else { |
|
#puts stderr "package $args" |
|
return [uplevel 1 [list ::package_orig {*}$args]] |
|
} |
|
} |
|
|
|
set ::test::pkg_stack [list] |
|
catch {::package_orig require zzz-non-existant} ;#scan so we get 'package versions' results |
|
dict for {pkg pkgdict} $::test::bootsupport_requirements { |
|
#set nsquals [namespace qualifiers $pkg] |
|
#if {$nsquals ne ""} { |
|
# catch {::package_orig require ${nsquals}::zzz-non-existant} ;#force scan of every level encountered |
|
#} |
|
set ::test::pkg_stack [list] |
|
#run the instrumented 'package require' on the toplevel requirements |
|
# dict key version always exists in pkgdict - version is empty or normalised to min- or min-max |
|
set wanted [dict get $pkgdict version] |
|
catch {package require $pkg {*}$wanted} |
|
} |
|
#} finally { |
|
# #not strictly necessary as we'll tear down the interp |
|
# catch {rename ::package ""} |
|
# catch {rename ::package_orig ::package} |
|
#} |
|
# ** *** *** *** *** *** *** *** *** *** *** *** |
|
|
|
#note we will have entries for each different way package was requested |
|
set ::test::pkg_requested [lsort -unique $::test::pkg_requested] |
|
|
|
#foreach pkg $::test::pkg_requested { |
|
# set ver [package provide $pkg] |
|
# if {$ver eq ""} { |
|
# #puts stderr "missing pkg: $pkg" |
|
# lappend ::test::pkg_missing $pkg |
|
# } else { |
|
# if {[string tolower $pkg] eq "tcl"} { |
|
# #ignore |
|
# #continue |
|
# } |
|
# lappend ::test::pkg_loaded $pkg |
|
# } |
|
#} |
|
} |
|
#extract results from testpkgs interp |
|
set requested [interp eval testpkgs {set ::test::pkg_requested}] |
|
set loaded [interp eval testpkgs {set ::test::pkg_loaded}] |
|
set missing [interp eval testpkgs {set ::test::pkg_missing}] |
|
set broken [interp eval testpkgs {set ::test::pkg_broken}] |
|
set pkginfo [interp eval testpkgs {set ::test::pkg_info}] |
|
interp delete testpkgs |
|
|
|
#now run the normal package require on every pkg to see if our 'broken' assignments are correct? |
|
#by returning without error in our fake package require - we have potentially miscategorised some in both the 'broken' and 'loaded' categories. |
|
#a) - packages that are broken due to missing dependency but we haven't reported as such (the common case) |
|
#b) - packages that we reported as broken because they tried to use a function from an optional dependency we didn't error on |
|
#c) - other cases |
|
# |
|
#Note also by not erroring on a package require the package may have not attempted to load another package that would do the job. |
|
#This is a case where we may completely fail to report a one-of-n dependency for example |
|
# - hard to test without repeated runs :/ |
|
#todo - another interp? |
|
#a 'normal' run now may at least mark/unmark some 'broken' packages and give at least some better feedback. |
|
#we will test all discovered packages from the above process except those already marked as 'missing' |
|
#both 'broken' and 'loaded' are still suspect at this point. |
|
#we will attempt to load the -exact version that the previous test either appeared to load or fail in loading. |
|
#Presumably that is the one that would be loaded in the normal course anyway - REVIEW. |
|
#(as well as 'requestd' not guaranteed to be complete - but we will live with that for the purposes here) |
|
interp create normaltest |
|
interp eval normaltest [list package prefer [package prefer]] |
|
interp eval normaltest { |
|
set ::pkg_broken [list] |
|
set ::pkg_loaded [list] |
|
set ::pkg_errors [dict create] |
|
tcl::tm::remove {*}[tcl::tm::list] |
|
set ::auto_path [list] |
|
} |
|
|
|
set test_packages [list] |
|
foreach pkgrequest $requested { |
|
lassign $pkgrequest pkgname requirements_list |
|
if {$pkgrequest ni $missing} { |
|
if {[dict exists $pkginfo $pkgrequest version]} { |
|
set tried_version [dict get $pkginfo $pkgrequest version] |
|
} else { |
|
set tried_version "" |
|
} |
|
lappend test_packages [list $pkgname $tried_version $requirements_list] |
|
} |
|
} |
|
|
|
#sync interp package paths with current state of package/library paths |
|
interp eval normaltest [list ::tcl::tm::add {*}[tcl::tm::list]] |
|
interp eval normaltest [list set ::auto_path $::auto_path] |
|
interp eval normaltest [list set ::test_packages $test_packages] |
|
interp eval normaltest [list set ::argv0 $::argv0] |
|
interp eval normaltest [list set ::opt_quiet $opt_quiet] |
|
|
|
interp eval normaltest { |
|
foreach testinfo $::test_packages { |
|
lassign $testinfo pkgname ver requirements_list |
|
|
|
#if {$ver eq ""} { |
|
# set require_script [list package require $pkgname] |
|
#} else { |
|
# set require_script [list package require $pkgname $ver-$ver] ;#bounded same version - equivalent to -exact |
|
#} |
|
set require_script [list package require $pkgname {*}$requirements_list] |
|
|
|
#puts "finaltest $pkgname requested:$requirements_list" |
|
if {[catch $require_script result]} { |
|
lappend ::pkg_broken [list $pkgname $requirements_list] |
|
dict set ::pkg_errors [list $pkgname $requirements_list] $result |
|
} else { |
|
#result is version we actually got - without the previous interp's fudgery |
|
if {![llength $requirements_list] || [package vsatisfies $result {*}$requirements_list]} { |
|
lappend ::pkg_loaded [list $pkgname $requirements_list] |
|
} else { |
|
lappend ::pkg_broken [list $pkgname $requirements_list] |
|
dict set ::pkg_errors [list $pkgname $requirements_list] "Version conflict for package \"$pkgname\": have $result, need $requirements_list" |
|
#standard err msg but capital V to differentiate |
|
#Differs from standard in that we have normalised exacts to ver-ver - so will report in that form instead of e.g 0-1 -exact 1.0 1b3-2 |
|
} |
|
} |
|
} |
|
} |
|
set actually_failed [interp eval normaltest [list set ::pkg_broken]] |
|
set pkg_errors [interp eval normaltest [list set ::pkg_errors]] ;#dict |
|
set actually_loaded [list] |
|
set actually_loaded_names [list] |
|
set actually_broken [list] |
|
foreach pkgrequest $requested { |
|
if {$pkgrequest in $missing} { |
|
continue |
|
} |
|
if {$pkgrequest in $actually_failed} { |
|
lappend actually_broken $pkgrequest |
|
} else { |
|
lappend actually_loaded $pkgrequest |
|
if {[lindex $pkgrequest 0] ni $actually_loaded_names} { |
|
lappend actually_loaded_names [lindex $pkgrequest 0] |
|
} |
|
} |
|
} |
|
|
|
dict for {pkg_req err} $pkg_errors { |
|
dict set pkginfo $pkg_req error $err |
|
} |
|
|
|
interp delete normaltest |
|
set pkgstate [dict create requested $requested loaded $actually_loaded loadednames $actually_loaded_names missing $missing broken $actually_broken info $pkginfo] |
|
|
|
#debug |
|
#dict for {k v} $pkgstate { |
|
# puts stderr " - $k $v" |
|
#} |
|
return $pkgstate |
|
} |
|
|
|
|
|
#called when only-bootsupport or bootsupport+external module/lib paths active. |
|
#flags for ui-feature relevant packages |
|
proc ::punkboot::package_bools {pkg_availability} { |
|
set pkgbools [dict create] |
|
set requirements [dict create {*}{ |
|
overtype 1.6.5- |
|
textblock 0.1.1- |
|
punk::ansi 0.1.1- |
|
}] |
|
#'dict get $pkg_availability loaded] is a list of {pkgname requrement} pairs |
|
#set loaded_names [lmap i [lsearch -all -index 0 -subindices [dict get $pkg_availability loaded] *] {lindex $loaded $i}] ;#return list of first elements in each tuple |
|
set loaded_names [dict get $pkg_availability loadednames] ;#prebuilt list of names |
|
dict for {pkgname req} $requirements { |
|
#each req could in theory be a list |
|
if {$pkgname in $loaded_names} { |
|
#get first loaded match - use version from it (all info records for {pkgname *} should have same version that was actually loaded) |
|
set first_loaded [lsearch -inline -index 0 [dict get $pkg_availability loaded] $pkgname] |
|
set loaded_version [dict get $pkg_availability info $first_loaded version] |
|
if {![llength $req] || [package vsatisfies $loaded_version {*}$req]} { |
|
dict set pkgbools $pkgname 1 |
|
} else { |
|
dict set pkgbools $pkgname 0 |
|
} |
|
} else { |
|
dict set pkgbools $pkgname 0 |
|
} |
|
} |
|
return $pkgbools |
|
} |
|
proc ::punkboot::get_display_missing_packages {pkg_availability} { |
|
array set haspkg [punkboot::package_bools $pkg_availability] ;#convenience e.g if {$haspkg(textblock)} ... |
|
global A |
|
if {![array size A]} { |
|
punkboot::define_global_ansi |
|
} |
|
set missing_rows [list] |
|
set fields_blank_missing [dict create {*}{ |
|
status "" |
|
package "" |
|
version_requested "" |
|
versions "" |
|
optional "" |
|
recommended "" |
|
required_by "" |
|
}] |
|
foreach pkg_req [dict get $pkg_availability missing] { |
|
lassign $pkg_req pkgname requirements_list |
|
set fields $fields_blank_missing |
|
dict set fields status "missing" |
|
dict set fields package $pkg_req |
|
if {[dict exists $::punkboot::bootsupport_optional $pkgname]} { |
|
dict set fields optional " ${A(OK)}(known optional)$A(RST)" |
|
} |
|
if {[dict exists $::punkboot::bootsupport_recommended $pkgname]} { |
|
dict set fields recommended "${A(HIGHLIGHT)}(RECOMMENDED)$A(RST)" |
|
} |
|
if {[dict exists $pkg_availability info $pkg_req required_by]} { |
|
dict set fields required_by [dict get $pkg_availability info $pkg_req required_by] |
|
} |
|
lappend missing_rows $fields |
|
} |
|
set missing_out "" |
|
set c1_width 40 |
|
foreach row $missing_rows { |
|
if {$haspkg(overtype)} { |
|
set line " [overtype::left [string repeat " " $c1_width] $A(BWHITE)[dict get $row package]$A(RST)]" |
|
} else { |
|
set line " [format "%-*s" $c1_width [dict get $row package]]" |
|
} |
|
append line " [dict get $row status]" |
|
append line " [dict get $row optional]" |
|
append line " [dict get $row recommended]" |
|
append line " requested_by:[join [dict get $row required_by] {, }]" |
|
append missing_out $line \n |
|
} |
|
return $missing_out |
|
} |
|
proc ::punkboot::get_display_broken_packages {pkg_availability} { |
|
array set haspkg [punkboot::package_bools $pkg_availability] ;#convenience e.g if {$haspkg(textblock)} ... |
|
global A |
|
if {![array size A]} { |
|
punkboot::define_global_ansi |
|
} |
|
set broken_rows [list] |
|
set fields_blank_broken [dict create {*}{ |
|
status "" |
|
package "" |
|
version "" |
|
optional "" |
|
recommended "" |
|
required_by "" |
|
error "" |
|
}] |
|
foreach pkg_req [dict get $pkg_availability broken] { |
|
lassign $pkg_req pkgname vrequested |
|
set fields $fields_blank_broken |
|
dict set fields status "broken" |
|
dict set fields package $pkg_req |
|
|
|
if {[dict exists $pkg_availability info $pkg_req version]} { |
|
dict set fields version [dict get $pkg_availability info $pkg_req version] |
|
} |
|
|
|
if {[dict exist $::punkboot::bootsupport_optional $pkgname]} { |
|
dict set fields optional "${A(OK)}(known optional)$A(RST)" |
|
} |
|
|
|
if {[dict exists $::punkboot::bootsupport_recommended $pkgname]} { |
|
dict set fields recommended "${A(HIGHLIGHT)}(RECOMMENDED)$A(RST)" |
|
} |
|
|
|
set requiredby_list [list] |
|
if {[dict exists $::punkboot::bootsupport_requirements $pkgname]} { |
|
#punkboot also asked for this pkgname |
|
#the question of what other packages would also be satisfied had this request not been broken isn't necessarily something we need to answer here |
|
#we do so for punkboot anyway - but it's inclusion as 'requiredby or requestedby' isn't strictly accurate - |
|
# it is more like: would also be satisfied by |
|
#what is 'broken' may depend on what order packages were loaded |
|
#e.g if a package already required a specific low version (that was optional for it) that another then fails on because a different version was not optional for that later package. |
|
#puts stderr "$pkgname===$::punkboot::bootsupport_requirements" |
|
set pboot_required [dict get $::punkboot::bootsupport_requirements $pkgname version] ;#version key always present and empty or normalised |
|
if {[list $pkgname $pboot_required] eq $pkg_req} { |
|
#pboot had same requirespec as this broken record |
|
set requiredby_list [list punkboot] |
|
} elseif {[dict exists $pkg_availability info $pkg_req version]} { |
|
set vtried [dict get $pkg_availability info $pkg_req version] |
|
if {[dict exists $pkg_availability broken [list $pkgname $pboot_required]]} { |
|
#punkboot didn't get what it wanted directly |
|
if {$pboot_required eq "" || [package vsatisfies $vtried $pboot_required]} { |
|
#REVIEW |
|
#e.g punkboot might require no specific version - and this fail record might be for a specific version |
|
#we only list punkboot against this request if it's request also failed - but would be satisfied by this failure if it had worked |
|
set requiredby_list [list punkboot] |
|
} |
|
} |
|
} |
|
} |
|
if {[dict exists $pkg_availability info $pkg_req required_by]} { |
|
lappend requiredby_list {*}[dict get $pkg_availability info $pkg_req required_by] |
|
} |
|
dict set fields required_by $requiredby_list |
|
|
|
if {[dict exists $pkg_availability info $pkg_req error]} { |
|
dict set fields error "[dict get $pkg_availability info $pkg_req error]" |
|
} |
|
|
|
lappend broken_rows $fields |
|
} |
|
set broken_out "" |
|
set c1_width 40 |
|
set c3_width 20 |
|
set c3 [string repeat " " $c3_width] |
|
foreach row $broken_rows { |
|
if {$haspkg(overtype)} { |
|
set line " [overtype::left [string repeat " " $c1_width] $A(BAD)[dict get $row package]$A(RST)]" |
|
} else { |
|
set line " [format "%-*s" $c1_width [dict get $row package]]" |
|
} |
|
append line " [dict get $row status]" |
|
if {[dict get $row version] ne ""} { |
|
set txt " ver:[dict get $row version]" |
|
append line [format "%-*s" $c3_width $txt] |
|
} else { |
|
append line $c3 |
|
} |
|
if {[dict get $row optional] ne ""} { |
|
append line [dict get $row optional] |
|
} |
|
if {[dict get $row recommended] ne ""} { |
|
append line [dict get $row recommended] |
|
} |
|
if {[dict get $row required_by] ne ""} { |
|
append line " requested_by:[join [dict get $row required_by] {, }]" |
|
} |
|
if {[dict get $row error] ne ""} { |
|
append line " err:[dict get $row error]" |
|
} |
|
append broken_out $line \n |
|
} |
|
return $broken_out |
|
} |
|
proc ::punkboot::define_global_ansi {} { |
|
#stick to basic colours for themable aspects ? |
|
# |
|
set has_ansi [expr {[package provide punk::ansi] ne ""}] |
|
|
|
global A |
|
if {!$has_ansi} { |
|
if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { |
|
set A(RST) "" |
|
set A(HIGHLIGHT) "" |
|
set A(BWHITE) "" |
|
set A(OK) "" |
|
set A(BAD) "" |
|
set A(ERR) "" |
|
} else { |
|
set A(RST) \x1b\[m |
|
set A(HIGHLIGHT) \x1b\[93m ;#brightyellow |
|
set A(BWHITE) \x1b\[97m ;#brightwhite |
|
set A(OK) \x1b\[92m ;#brightgreen |
|
set A(BAD) \x1b\[33m ;# orange |
|
set A(ERR) \x1b\[31m ;# red |
|
} |
|
} else { |
|
namespace eval ::punkboot { |
|
namespace import ::punk::ansi::a+ ::punk::ansi::a |
|
} |
|
if {[info exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { |
|
#G-113: the A() palette is colour-only highlighting - when colour is |
|
#disabled every entry (including RST) is empty rather than relying on |
|
#a+/a colour stripping (a bare reset would survive as a non-colour code). |
|
set A(RST) "" |
|
set A(HIGHLIGHT) "" |
|
set A(BWHITE) "" |
|
set A(OK) "" |
|
set A(BAD) "" |
|
set A(ERR) "" |
|
} else { |
|
set A(RST) [a] |
|
set A(HIGHLIGHT) [a+ brightyellow] |
|
set A(BWHITE) [a+ brightwhite] |
|
set A(OK) [a+ web-lawngreen] ;#brightgreen |
|
set A(BAD) [a+ web-orange] |
|
set A(ERR) [a+ web-indianred] ;#easier on the eyes than standard red on some screens |
|
} |
|
} |
|
} |
|
proc ::punkboot::punkboot_gethelp {args} { |
|
#we have currently restricted our package paths to those from 'bootsupport' |
|
#gather details on what is missing so that the info is always reported in help output. |
|
variable pkg_availability |
|
global A |
|
punkboot::define_global_ansi |
|
|
|
array set haspkg [punkboot::package_bools $pkg_availability] ;#convenience e.g if {$haspkg(textblock)} ... |
|
|
|
set scriptname [file tail [info script]] |
|
append h "Usage:" \n |
|
append h "" \n |
|
append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n |
|
append h " - This help." \n \n |
|
append h " $scriptname bakehouse ?-k? ?-dirty-abort 1|0?" \n |
|
append h " - consumer run from a clean checkout: mints the packages (modules + libs) then bakes kit/zipkit executables to <projectdir>/bin" \n |
|
append h " - refuses uncommitted src by default (-dirty-abort defaults ON: the bakehouse bakes from the committed recipe; pass -dirty-abort 0 to override)" \n |
|
append h " - the optional -k flag will terminate running processes matching the executable being baked (if applicable)" \n |
|
append h " - does NOT run the promotion gates (bootsupport, vfscommonupdate) - on a clean checkout they are already satisfied by the committed tree" \n \n |
|
append h " $scriptname bake ?-k? ?kitname ...?" \n |
|
append h " - assemble kit/zipkit executables from the promoted payload (src/vfs) and src/runtime runtimes into <projectdir>/bin" \n |
|
append h " - includes the vfslibs phase; does not re-mint modules/libs and does not run the promotion gates" \n |
|
append h " - with kitname arguments, bakes and deploys only the named configured kits (unknown names error before any bake)" \n \n |
|
append h " $scriptname bakelist ?kitname ...?" \n |
|
append h " - list the kit outputs configured in src/runtime/mapvfs.toml: name, kit type, runtime (with presence)," \n |
|
append h " vfs folder and deployed state (bin copy absent/current/stale/nobake vs the src/_bake product)" \n |
|
append h " - kitname arguments filter to the named entries (per-kit detail)" \n \n |
|
append h " $scriptname modules" \n |
|
append h " - mint (stamp real versions, pack modpods; plain copy where no stamping applies) .tm modules from src/modules src/vendormodules etc to their corresponding locations under <projectdir>" \n |
|
append h " This does not scan src/runtime and src/vfs folders to bake kit/zipkit/cookfs executables" \n \n |
|
append h " $scriptname libs" \n |
|
append h " - mint (or plain copy where no stamping applies) pkgIndex.tcl based libraries from src/lib src/vendorlib etc to their corresponding locations under <projectdir>" \n |
|
append h " This does not scan src/runtime and src/vfs folders to bake kit/zipkit/cookfs executables" \n \n |
|
append h " $scriptname packages" \n |
|
append h " - mint both .tm and pkgIndex.tcl based packages from src to their corresponding locations under <projectdir> (= modules + libs)" \n |
|
append h " This does not scan src/runtime and src/vfs folders to bake kit/zipkit/cookfs executables" \n \n |
|
append h " $scriptname bootsupport" \n |
|
append h " - update the src/bootsupport modules" \n |
|
append h " - bootsupport modules are pulled from locations specified in include_modules.config files within each src/bootsupport subdirectory" \n |
|
append h " - project layouts store no bootsupport module snapshots: generated projects get bootsupport injected at generation time by 'dev project.new'" \n |
|
append h " - This should usually be from modules that have been minted and tested in <projectdir>/modules <projectdir>/lib etc." \n |
|
append h " - bootsupport modules are available to make.tcl" \n \n |
|
append h " $scriptname vendorupdate" \n |
|
append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n |
|
append h " - update the src/vendorlib based on src/vendorlib/config.toml (todo)" \n \n |
|
append h " $scriptname vfslibs" \n |
|
append h " - propagate declared platform-library packages (vendored src/ or bin/packages tier) into kit vfs lib_tcl<N> trees" \n |
|
append h " - declarations (per-package per-kit, with superseded-version removal + clean-slate replace) live in src/runtime/vendorlib_vfs.toml" \n |
|
append h " - also runs automatically as a phase of '$scriptname bake' (and therefore of '$scriptname bakehouse')" \n \n |
|
append h " $scriptname libfetch ?-serverurl <url>? ?-trust-server? ?-force?" \n |
|
append h " - fetch declared punkbin lib-tier library artifacts (src/runtime/libpackages.toml) into bin/packages/<target>" \n |
|
append h " - sha1-verified against the server's per-target sha1sums.txt; materializes package trees under bin/packages/<target>/tcl<N>" \n |
|
append h " - canonical origin trusted by default; other servers (incl. PUNKBIN_URL overrides) require -trust-server" \n \n |
|
append h " $scriptname vfscommonupdate" \n |
|
append h " - promotion gate: update the src/vfs/_vfscommon.vfs kit payload from the minted <projectdir> module/lib trees" \n |
|
append h " - before calling this (followed by '$scriptname bake') - you can test using '<builtexe>(.exe) minted'" \n |
|
append h " this will load modules from your <projectdir>/module <projectdir>/lib paths instead of from the kit/zipkit" \n \n |
|
append h " $scriptname info" \n |
|
append h " - show the name and base folder of the project" \n \n |
|
append h " $scriptname check" \n |
|
append h " - show module/library paths and any potentially problematic packages for running this script" \n |
|
append h " $scriptname shell" \n |
|
append h " - run the punk shell using bootsupport libraries." \n |
|
append h " $scriptname projectversion" \n |
|
append h " - advisory check: verify CHANGELOG.md matches punkproject.toml and warn if src/ has changes since the last project-version bump." \n \n |
|
append h " $scriptname workflow" \n |
|
append h " - print an ASCII data-flow overview of the release workflow (edit -> mint -> promote -> bake) incl. the TERMINOLOGY key" \n \n |
|
append h " $scriptname buildsuite list|info|build ?<suitename>? ?driver-args ...?" \n |
|
append h " - list the defined buildsuites under src/buildsuites (zig runtime factory), show a suite's configured" \n |
|
append h " detail (sources/zig pin/products from its sources.config), or run its driver forwarding the args" \n \n |
|
append h " $scriptname tool list ?<toolname> ...?" \n |
|
append h " $scriptname tool info <toolname> ..." \n |
|
append h " $scriptname tool build ?-test 0|1? ?<toolname> ...?" \n |
|
append h " $scriptname tool test ?<toolname> ...?" \n |
|
append h " - vendored first-party build tools under src/tools (zig source; G-126): list/detail them, run their" \n |
|
append h " test suites, or build (test-gated) and install to <projectdir>/bin; options precede the tool names" \n |
|
append h " - zig is OPTIONAL: packages/bake never require this step; without a suitable toolchain the state is" \n |
|
append h " reported and build/test exit nonzero with fetch guidance (bin/punk-getzig.cmd)" \n \n |
|
append h " $scriptname help ?subcommand? ?arg ...?" \n |
|
append h " - show usage for $scriptname or one of its subcommands (equivalent: $scriptname <subcommand> -help);" \n |
|
append h " extra words are the subcommand's own command line, dry-run through its declaration - an accepted" \n |
|
append h " line shows the matched action's usage (tool, buildsuite), a rejected line that subcommand's own" \n |
|
append h " usage error (tabled help only)" \n \n |
|
append h " Flags:" \n |
|
append h " -confirm 0|1" \n |
|
append h " - interactive y/n confirmation policy (default 1: prompt when stdin is a terminal, abort fast when it is not)." \n |
|
append h " Use -confirm 0 for unattended runs: the bootsupport minor-staleness gate and the vfscommonupdate REPLACE" \n |
|
append h " confirmation proceed without prompting; kits with a source/target kit-type mismatch are skipped." \n |
|
append h " -dirty-abort" \n |
|
append h " - abort producing commands (mint/promote/bake: bakehouse packages modules libs bake vfslibs bin bootsupport vfscommonupdate) when src/ has" \n |
|
append h " uncommitted VCS changes. Default is warn-only EXCEPT bakehouse (defaults ON there; -dirty-abort 0 overrides):" \n |
|
append h " artifacts produced from dirty src have no committed provenance." \n |
|
append h " Warnings carry a plain PROVENANCE-WARNING: prefix (greppable in redirected output) and are recapped at the end of the run." \n |
|
append h " Use '$scriptname check' to see the current provenance status. To evaluate uncommitted source without minting or baking," \n |
|
append h " use '<builtexe> src' or '<builtexe> src shell'." \n \n |
|
append h "" \n |
|
append h [punkboot_availability_note] |
|
return $h |
|
} |
|
#Embedded release-workflow overview - the output of the 'workflow' subcommand. |
|
#Embedded (rather than a data file) so it travels with make.tcl wherever it runs, including |
|
#the make.tcl copies seeded into generated projects via the project layouts. |
|
#Contract for updates (see also src/AGENTS.md 'Work Guidance'): when make.tcl data flow changes |
|
#(subcommand added/removed/repurposed, source or output folder flow changed, new propagation |
|
#target), this text changes in the same commit. Plain ASCII only, max line width 100. |
|
proc ::punkboot::workflow_text {} { |
|
set txt { |
|
mint, promote & bake - the release workflow from module edit to kits + bootsupport (punk layout) |
|
============================================================================= |
|
Scope: data flow from editing a module under src/ through to a release-ready |
|
refresh (minted packages, bootsupport refresh, kit vfs, kit executables). |
|
All commands run from the projectroot with a native tclsh, e.g: |
|
tclsh src/make.tcl <subcommand> -confirm 0 (see [K6]) |
|
|
|
|
|
TERMINOLOGY (stage verbs - one word, one stage) |
|
---------------------------------------------------------------------------- |
|
build compile source to binaries. Lives in the arm's-length factories: |
|
'make.tcl buildsuite' (whole Tcl runtimes from external sources, |
|
src/buildsuites, workdir src/buildsuites/_build) and 'make.tcl |
|
tool build' (vendored zig tools, src/tools). Nothing in |
|
mint/promote/bake compiles anything: bakes succeed with no build |
|
toolchain installed. |
|
mint stamp real versions onto magic-version sources (999999.0a1.0 -> |
|
the <pkg>-buildversion.txt value), pack #modpod-* trees, prune |
|
superseded copies and install the results into the projectroot |
|
trees (modules*/ lib*/). The modules/libs/packages subcommands |
|
are the mint stage; staging area <srcdir>/_mint. |
|
promote propagate minted packages into the two gated consumption trees: |
|
src/bootsupport (make.tcl's own boot environment) and |
|
src/vfs/_vfscommon.vfs (the committed kit payload) - the |
|
bootsupport and vfscommonupdate promotion gates. |
|
bake assemble kit/zipkit executables from promoted payload + runtimes |
|
(workdir src/_bake) and deploy them to bin/. Consumer umbrella: |
|
bakehouse = mint + bake from the committed recipe. |
|
fetch bring third-party inputs to the tree: libfetch (punkbin lib |
|
artifacts), vendorupdate (vendored sources). |
|
deploy the final copy of a baked kit from src/_bake to bin/<kit>. |
|
Mechanism words keep their scoped meanings: stamp (version fields at mint, |
|
icons/resources at bake via punkres), install (punkcheck-recorded placement |
|
at any stage), sync (thin-layout copies), materialize (vfslibs payload |
|
declarations, libfetch trees). |
|
|
|
TWO PERSONAS (stage-true subcommand model - one mint stage, two promotion |
|
gates, one bake) |
|
---------------------------------------------------------------------------- |
|
CONSUMER (clean checkout, wants baked kits): |
|
tclsh src/make.tcl bakehouse -confirm 0 |
|
= packages + bake in one uninterrupted run. The promotion gates are already |
|
satisfied by the committed tree. bakehouse REFUSES uncommitted src by |
|
default (-dirty-abort defaults ON: the bakehouse bakes from the committed |
|
recipe; -dirty-abort 0 overrides). |
|
DEVELOPER (changing payload): pass the gates explicitly - the commit is the |
|
publishing act, not a producing step. That is the RELEASE SEQUENCE below. |
|
|
|
RELEASE SEQUENCE (the developer order that satisfies the staleness + provenance gates) |
|
---------------------------------------------------------------------------- |
|
|
|
(1) edit src/modules/foo-999999.0a1.0.tm code change [K1] |
|
(2) bump src/modules/foo-buildversion.txt module version + changelog comment |
|
punkproject.toml + CHANGELOG.md project version (if shipped behaviour) [K2] |
|
(3) test tclsh src/tests/runtests.tcl ... runs against src/ trees (if present) |
|
(4) commit source changes (git/fossil) clean tree -> committed provenance [K3] |
|
(5) mint tclsh src/make.tcl modules -confirm 0 (or 'packages' = modules + libs) |
|
(6) promote tclsh src/make.tcl bootsupport -confirm 0 run twice: 2nd pass must copy 0 files [K4] |
|
(7) promote tclsh src/make.tcl vfscommonupdate -confirm 0 |
|
(8) bake tclsh src/make.tcl bake -confirm 0 kits; close running kit shells first [K5] |
|
(9) commit tracked output trees src/bootsupport, thin-layout script/ |
|
manifest/gitignore.in payload copies |
|
(src/project_layouts + |
|
templates modpod payload), |
|
src/vfs/_vfscommon.vfs |
|
|
|
|
|
DIAGRAM 1 - DATA FLOW: SOURCE -> MINTED PACKAGES -> PROMOTION TARGETS |
|
---------------------------------------------------------------------------- |
|
|
|
src/modules/foo-999999.0a1.0.tm [K1] src/lib/ |
|
src/modules/foo-buildversion.txt src/vendorlib/ |
|
src/vendormodules/ (+ *_tcl9 variants) | |
|
| | |
|
| make.tcl modules | make.tcl libs |
|
| (stamp real version, pack #modpod-*, | |
|
| prune superseded) | |
|
v v |
|
modules/ modules_tcl8/ modules_tcl9/ lib/ lib_tcl8/ lib_tcl9/ |
|
e.g. modules/foo-0.12.4.tm |
|
== MINTED PACKAGES (projectroot output trees, punkcheck-recorded [K3]) == |
|
| |
|
+--------------------------------------+ |
|
| | |
|
| make.tcl bootsupport [K4] | make.tcl vfscommonupdate |
|
| (curated subset) | (REPLACE semantics: vfs modules/libs |
|
v | are overwritten with built set) |
|
src/bootsupport/modules/ v |
|
(the module set make.tcl itself src/vfs/_vfscommon.vfs/modules/ + libs |
|
boots from; staleness-gated. (VCS-tracked kit payload source) |
|
Project layouts store NO module | |
|
snapshots - 'dev project.new' | make.tcl bake (kit-assembly stage; |
|
injects bootsupport into generated v consumer umbrella: bakehouse) |
|
projects from the generating src/_bake/<kit>.exe --deploy--> bin/<kit>.exe |
|
shell at generation time - G-087) (see DIAGRAM 2) [K5] |
|
|
|
|
|
DIAGRAM 1b - THIN-LAYOUT SYNC (part of modules/libs/packages/bakehouse runs) |
|
---------------------------------------------------------------------------- |
|
|
|
.gitignore src/make.tcl src/build.tcl src/bootsupport/modules*/include_modules.config |
|
| |
|
| punkcheck-recorded copies: root .gitignore -> every vendor layout's inert |
|
| gitignore.in payload (G-012; materialized to .gitignore at generation), |
|
| scripts/manifests -> each vendor layout carrying src/make.tcl |
|
v |
|
src/project_layouts/vendor/punk/<layout>/src/... (thin layouts: scripts, docs, |
|
| manifests - no module snapshots) |
|
| store -> modpod payload sync (punk.project layout only; excludes bin/sdx.kit) |
|
v |
|
src/modules/punk/mix/#modpod-templates-*/templates/project_layouts/ |
|
(packed into the punk::mix::templates module by the modules mint, so a bare |
|
kit outside any project can list and generate the punk.project layout) |
|
|
|
|
|
DIAGRAM 2 - KIT ASSEMBLY DETAIL (the 'make.tcl bake' stage; incl. vfslibs phase) |
|
---------------------------------------------------------------------------- |
|
|
|
src/runtime/mapvfs.toml which vfs folder pairs with which runtime -> kit name |
|
([kit.<name>] tables; tomlish-parsed - G-024), incl. the |
|
runtime's TARGET PLATFORM [K9], smoke-require packages, |
|
named groups and generative version-named schemes |
|
(deprecated mapvfs.config line format still readable) |
|
'make.tcl bakelist ?name|@group ...?' reports the |
|
configured kit outputs (presence + deployed state); |
|
'make.tcl bake ?name|@group ...?' bakes only the named |
|
kits (bare bake = all entries except bake_default=false |
|
ones; unknown names error before any bake) |
|
bin/runtime/<target>/<runtime> bare Tcl runtime (tclkit / tclsfe / suite build), in the |
|
store tier of the TARGET platform it bakes kits for [K9] |
|
src/vfs/_vfscommon.vfs/ common payload (minted modules + libs, main boot support) |
|
src/vfs/<kitspecific>.vfs/ per-kit overlay (main.tcl, kit-only modules/config) |
|
src/vfs/<kitspecific>.vfs.toml optional per-.vfs payload declaration (G-115): [payload.*] |
|
entries materialized INTO the .vfs folder by the vfslibs |
|
phase (vendor trees / bin/packages tier), punkcheck- |
|
tracked with drop-in-wins precedence - undeclared or |
|
hand-modified files are preserved, never overwritten. |
|
A source containing %platform% materializes once per |
|
CONSUMING KIT TARGET (set derived from mapvfs) into |
|
_targets/<platform>/ staging; each kit's merged image |
|
then gets only its own target's subtree (G-127) |
|
|
|
_vfscommon.vfs <kitspecific>.vfs <-- payload declarations (if any) already |
|
| | materialized by the vfslibs phase |
|
+-----------+----------+ |
|
| copy common, then merge overlay over it |
|
v |
|
src/_bake/<kit>.exe.vfs |
|
| |
|
| advisory payload/target binary-arch scan of the merged |
|
| tree (wrong-arch libraries -> recapped BAKE-WARNING) [K11] |
|
| boot-precondition gate: merged vfs must supply a tcl |
|
| library (tcl_library/, lib/tcl<M>.<m>/, tcl<M>.<m>/) [K10] |
|
v |
|
(gate) --> refused: kit listed under FAILED KITS, nothing |
|
| built, nothing deployed, bin/<kit> untouched |
|
| |
|
| kit icon step (G-057): <kit>.resources.toml sidecar records |
|
| the icon choice for every target (default src/runtime/ |
|
| punkshell.ico; override = punkshell.ico in the kit's own .vfs |
|
| folder, pre-merge); win32 targets on a twapi-capable host get |
|
| the icon stamped into a per-kit copy of the raw runtime stub |
|
| BEFORE the payload attach (non-PE target: not applicable; |
|
| incapable host: distinct notice - sidecar written either way) |
|
| |
|
| zip image appended to the (stamped) runtime exe: tcl::zipfs:: |
|
| mkimg, or (driving tcl without zipfs, e.g 8.6) raw-runtime |
|
| split + punk::zip::mkzip + concatenation - both mount the same |
|
v |
|
src/_bake/<kit>.exe (+ <kit>.exe.resources.toml) |
|
| |
|
| smoke-require probe (host-runnable kits with declared |
|
| packages): plain 'package require' inside the artifact [K11] |
|
| deploy step: delete old bin/<kit>.exe, copy new one in |
|
| (the resource sidecar deploys beside the kit) |
|
v |
|
bin/<kit>.exe <-- FAILS (kit listed under FAILED KITS) if a |
|
running shell still holds the old exe [K5] |
|
|
|
|
|
LIBRARY-ARTIFACT FETCH + CONSUMPTION (G-139) |
|
---------------------------------------------------------------------------- |
|
|
|
src/runtime/libpackages.toml which punkbin LIB-TIER artifacts this checkout |
|
consumes (declared artifact names + targets) |
|
| |
|
| 'make.tcl libfetch' - sha1-verified download of the declared |
|
| <pkg>-<tcl8|tcl9>-r<N>.zip artifacts + .toml sidecars from |
|
| <origin>/lib/<target>/ (canonical punkbin origin trusted by |
|
| default; -serverurl/PUNKBIN_URL override needs -trust-server; |
|
| file:// origins serve local mirrors/fixtures), then |
|
| materialization of each verified zip's package tree |
|
v |
|
bin/packages/<target>/ verified -r<N> zips + toml sidecars (input tier, |
|
untracked - mirrors bin/runtime/<target>) |
|
bin/packages/<target>/tcl<N>/<pkgfolder>/ |
|
materialized installed-shape trees, self-describing |
|
via their embedded punkbin-artifact.toml records |
|
| |
|
| consumption (two lanes, both punkcheck-tracked): |
|
| PACKAGES_tcl<N> phase of modules/libs/packages/bakehouse |
|
| -> lib_tcl<N>/allplatforms + lib_tcl<N>/<platform>; |
|
| per-.vfs payload declarations (src/vfs/<kit>.vfs.toml, |
|
| G-115) with source_root = "packages" |
|
| -> declared kit vfs lib_tcl<N> trees (see DIAGRAM 2) |
|
v |
|
lib_tcl<N>/... + src/vfs/<kit>.vfs/lib_tcl<N>/... (embedded records ride along |
|
into deployed trees and baked kit payloads) |
|
|
|
|
|
KEY / NOTES |
|
---------------------------------------------------------------------------- |
|
[K1] Source modules carry the literal magic version 999999.0a1.0 in the filename. |
|
The real version is the first line of the sibling <modulename>-buildversion.txt; |
|
bump it per semver (patch=fix, minor=api add, major=breaking) and append a |
|
'#<version> - ...' changelog comment line below it. The mint stamps |
|
the real version into the output filename and package provide. |
|
(A project may carry manually-versioned exceptions - see src/modules/AGENTS.md |
|
if present.) |
|
|
|
[K2] Project version (punkproject.toml [project] version + matching CHANGELOG.md |
|
entry) is change-driven: bump when the change ships user-visible behaviour. |
|
Advisory check: tclsh src/make.tcl projectversion |
|
|
|
[K3] Every output target root gets a .punkcheck file recording what was installed |
|
from where (punkcheck provenance). Minting/promoting/baking from a tree with |
|
uncommitted changes under src/ works but emits PROVENANCE-WARNINGs - commit |
|
source first for release runs. Output-tree commits (step 9) come after the |
|
producing steps. |
|
|
|
[K4] Bootsupport staleness gate: make.tcl compares tracked module versions in |
|
src/bootsupport against built sources; a stale bootsupport makes other |
|
subcommands warn/prompt/abort (per bump level) unless -confirm 0. After a |
|
tracked module bump, refresh with 'make.tcl bootsupport' and rerun it until |
|
a pass copies 0 files (a converged second pass also proves prune tooling ran). |
|
|
|
[K5] The deploy step cannot replace a kit exe that is currently executing. Close |
|
running kit shells before step 8, or rerun 'make.tcl bake -confirm 0' |
|
afterwards - the freshly baked kits wait in src/_bake. punkcheck records |
|
mean the rerun only redoes the failed deploys. When iterating on one kit, |
|
'make.tcl bake <kitname>' rebakes/deploys just that kit; 'make.tcl |
|
bakelist' shows each configured kit's deployed state (bin vs src/_bake). |
|
|
|
[K6] All confirmation prompts follow -confirm: unattended/agent runs must pass |
|
-confirm 0 (non-interactive stdin aborts fast at prompts; piping 'y' is |
|
retired). 'make.tcl help <subcommand>' shows per-subcommand usage. |
|
|
|
[K7] Testing hooks along the way: |
|
- src/tests/runtests.tcl exercises the src/ trees directly (dev modules). |
|
- '<builtkit>.exe minted' runs a built shell against the mint output trees |
|
(<projectroot>/modules etc) - useful for testing minted packages before |
|
they are baked into kits via vfscommonupdate + bake; '<builtkit> src' |
|
runs against the unbuilt src/ dev modules. |
|
|
|
[K8] What is VCS-tracked where (checkin targets after a make.tcl run): |
|
tracked: src/** (sources, src/bootsupport, src/project_layouts copies, |
|
src/vfs/_vfscommon.vfs), punkproject.toml, CHANGELOG.md |
|
untracked: modules*/ lib*/ at projectroot, src/_bake/, bin/<kit>.exe, |
|
bin/kits/<platform>/ (cross-target kit outputs - G-127), |
|
src/vfs/*.vfs/_targets/ (per-platform payload staging) |
|
(bin/ scripts/tools are tracked; kit executables are not) |
|
|
|
[K9] HOST vs TARGET platform (G-122). What a bake EMITS is keyed by the target |
|
platform, never by the driving tclsh's personality: which bin/runtime/<tier> |
|
holds the runtime, whether the runtime file and the built kit carry .exe, and |
|
whether the pre-deploy sweep uses tasklist/taskkill or ps/kill. The default |
|
target is this host's own platform - except a cygwin-family host (an |
|
msys2/cygwin-runtime tclsh, which reports platform 'unix' on windows), which |
|
targets win32. A mapvfs.toml entry may declare its own target (target key; |
|
legacy config: 4th element) and is then read from that platform's tier, named |
|
with its executable convention, and (being unrunnable here) skipped by the |
|
process sweep. |
|
'make.tcl check' prints the derivation; 'make.tcl bakelist' shows per-kit |
|
targets, with a target= note on rows that are not on the default target. |
|
OUTPUT locations are target-keyed too (G-127): default-target kits keep the |
|
flat src/_bake/<kit> + bin/<kit> locations, any other target's kit bakes |
|
and deploys under the kits/<platform>/ tier of both (bin/kits/ = outputs, |
|
beside bin/runtime/ = inputs), so same-named kits for different targets |
|
coexist instead of overwriting each other; bakelist marks such rows with |
|
out=kits/<platform>/ and its detail block prints the tiered paths. |
|
|
|
[K10] BOOT-PRECONDITION gate (G-125). A kit whose merged vfs has no tcl library |
|
cannot initialise at all ('Cannot find a usable init.tcl'), so the bake |
|
refuses it: the kit is listed under FAILED KITS and NOTHING is written - |
|
no src/_bake/<kit>, no deploy, and the previously deployed bin/<kit> is |
|
left exactly as it was. This is deliberately not a warning: the deploy step |
|
deletes the old kit before copying the new one, so warning-and-proceeding |
|
replaced a working shell with one that could not start. The check is |
|
structural - init.tcl in tcl_library/, lib/tcl<major>.<minor>/ or |
|
tcl<major>.<minor>/ (that last one for runtimes whose archive mounts at the |
|
executable's own path rather than //zipfs:/app), plus a companion file so a |
|
package's own init.tcl cannot answer for a tcl library - and runs on the |
|
MERGED tree, not on whether extraction ran - a .vfs that |
|
supplies its own tcl library bakes and deploys as normal. Nothing is |
|
executed, so cross-target kits are covered too. Usual cause: the runtime's |
|
own payload could not be extracted - see the BAKE-WARNING naming what was |
|
tried. 'make.tcl check' reports whether the gate is ACTIVE. |
|
|
|
[K11] PAYLOAD/TARGET consistency checks (G-133), both ADVISORY - warnings recap at |
|
end of run, the kit still bakes and deploys. (a) Binary-arch scan at the same |
|
seam as [K10]: each binary library (*.dll/*.so/*.dylib) in the merged tree is |
|
classified by header (PE/ELF/Mach-O - structural, nothing executed, so |
|
cross-target kits are covered) against the kit's target platform; wrong-arch |
|
libraries outside platform-discriminated subdirs (win32-ix86/, win-x64/ etc - |
|
multi-arch payloads are legitimate there) earn recapped BAKE-WARNINGs. |
|
(b) Smoke-require probe: a kit declaring packages (mapvfs.toml smokerequire |
|
key; legacy config: 5th element) has each one plain-'package require'd INSIDE the freshly built |
|
artifact via its tclsh subcommand - the only check that sees resolution-order |
|
defects (a wrong-arch higher-versioned package shadowing a working copy); |
|
cross-target kits skip with a stated reason, undeclared kits run nothing new. |
|
What neither check guarantees: statically linked packages, pure-tcl packages |
|
with binary dependencies, and version-preference outcomes are visible only to |
|
the smoke probe - and only for declared packages. 'make.tcl check' reports both. |
|
|
|
OUT-OF-BAND SUBSYSTEMS (not part of the packages/bake data flow above) |
|
'make.tcl tool' builds the vendored first-party zig tools under src/tools |
|
(G-126; punkzip first) into <projectdir>/bin, gated on each tree's own |
|
'zig build test' exit code. zig is OPTIONAL: packages/bake never require it. |
|
'make.tcl buildsuite' is the analogous arm's-length factory for whole Tcl |
|
runtimes built from EXTERNAL sources under src/buildsuites (fetch + test-gate |
|
contract per suite; products land in the bin/runtime store tiers). |
|
|
|
MAINTENANCE (agents take note) |
|
---------------------------------------------------------------------------- |
|
This text is embedded in make.tcl (::punkboot::workflow_text). When the make.tcl |
|
data flow changes - a make.tcl subcommand added/removed/repurposed, a source or |
|
output folder added or rerouted, a new propagation target, a changed gate or |
|
deploy behaviour - update this text in the same change-set and verify with |
|
'tclsh src/make.tcl workflow'. Plain ASCII only; max line width 100. A make.tcl |
|
interface change is product surface: bump the project version (at least patch). |
|
} |
|
return [string trim $txt \n] |
|
} |
|
#Missing/broken bootsupport-package NOTE shown with help output. |
|
#Factored out of punkboot_gethelp (G-030) so both the punk::args tabled help path and the |
|
#plain-text fallback help append the same information. Returns "" when there is nothing to report. |
|
proc ::punkboot::punkboot_availability_note {} { |
|
variable pkg_availability |
|
if {![info exists pkg_availability]} { |
|
return "" |
|
} |
|
global A |
|
if {![array size A]} {punkboot::define_global_ansi} |
|
set h "" |
|
if {[llength [dict get $pkg_availability missing]] || [llength [dict get $pkg_availability broken]]} { |
|
set has_recommended 0 |
|
set has_nonoptional 0 |
|
foreach pkg_req [list {*}[dict get $pkg_availability missing] {*}[dict get $pkg_availability broken]] { |
|
lassign $pkg_req pkgname _requirements |
|
if {[dict exists $::punkboot::bootsupport_recommended $pkgname]} { |
|
set has_recommended 1 |
|
break |
|
} |
|
if {![dict exists $::punkboot::bootsupport_optional $pkgname]} { |
|
set has_nonoptional 1 |
|
break |
|
} |
|
} |
|
if {$has_recommended || $has_nonoptional} { |
|
append h "* $A(HIGHLIGHT)** NOTE ** ***$A(RST)" \n |
|
append h " punk boot has detected that the following packages could not be loaded from the bootsystem path:" \n |
|
set missing_out [get_display_missing_packages $pkg_availability] |
|
append h $missing_out |
|
|
|
set broken_out [get_display_broken_packages $pkg_availability] |
|
|
|
append h $broken_out |
|
append h "* $A(HIGHLIGHT)** *** *** ***$A(RST)" \n |
|
append h " Packages marked RECOMMENDED are *probably* required for punk boot to function efficiently" \n |
|
append h " punk boot may still work if they are available elsewhere for the running interpreter" \n |
|
append h " Review to see if bootsupport should be updated" \n |
|
append h " Call 'make.tcl check' and examine the last table (which includes bootsupport + executable-provided packages)" \n |
|
append h " See if there are any items marked missing or broken that aren't marked as '(known optional)'" \n |
|
append h " If all are marked (known optional) then it should work." \n |
|
append h " A package marked (known optional) and (RECOMMENDED) may make the mint/bake and install processes run a lot faster. (e.g tcllibc)" \n |
|
append h "* $A(HIGHLIGHT)** *** *** ***$A(RST)" \n\n |
|
#append h "Successfully Loaded packages:" \n |
|
#append h " " [join $::punkboot::pkg_loaded "\n "] \n |
|
} |
|
} |
|
return $h |
|
} |
|
|
|
|
|
#todo? process and remove first arg minted os internal (and combinations such as minted-os etc) |
|
############################################################################################################## |
|
############################################################################################################## |
|
############################################################################################################## |
|
set scriptargs $::argv |
|
|
|
# ---------------------------------------------------------------------------------------------- |
|
# G-030: make.tcl dogfoods punk::args. |
|
# Subcommands and their options are declared as punk::args definitions ((script)::punkboot and |
|
# (script)::punkboot::<subcommand>) and parsed with punk::args::parse - 'make.tcl', |
|
# 'make.tcl help ?subcommand?' and 'make.tcl <subcommand> -help' render tabled usage, and invalid |
|
# arguments produce punk::args usage errors. |
|
# Degrade rule (hard requirement - see goals/archive/G-030-maketcl-punkargs.md): punk::args is |
|
# guarded. When it (or a definition feature it needs) is unavailable from bootsupport, dispatch |
|
# falls back to the self-contained scan below and help falls back to plain-text |
|
# ::punkboot::punkboot_gethelp, so the environment-repair commands (check, bootsupport, modules) |
|
# keep working. The tabled rendering additionally depends on the punk::ansi/textblock stack - |
|
# rendering degrades independently of parsing (minimal errorstyle / plain fallback help) when |
|
# that stack is unhealthy. Only punk::args itself joins the bootstrap-tracked staleness set |
|
# (_runtime_deps above): it is the parsing contract; the rendering stack is left to degrade. |
|
# ---------------------------------------------------------------------------------------------- |
|
set ::punkboot::punkargs_ok 0 |
|
#PUNKBOOT_PLAIN=1 forces the plain fallback dispatch/help - a troubleshooting/test hook for the |
|
#degrade contract (e.g when a half-broken punk::args snapshot loads but misbehaves). |
|
if {[info exists ::env(PUNKBOOT_PLAIN)] && [string is true -strict $::env(PUNKBOOT_PLAIN)]} { |
|
puts stderr "make.tcl: PUNKBOOT_PLAIN set - using plain argument handling and help" |
|
} elseif {![catch {package require punk::args}]} { |
|
if {![catch { |
|
namespace eval ::punkboot::argdoc { |
|
#single source for the subcommand one-line summaries: each subcommand definition's |
|
#@cmd -summary and the top-level subcommand -choicelabels are both built from this. |
|
variable SUMMARIES { |
|
bakehouse "Consumer run from a clean checkout: mint packages then bake - refuses uncommitted src by default" |
|
packages "Mint .tm modules and pkgIndex.tcl libraries from src into <projectdir> (no kit executables)" |
|
modules "Mint .tm modules from src/modules, src/vendormodules etc into <projectdir>/modules etc" |
|
libs "Mint pkgIndex.tcl libraries from src/lib, src/vendorlib etc into <projectdir>/lib etc" |
|
bake "Assemble kit/zipkit executables from promoted payload (src/vfs) and runtimes into <projectdir>/bin" |
|
bakelist "List the kit outputs configured in src/runtime/mapvfs.toml: type, runtime/vfs presence, deployed state, groups" |
|
vfslibs "Materialize per-.vfs payload declarations (src/vfs/<name>.vfs.toml - G-115) into kit vfs folders; drop-ins preserved" |
|
bin "Install executables from src/bin into <projectdir>/bin, then bake kits as for bake" |
|
vendorupdate "Update src/vendormodules based on src/vendormodules/include_modules.config" |
|
libfetch "Fetch declared punkbin lib-tier library artifacts into bin/packages/<target> (sha1-verified) and materialize the package trees" |
|
bootsupport "Promotion gate: update src/bootsupport modules from built project modules" |
|
vfscommonupdate "Promotion gate: replace src/vfs/_vfscommon.vfs modules and libs with the project's built set" |
|
info "Show the name and base folder of the project to be built" |
|
check "Show module/library paths and any potentially problematic packages for running this script" |
|
projectversion "Advisory check: CHANGELOG.md vs punkproject.toml and src/ changes since last version bump" |
|
workflow "Print an ASCII data-flow overview of the release workflow (edit -> mint -> promote -> bake)" |
|
shell "Run the punk shell using bootsupport libraries" |
|
help "Show usage for make.tcl or one of its subcommands" |
|
buildsuite "List, describe or run the defined buildsuites under src/buildsuites (zig runtime factory)" |
|
tool "List, test or build the vendored tools under src/tools (zig) and install them to <projectdir>/bin" |
|
} |
|
#@cmd -help bodies for the braced definitions below, pulled in via tstr |
|
#placeholders ({${[dict get $HELPTEXTS <sub>]}}). -help is a display field, |
|
#expanded DEFERRED (punk::args G-046) - each body lands in the rendered |
|
#Description column verbatim, so the BLOCK-FORM authoring here (first value |
|
#line whitespace-only, content uniformly indented) deliberately carries this |
|
#indentation into the display: the centred Description look of the punk |
|
#module doc blocks (no @normalize re-basing). |
|
variable HELPTEXTS { |
|
bakehouse |
|
" |
|
Consumer umbrella: run the packages stage (modules + libs) then bake |
|
the kit/zipkit executables - the full path from a CLEAN checkout to |
|
installed kits in <projectdir>/bin. |
|
The bakehouse bakes from the committed recipe: by default it refuses |
|
to run when src/ has uncommitted changes (-dirty-abort defaults ON), |
|
pointing at the granular developer flow (packages -> test -> |
|
bootsupport/vfscommonupdate -> commit -> bake). Pass -dirty-abort 0 |
|
to proceed anyway with PROVENANCE-WARNINGs. |
|
Deliberately does NOT run the promotion gates (bootsupport, |
|
vfscommonupdate): payload promotion is a confirm-gated, committed |
|
act - on a clean checkout the gates are already satisfied by the |
|
committed tree." |
|
packages |
|
" |
|
Mint (stamp real versions, pack modpods; plain copy where no |
|
stamping applies) both .tm and pkgIndex.tcl based |
|
packages from src to their corresponding locations under <projectdir>. |
|
This does not scan src/runtime and src/vfs folders to bake kit/zipkit |
|
executables." |
|
modules |
|
" |
|
Mint (stamp real versions, pack modpods; plain copy where no |
|
stamping applies) .tm modules from src/modules, |
|
src/vendormodules etc to their corresponding locations under <projectdir>. |
|
This does not scan src/runtime and src/vfs folders to bake kit/zipkit |
|
executables." |
|
libs |
|
" |
|
Mint (or plain copy where no stamping applies) pkgIndex.tcl based libraries from |
|
src/lib, src/vendorlib etc to their corresponding locations under |
|
<projectdir>. |
|
This does not scan src/runtime and src/vfs folders to bake kit/zipkit |
|
executables." |
|
bake |
|
" |
|
Assemble kit/zipkit executables: scan src/vfs and src/runtime folders, |
|
bake each configured kit from the promoted payload |
|
(src/vfs/_vfscommon.vfs + custom vfs folders) and its runtime, and |
|
install to <projectdir>/bin. |
|
With kitname (or @groupname - G-024 groups) arguments, bake and |
|
deploy ONLY the named configured kits (see 'make.tcl bakelist' |
|
for the configured names and groups) - other kits' bake |
|
products, bin copies and punkcheck records are left untouched. |
|
An unknown name errors before any bake, listing the configured |
|
names. Bare 'bake' processes all configured kits except |
|
bake_default=false entries (those bake only by name/@group). |
|
Includes the vfslibs phase (per-.vfs payload declarations |
|
src/vfs/<name>.vfs.toml materialized into the kit vfs folders - |
|
G-115) so a bake cannot ship stale binary libs; a selective |
|
bake narrows that phase to the named kits' vfs folders. |
|
Does not rebuild modules/libs and does not run the promotion gates - |
|
minted modules reach the kit payload only via 'make.tcl |
|
vfscommonupdate' (committed for provenance). Consumer full path from |
|
a clean checkout: 'make.tcl bakehouse'." |
|
bakelist |
|
" |
|
List the kit outputs configured in src/runtime/mapvfs.toml (the |
|
same parsed mapping the bake subcommand consumes; the deprecated |
|
mapvfs.config line format is honoured when no toml file exists): |
|
kit name, kit type (kit|zip|zipcat...), runtime with presence in |
|
the runtime store of that kit's TARGET platform |
|
(<projectdir>/bin/runtime/<target>), vfs folder, and the |
|
deployed state of <projectdir>/bin/<kit> vs the src/_bake bake |
|
product: |
|
current - deployed copy is identical to the bake product |
|
stale - deployed copy differs from the bake product |
|
absent - no deployed copy in <projectdir>/bin |
|
nobake - deployed copy exists but no bake product to compare |
|
A trailing notes column flags anomalies (runtime=missing, |
|
vfs=missing, rtrev=r<cur><r<max> when the runtime working copy is |
|
materialized from an older revision than a -r<N> artifact beside |
|
it) and marks cross-target entries (target=<platform> on any kit |
|
whose mapvfs entry declares a target other than this host's |
|
default - 'make.tcl check' shows that default), G-024 groups |
|
(group=<name>), entries excluded from full bakes (default=no) |
|
and scheme-expanded outputs (scheme=versioned|dev|release). |
|
Non-default-target kits bake and deploy under the |
|
kits/<platform>/ tier of src/_bake and bin (G-127) - their rows |
|
carry out=kits/<platform>/ and the deployed state compares the |
|
tiered paths; a kit NAME shared by entries for several targets |
|
selects (and lists) every one of them. |
|
kitname (or @groupname) arguments filter the report to the named |
|
entries (per-kit detail, with resolved store tier, target, |
|
config entry and paths). Reporting only - never bakes." |
|
vfslibs |
|
" |
|
Materialize the per-.vfs payload declarations (G-115): each |
|
src/vfs/<name>.vfs.toml declares package folders to install |
|
INTO src/vfs/<name>.vfs - from vendored src/ folders |
|
(source_root 'src', the default) or from the bin/packages |
|
punkbin lib-tier input (source_root 'packages', populated by |
|
'make.tcl libfetch' - G-139) - with explicit superseded-version |
|
removal and clean-slate same-name 'replace'. |
|
punkcheck-tracked with drop-in-wins precedence: files the |
|
mechanism did not install (or that changed since it installed |
|
them) are preserved and reported, never overwritten; a .vfs |
|
with no declaration file is untouched. Format + precedence: |
|
src/vfs/README.md. |
|
Also runs automatically as a phase of 'make.tcl bake' (and therefore |
|
of 'make.tcl bakehouse'); this standalone narrowing serves quick |
|
iteration on the declarations." |
|
libfetch |
|
" |
|
Fetch the punkbin LIB-TIER library artifacts declared in |
|
src/runtime/libpackages.toml into the untracked input tier |
|
bin/packages/<target>/ - immutable <pkg>-<tcl8|tcl9>-r<N>.zip |
|
artifacts plus their .toml sidecars, each verified against the |
|
server's per-target sha1sums.txt - then materialize each verified |
|
zip's installed-shape package tree under |
|
bin/packages/<target>/tcl<N>/ (self-describing via the embedded |
|
punkbin-artifact.toml record; G-138/G-139). |
|
Present artifacts that already verify are skipped (-force |
|
re-downloads). The canonical punkbin origin is trusted by |
|
default; -serverurl (or env PUNKBIN_URL) overrides it, and any |
|
NON-canonical origin requires the explicit -trust-server flag |
|
(never an interactive prompt - unattended runs stay unattended). |
|
A file:// origin is supported for local mirrors/fixtures. |
|
Transport for http(s): Tcl http+tls when loadable, else curl, |
|
else PowerShell (windows). |
|
Isolation seams (env-only): PUNK_LIBFETCH_CONFIG points at an |
|
alternate declarations file and PUNK_LIBFETCH_PACKAGES at an |
|
alternate tier root - fixture/test runs leave the real |
|
declarations and bin/packages untouched. Neither bypasses the |
|
-trust-server consent gate." |
|
bin |
|
" |
|
Install executables from src/bin to <projectdir>/bin, then check vfs |
|
folders and bake kit/zipkit executables as for the bake subcommand." |
|
vendorupdate |
|
" |
|
Update the src/vendormodules based on src/vendormodules/include_modules.config. |
|
Update the src/vendorlib based on src/vendorlib/config.toml (todo)." |
|
bootsupport |
|
" |
|
Update the src/bootsupport modules. |
|
Bootsupport modules are pulled from locations specified in |
|
include_modules.config files within each src/bootsupport subdirectory. |
|
This should usually be from modules that have been built and tested in |
|
<projectdir>/modules, <projectdir>/lib etc. |
|
Bootsupport modules are available to make.tcl. |
|
Project layouts store no bootsupport module snapshots - generated |
|
projects get bootsupport injected at generation time by 'dev |
|
project.new' (G-087)." |
|
vfscommonupdate |
|
" |
|
Update the src/vfs/_vfscommon.vfs from compiled src/modules and src/lib etc. |
|
Before calling this (followed by 'make.tcl bake') - you can test using |
|
'<builtexe>(.exe) minted' - this will load modules from your <projectdir>/modules, |
|
<projectdir>/lib paths instead of from the kit/zipkit. |
|
Replacing the _vfscommon.vfs contents requires confirmation - see -confirm." |
|
info |
|
" |
|
Show the name and base folder of the project to be built." |
|
check |
|
" |
|
Show module/library paths and any potentially problematic packages for |
|
running this script. |
|
Also reports the colour policy, the host/target platform derivation |
|
(this tclsh's platform canon vs the default kit target, its runtime |
|
store tier, executable suffix and process tooling), bootsupport |
|
staleness and the src provenance status (what the producing |
|
commands would do)." |
|
projectversion |
|
" |
|
Advisory check: verify CHANGELOG.md matches punkproject.toml and warn |
|
if src/ has changes since the last project-version bump." |
|
workflow |
|
" |
|
Print a plain-text (ASCII diagram) overview of the release |
|
workflow: the release-ready command sequence and how data flows from |
|
editing a module under src/ through built packages to bootsupport, |
|
the kit vfs and the kit executables. |
|
The text is embedded in make.tcl (::punkboot::workflow_text) so it is |
|
available wherever make.tcl runs; its MAINTENANCE key states the |
|
update contract for keeping it in step with make.tcl behaviour." |
|
help |
|
" |
|
Show tabled usage for make.tcl as a whole, or for a single subcommand. |
|
After the subject, accepts that subcommand's own command line and |
|
dry-runs it through the subcommand's declaration: a line the |
|
subcommand would accept shows the matched action's usage - 'make.tcl |
|
help tool build -test 0 punkzip' shows the tool build form, as does |
|
appending -help to the command line itself ('make.tcl tool build |
|
-test 0 punkzip -help') - while a line it would reject shows the |
|
same usage error the subcommand itself would produce (the error |
|
table carries the forms' synopsis, argument rows and per-form |
|
reasons; exit 1). An accepted line is confirmed with a one-line |
|
report of where each word landed ('kitname = punk91 -confirm 0' |
|
reveals flag-like words consumed as values); an action word alone |
|
is dry-run too, so a form needing more arguments reports them via |
|
the usage error ('make.tcl help buildsuite build')." |
|
buildsuite |
|
" |
|
Surface for the defined buildsuites under src/buildsuites (zig-built |
|
runtime factory - an arm's-length subsystem building Tcl runtimes |
|
from external sources, distinct from the project mint/bake stages). |
|
|
|
Actions: |
|
buildsuite list |
|
Discover the suites (directories carrying a suite.tcl driver; |
|
_build excluded) with their one-line descriptions. |
|
buildsuite info <name> |
|
Show the suite's configured detail: description, source records |
|
(name/kind/url/ref/dir from sources.config), pinned zig and its |
|
resolution, products, doc pointers. |
|
buildsuite build <name> ?driver-args ...? |
|
Run the suite's driver ('suite.tcl build' with the given args |
|
forwarded untouched, e.g -tclbranch/-refresh/-steps), streaming |
|
its output and exiting with the driver's status. |
|
|
|
Suites are SELF-describing: list/info read each suite's |
|
sources.config records (description/product/doc/zigpin - the same |
|
manifest the suite.tcl driver parses), so a copied/retargeted tree |
|
(copy-and-tweak workflow) appears here automatically with no |
|
make.tcl edits. The contract is documented in |
|
src/buildsuites/README.md." |
|
tool |
|
" |
|
Surface for the vendored first-party build tools under src/tools |
|
(G-126: zig source vendored in full; boundary and editing policy in |
|
src/tools/AGENTS.md, per-tree origin/licence records in |
|
<tool>/PROVENANCE.md). Discovery is convention-based: a directory |
|
under src/tools carrying build.zig is a tool; its installed |
|
artifact is <projectdir>/bin/<name> with the host executable |
|
suffix. |
|
|
|
Actions: |
|
tool list |
|
Discover the tools with version (build.zig.zon), declared zig |
|
floor, installed-binary state (current|stale|absent) and the |
|
vendored upstream commit; report the resolved toolchain. |
|
tool info <name> ... |
|
Per-tool detail: paths, provenance records, toolchain |
|
resolution. |
|
tool build ?-test 0|1? ?<name> ...? |
|
Resolve a zig satisfying the tool's declared floor, run the |
|
'zig build test' gate (default on; the gate is the EXIT CODE - |
|
expected warnings on stderr do not fail it), build ReleaseSafe |
|
and install to <projectdir>/bin. Nothing is installed when the |
|
gate or the build fails. Options precede the tool names |
|
(punk::args positional model); with no name, all tools are |
|
processed. |
|
tool test ?<name> ...? |
|
Run each tool's 'zig build test' only. |
|
|
|
'make.tcl help tool <action>' shows a single action's usage table. |
|
|
|
Toolchain resolution: PUNK_ZIG=<path-to-zig-or-its-folder> |
|
overrides; otherwise <projectdir>/bin/tools/zig* is scanned and |
|
the LOWEST release satisfying the floor wins (deterministic as |
|
newer toolchains appear beside the pinned one; dev builds count |
|
only when their base version exceeds the floor). zig is OPTIONAL |
|
for the punkshell mint/bake pipeline: packages/bake never require this step - |
|
without a suitable toolchain, list reports the state and |
|
build/test exit nonzero with fetch guidance |
|
(bin/punk-getzig.cmd). Build caches (.zig-cache/zig-out) are |
|
deliberately left in place between runs for rebuild speed (both |
|
git- and fossil-ignored)." |
|
} |
|
#shared option fragments interpolated into the per-subcommand definitions |
|
#below via tstr placeholders (${$OPT_...}) - expanded eagerly at resolve time |
|
#in this namespace, so each definition receives these records verbatim |
|
variable OPT_CONFIRM { |
|
-confirm -type boolean -default 1 -help\ |
|
"Interactive y/n confirmation policy. |
|
-confirm 1 (default): confirmation points prompt when stdin is an |
|
interactive terminal. When stdin is NOT interactive (piped/closed), |
|
make.tcl aborts fast at the confirmation point with guidance instead |
|
of reading stdin. |
|
-confirm 0: never prompt - each confirmation point takes its documented |
|
non-interactive resolution: |
|
bootsupport minor-version staleness gate -> proceed |
|
vfscommonupdate REPLACE confirmation -> proceed |
|
kit source/target type mismatch -> skip baking that kit |
|
Note: Tcl 8.6 lacks the terminal probe (-inputmode) so stdin is assumed |
|
interactive there - piped runs under 8.6 should always pass -confirm |
|
explicitly." |
|
} |
|
variable OPT_DIRTYABORT { |
|
-dirty-abort -type none -default 0 -help\ |
|
"Abort when src/ has uncommitted VCS changes. |
|
Default is warn-only: artifacts built from dirty src have no committed |
|
provenance. Warnings carry a plain PROVENANCE-WARNING: prefix (greppable |
|
in redirected output) and are recapped at the end of the run. |
|
Use 'make.tcl check' to see the current provenance status. To evaluate |
|
uncommitted source without minting or baking, use '<builtexe> src' or |
|
'<builtexe> src shell'." |
|
} |
|
variable OPT_FORCEKILL { |
|
-k -type none -default 0 -help\ |
|
"Terminate running processes matching the executable being built |
|
(if applicable) so the bake can install over it." |
|
} |
|
#bakehouse defaults the dirty gate ON: |
|
#the bakehouse bakes from the committed recipe (G-112 two-persona model). |
|
variable OPT_DIRTYABORT_ON { |
|
-dirty-abort -type boolean -default 1 -help\ |
|
"Abort when src/ has uncommitted VCS changes - DEFAULT ON for this |
|
subcommand: the bakehouse bakes from the committed recipe. A |
|
consumer run on a clean checkout proceeds uninterrupted; uncommitted |
|
developer changes get a refusal naming the granular flow |
|
(packages -> test -> bootsupport/vfscommonupdate -> commit -> bake). |
|
Pass -dirty-abort 0 to proceed anyway with PROVENANCE-WARNINGs." |
|
} |
|
#libfetch fragments (G-139): consent is keyed to SERVER TRUST (the G-123 |
|
#posture) - the canonical punkbin origin needs no acknowledgement, any |
|
#other origin needs the explicit flag. Never an interactive prompt. |
|
variable OPT_SERVERURL { |
|
-serverurl -type string -default "" -help\ |
|
"Artifact server base url override (default: the canonical punkbin |
|
origin; env PUNKBIN_URL overrides the default, this flag overrides |
|
both). The lib tier is addressed as <serverurl>/lib/<target>/. |
|
file:// urls are supported for local mirrors and fixtures. |
|
A NON-canonical origin additionally requires -trust-server." |
|
} |
|
variable OPT_TRUSTSERVER { |
|
-trust-server -type none -default 0 -help\ |
|
"Acknowledge fetching from a NON-canonical artifact server |
|
(consent keyed to server trust - the interim G-123/G-006 |
|
mechanism). Without this flag, a non-canonical -serverurl or |
|
PUNKBIN_URL aborts before any network access. Fetches from the |
|
canonical origin never require it." |
|
} |
|
variable OPT_FORCE { |
|
-force -type none -default 0 -help\ |
|
"Re-download and re-materialize even when a present artifact |
|
already verifies against the server sha1sums." |
|
} |
|
#bake and bakelist take optional trailing kit names (G-121 selective bake). |
|
#The configured kit names + @group selectors become RESTRICTED choices when |
|
#the mapping parses at definition time (-choicerestricted 1, 2026-08-02 - |
|
#declaration-authoritative per the G-143 arc): dispatch rejects an unknown |
|
#kit with the punk::args choice error (the same configured-names |
|
#information the handler error carries), unambiguous prefixes resolve to |
|
#canonical names, and the dry-run help mirrors the verdict. The read is |
|
#the same memoized model the handlers consume (mapvfs_model - one parse |
|
#per invocation). When the mapping cannot be parsed here the choices |
|
#clause is omitted entirely (no gate) and the handlers' own validation |
|
#remains the backstop - as it also is in PUNKBOOT_PLAIN degraded mode, |
|
#where these definitions don't exist. |
|
#KITNAME_CHOICEPART persists as a namespace variable because the kitname |
|
#records below interpolate it at definition RESOLVE time (lazy - first |
|
#parse/usage/get_spec of the bake/bakelist ids). |
|
variable KITNAME_CHOICES [list] |
|
catch { |
|
set _mapmodel [punkboot::lib::mapvfs_model [file join $::punkboot::scriptfolder runtime] [file dirname $::punkboot::scriptfolder]/bin/runtime $::punkboot::scriptfolder $::punkboot::target_platform] |
|
foreach _rec [punkboot::lib::mapvfs_kit_outputs $_mapmodel [file dirname $::punkboot::scriptfolder]/bin/runtime $::punkboot::scriptfolder] { |
|
lappend KITNAME_CHOICES [dict get $_rec kitname] |
|
} |
|
#G-024 group selectors join the choices (@<group>) |
|
foreach _g [dict keys [dict get $_mapmodel groups]] { |
|
lappend KITNAME_CHOICES @$_g |
|
} |
|
} |
|
variable KITNAME_CHOICEPART "" |
|
if {[llength $KITNAME_CHOICES]} { |
|
set KITNAME_CHOICEPART " -choices [list $KITNAME_CHOICES] -choicerestricted 1" |
|
} |
|
#per-subcommand definitions: braced file-style blocks with -& record |
|
#continuations (G-045). -summary values and -help bodies are pulled from |
|
#SUMMARIES/HELPTEXTS via tstr placeholders; the shared option fragments |
|
#(${$OPT_...}) and the kitname choice part expand eagerly at (lazy) resolve |
|
#time in this namespace, while the -help bodies are display fields (G-046 |
|
#deferred expansion - their block indentation reaches the render verbatim). |
|
punk::args::define { |
|
@id -id "(script)::punkboot::bakehouse" |
|
@cmd -name "make.tcl bakehouse" -& |
|
-summary "${[dict get $SUMMARIES bakehouse]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS bakehouse]}} |
|
@opts |
|
${$OPT_FORCEKILL} |
|
${$OPT_DIRTYABORT_ON} |
|
${$OPT_CONFIRM} |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::packages" |
|
@cmd -name "make.tcl packages" -& |
|
-summary "${[dict get $SUMMARIES packages]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS packages]}} |
|
@opts |
|
${$OPT_DIRTYABORT} |
|
${$OPT_CONFIRM} |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::modules" |
|
@cmd -name "make.tcl modules" -& |
|
-summary "${[dict get $SUMMARIES modules]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS modules]}} |
|
@opts |
|
${$OPT_DIRTYABORT} |
|
${$OPT_CONFIRM} |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::libs" |
|
@cmd -name "make.tcl libs" -& |
|
-summary "${[dict get $SUMMARIES libs]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS libs]}} |
|
@opts |
|
${$OPT_DIRTYABORT} |
|
${$OPT_CONFIRM} |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::bake" |
|
@cmd -name "make.tcl bake" -& |
|
-summary "${[dict get $SUMMARIES bake]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS bake]}} |
|
@opts |
|
${$OPT_FORCEKILL} |
|
${$OPT_DIRTYABORT} |
|
${$OPT_CONFIRM} |
|
@values -min 0 -max -1 |
|
kitname -type string -optional 1 -multiple 1${$KITNAME_CHOICEPART} -help -& |
|
"Configured kit output(s) to bake and deploy - a kit name, or |
|
@<groupname> for every kit in a configured group (G-024) - see |
|
'make.tcl bakelist' for the configured names and groups. With no |
|
kitname, all configured kits are processed except entries with |
|
bake_default=false. An unknown name errors before any bake." |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::bakelist" |
|
@cmd -name "make.tcl bakelist" -& |
|
-summary "${[dict get $SUMMARIES bakelist]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS bakelist]}} |
|
@values -min 0 -max -1 |
|
kitname -type string -optional 1 -multiple 1${$KITNAME_CHOICEPART} -help -& |
|
"Configured kit output(s) to report on - a kit name, or @<groupname> |
|
for every kit in a configured group (filters the listing - doubles |
|
as per-kit detail). With no kitname, all configured entries are |
|
listed." |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::vfslibs" |
|
@cmd -name "make.tcl vfslibs" -& |
|
-summary "${[dict get $SUMMARIES vfslibs]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS vfslibs]}} |
|
@opts |
|
${$OPT_DIRTYABORT} |
|
${$OPT_CONFIRM} |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::bin" |
|
@cmd -name "make.tcl bin" -& |
|
-summary "${[dict get $SUMMARIES bin]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS bin]}} |
|
@opts |
|
${$OPT_FORCEKILL} |
|
${$OPT_DIRTYABORT} |
|
${$OPT_CONFIRM} |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::vendorupdate" |
|
@cmd -name "make.tcl vendorupdate" -& |
|
-summary "${[dict get $SUMMARIES vendorupdate]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS vendorupdate]}} |
|
@opts |
|
${$OPT_CONFIRM} |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::libfetch" |
|
@cmd -name "make.tcl libfetch" -& |
|
-summary "${[dict get $SUMMARIES libfetch]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS libfetch]}} |
|
@opts |
|
${$OPT_SERVERURL} |
|
${$OPT_TRUSTSERVER} |
|
${$OPT_FORCE} |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::bootsupport" |
|
@cmd -name "make.tcl bootsupport" -& |
|
-summary "${[dict get $SUMMARIES bootsupport]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS bootsupport]}} |
|
@opts |
|
${$OPT_DIRTYABORT} |
|
${$OPT_CONFIRM} |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::vfscommonupdate" |
|
@cmd -name "make.tcl vfscommonupdate" -& |
|
-summary "${[dict get $SUMMARIES vfscommonupdate]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS vfscommonupdate]}} |
|
@opts |
|
${$OPT_DIRTYABORT} |
|
${$OPT_CONFIRM} |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::info" |
|
@cmd -name "make.tcl info" -& |
|
-summary "${[dict get $SUMMARIES info]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS info]}} |
|
@opts |
|
${$OPT_CONFIRM} |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::check" |
|
@cmd -name "make.tcl check" -& |
|
-summary "${[dict get $SUMMARIES check]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS check]}} |
|
@opts |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::projectversion" |
|
@cmd -name "make.tcl projectversion" -& |
|
-summary "${[dict get $SUMMARIES projectversion]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS projectversion]}} |
|
@opts |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::workflow" |
|
@cmd -name "make.tcl workflow" -& |
|
-summary "${[dict get $SUMMARIES workflow]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS workflow]}} |
|
@opts |
|
@values -min 0 -max 0 |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::shell" |
|
@cmd -name "make.tcl shell" -& |
|
-summary "${[dict get $SUMMARIES shell]}" -& |
|
-help -& |
|
"Run the punk shell (repl) using bootsupport libraries. |
|
All arguments after the shell subcommand are passed through to the |
|
repl untouched (they are not parsed or validated by make.tcl)." |
|
@values -min 0 -max -1 |
|
arg -type any -optional 1 -multiple 1 -help -& |
|
"Arguments passed through to the punk repl." |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot::buildsuite" |
|
@cmd -name "make.tcl buildsuite" -& |
|
-summary "${[dict get $SUMMARIES buildsuite]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS buildsuite]}} |
|
@form -form {list info build} |
|
@form -form list |
|
@leaders -min 1 -max 1 |
|
action -choices {list} -choicelabels -& |
|
{list "Discover the suites (directories carrying a suite.tcl driver) with their one-line descriptions"} |
|
@values -min 0 -max 0 |
|
@form -form info |
|
@leaders -min 1 -max 1 |
|
action -choices {info} -choicelabels -& |
|
{info "Show a suite's configured detail: description, source records, zig pin, products, doc pointers"} |
|
@values -min 1 -max 1 |
|
suitename -type string -optional 0 -help -& |
|
"Suite name (a directory under src/buildsuites carrying a suite.tcl driver)." |
|
@form -form build |
|
@leaders -min 1 -max 1 |
|
action -choices {build} -choicelabels -& |
|
{build "Run the suite's driver ('suite.tcl build'), forwarding trailing args untouched"} |
|
@values -min 1 -max -1 |
|
suitename -type string -optional 0 -help -& |
|
"Suite to build." |
|
driverarg -type any -optional 1 -multiple 1 -help -& |
|
"Driver arguments forwarded to suite.tcl untouched (e.g -tclbranch/-refresh/-steps)." |
|
} |
|
|
|
punk::args::define { |
|
@id -id "(script)::punkboot::tool" |
|
@cmd -name "make.tcl tool" -& |
|
-summary "${[dict get $SUMMARIES tool]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS tool]}} |
|
@form -form {list info build test} |
|
@form -form list |
|
@leaders -min 1 -max 1 |
|
action -choices {list} -choicelabels -& |
|
{list "Discover the tools with version, zig floor, install state and vendored commit; report the resolved toolchain"} |
|
@values -min 0 -max -1 |
|
toolname -type string -optional 1 -multiple 1 -& |
|
-help "Validated against the configured tools (list reports all regardless)." |
|
@form -form info |
|
@leaders -min 1 -max 1 |
|
action -choices {info} -choicelabels -& |
|
{info "Per-tool detail: paths, provenance records, toolchain resolution"} |
|
@values -min 1 -max -1 |
|
toolname -type string -optional 0 -multiple 1 -& |
|
-help "Tool(s) to describe (directory names under src/tools)." |
|
@form -form build |
|
@leaders -min 1 -max 1 |
|
action -choices {build} -choicelabels -& |
|
{build "Resolve zig, run the test gate, build ReleaseSafe and install to <projectdir>/bin"} |
|
@opts |
|
-test -type boolean -default 1 -help -& |
|
"Run the 'zig build test' gate before building (default 1). The gate is the exit code." |
|
@values -min 0 -max -1 |
|
toolname -type string -optional 1 -multiple 1 -& |
|
-help "Tool(s) to build; with no name, all tools are processed." |
|
@form -form test |
|
@leaders -min 1 -max 1 |
|
action -choices {test} -choicelabels -& |
|
{test "Run each tool's 'zig build test' only"} |
|
@values -min 0 -max -1 |
|
toolname -type string -optional 1 -multiple 1 -& |
|
-help "Tool(s) to test; with no name, all tools are processed." |
|
} |
|
|
|
punk::args::define { |
|
@id -id "(script)::punkboot::help" |
|
@cmd -name "make.tcl help" -& |
|
-summary "${[dict get $SUMMARIES help]}" -& |
|
-help -& |
|
{${[dict get $HELPTEXTS help]}} |
|
@values -min 1 -max -1 |
|
subject -type string -optional 0 -& |
|
-choices {${[dict keys $SUMMARIES]}} -& |
|
-help "Subcommand to show usage for." |
|
arg -type any -optional 1 -multiple 1 -help -& |
|
"The subject's own arguments, as they would be typed. The line |
|
is dry-run through the subject's declaration: an accepted line |
|
shows the matched action's usage (tool, buildsuite), a rejected |
|
line shows the subject's own usage error." |
|
} |
|
#top-level definition: the subcommand table rendered by 'make.tcl' / 'make.tcl -help' |
|
variable SUBGROUPS { |
|
"mint & bake" {bakehouse packages modules libs bake vfslibs bin} |
|
"promotion gates" {bootsupport vfscommonupdate} |
|
"source maintenance" {vendorupdate libfetch} |
|
"buildsuites" {buildsuite} |
|
"vendored tools" {tool} |
|
"informational" {info check bakelist projectversion workflow help} |
|
"interactive" {shell} |
|
} |
|
#top-level @cmd -help body (make.tcl itself is not a subcommand key, so this |
|
#lives beside HELPTEXTS rather than in it) - same block-form/indentation |
|
#convention as the HELPTEXTS entries |
|
variable TOPLEVEL_HELP { |
|
punk boot: make any tclkits and modules in <projectdir>/src folders and place |
|
them and associated data files/scripts in the parent folder of src - e.g in |
|
'bin' and 'modules' folders at the same level as 'src'. |
|
|
|
General usage: make.tcl <subcommand> ?flags? |
|
'make.tcl help <subcommand> ?arg ...?' or 'make.tcl <subcommand> |
|
?arg ...? -help' shows a subcommand's own usage - the words are |
|
dry-run through the subcommand's declaration, so an accepted |
|
command line shows the matched action's usage (tool, buildsuite) |
|
and a rejected one shows that subcommand's own usage error. |
|
Interactive y/n confirmations can be driven non-interactively |
|
with the -confirm flag declared on the relevant subcommands.} |
|
punk::args::define { |
|
@id -id "(script)::punkboot" |
|
@cmd -name "make.tcl" -& |
|
-summary "punkshell project make tool (punk boot)" -& |
|
-help -& |
|
{${$TOPLEVEL_HELP}} |
|
#sole remaining explicit synopsis override (G-143 retired the per-subcommand |
|
#ones per G-144's @cmd -name auto-synopsis): the auto render would show the |
|
#subcommand leader as mandatory - this line states the bare-invocation and |
|
#per-subcommand-flags reality the declaration cannot. |
|
@form -synopsis "make.tcl ?subcommand? ?flags?" |
|
@leaders -min 1 -max 1 |
|
subcommand -type string -optional 0 -choicecolumns 1 -& |
|
-choicegroups {${$SUBGROUPS}} -& |
|
-choicelabels {${$SUMMARIES}} -& |
|
-help "Use 'make.tcl help <subcommand>' or 'make.tcl <subcommand> -help' for details of a subcommand." |
|
} |
|
#Rich top-level overview (2026-08-02, the 'i info' style): each subcommand |
|
#cell carries its one-line summary plus the auto-generated bracket-notation |
|
#synopsis line(s) of that subcommand's OWN definition (per-form lines for |
|
#the multi-form tool/buildsuite), grouped by SUBGROUPS - the same |
|
#punk::args choices-table machinery punk::ns::cmdhelp uses for built-in |
|
#ensembles. -choicecolumns is 1 for now: the one-line summaries are long |
|
#and a 2-column layout is too wide without table CELL WRAPPING - revisit |
|
#-choicecolumns 2 when that lands (user decision 2026-08-02; the '## FORM' |
|
#header lines are likewise deliberately dropped from the cells for |
|
#compactness). Hung on a SEPARATE id so the label cost (a synopsis |
|
#render per subcommand, a few ms total) is paid only when the top-level |
|
#help actually renders: the lean (script)::punkboot definition above stays |
|
#the dispatch surface, and overview_labels runs at lazy resolve time |
|
#(first usage of this id - deliberately NOT in the capability probe below). |
|
proc ::punkboot::argdoc::overview_labels {} { |
|
variable SUMMARIES |
|
set labels [dict create] |
|
dict for {sub summary} $SUMMARIES { |
|
set lines [list] |
|
if {![catch {punk::args::synopsis -noheader (script)::punkboot::$sub} syn]} { |
|
catch {set syn [punk::ansi::ansistrip $syn]} |
|
foreach ln [split $syn \n] { |
|
#drop '## FORM n <name>' headers - the synopsis lines are |
|
#self-describing and the cells stay compact |
|
if {[string match "## *" [string trim $ln]] || [string trim $ln] eq ""} continue |
|
lappend lines $ln |
|
} |
|
} |
|
dict set labels $sub "# $summary\n[join $lines \n]" |
|
} |
|
return $labels |
|
} |
|
punk::args::define { |
|
@id -id "(script)::punkboot.overview" |
|
@cmd -name "make.tcl" -& |
|
-summary "punkshell project make tool (punk boot)" -& |
|
-help -& |
|
{${$TOPLEVEL_HELP}} |
|
@form -synopsis "make.tcl ?subcommand? ?flags?" |
|
@leaders -min 1 -max 1 |
|
subcommand -type string -optional 0 -choicecolumns 1 -& |
|
-choicegroups {${$SUBGROUPS}} -& |
|
-choicelabels {${[::punkboot::argdoc::overview_labels]}} -& |
|
-help "Use 'make.tcl help <subcommand>' or 'make.tcl <subcommand> -help' for details of a subcommand." |
|
} |
|
#capability probe: force resolution of representative definitions now, inside |
|
#the guarded block - a stale punk::args that accepted the raw text but cannot |
|
#resolve a mechanism used here (e.g snapshots predating -& record continuation |
|
#or the G-046 display-field deferral) degrades to the plain fallback |
|
#immediately instead of erroring at first parse/usage. |
|
punk::args::get_spec (script)::punkboot |
|
punk::args::get_spec (script)::punkboot::bakehouse |
|
punk::args::get_spec (script)::punkboot::bake ;#exercises the G-121 kitname values spec (-choicerestricted mechanism) |
|
punk::args::get_spec (script)::punkboot::help |
|
punk::args::get_spec (script)::punkboot::shell |
|
unset -nocomplain _mapmodel _rec _g |
|
} |
|
} _defserr]} { |
|
set ::punkboot::punkargs_ok 1 |
|
} else { |
|
puts stderr "make.tcl: punk::args subcommand definitions failed to load ($_defserr) - falling back to plain argument handling" |
|
} |
|
} |
|
#error/usage rendering style: tabled (standard) when the rendering stack is healthy, |
|
#minimal plain text otherwise - rendering degrades independently of parsing. |
|
set ::punkboot::errstyle minimal |
|
if {$::punkboot::punkargs_ok && [package provide punk::ansi] ne "" && [package provide textblock] ne ""} { |
|
set ::punkboot::errstyle standard |
|
} |
|
|
|
set do_help 0 |
|
set help_subject "" |
|
set help_words [list] |
|
set help_exitcode 0 |
|
#defaults for the option-derived variables (fallback scan and passthrough subcommands rely on these) |
|
set ::punkboot::opt_forcekill 0 |
|
set ::punkboot::opt_dirty_abort 0 |
|
set ::punkboot::opt_confirm 1 |
|
set ::punkboot::opt_serverurl "" |
|
set ::punkboot::opt_trust_server 0 |
|
set ::punkboot::opt_force 0 |
|
set ::punkboot::opt_kitnames [list] ;#G-121: requested kit names for bake/bakelist (empty = all configured) |
|
|
|
if {$::punkboot::punkargs_ok} { |
|
set first [lindex $scriptargs 0] |
|
if {![llength $scriptargs] || $first in $::punkboot::help_flags} { |
|
set do_help 1 |
|
} else { |
|
#validate/resolve the subcommand word via the top-level definition |
|
#(allows unambiguous prefixes; unknown subcommands get a punk::args usage error) |
|
if {[catch {punk::args::parse [list $first] -errorstyle $::punkboot::errstyle withid (script)::punkboot} argd]} { |
|
puts stderr $argd |
|
exit 1 |
|
} |
|
set subcommand [dict get $argd leaders subcommand] |
|
set subargs [lrange $scriptargs 1 end] |
|
set wants_help 0 |
|
foreach h $::punkboot::help_flags { |
|
if {$h in $subargs} {set wants_help 1 ; break} |
|
} |
|
if {$subcommand eq "help"} { |
|
set do_help 1 |
|
if {[llength $subargs]} { |
|
#validate/resolve ONLY the subject word through the help definition |
|
#(choices table + unambiguous prefixes). The tail is the subject's |
|
#own command line as the user would type it - deliberately NOT |
|
#parsed here: it may be any mix of that subcommand's actions, |
|
#options and values, including incomplete or wrong ones, which is |
|
#precisely when help is wanted (G-143 refinement 2026-08-01). |
|
if {[catch {punk::args::parse [lrange $subargs 0 0] -errorstyle $::punkboot::errstyle withid (script)::punkboot::help} argd]} { |
|
puts stderr $argd |
|
exit 1 |
|
} |
|
set help_subject [dict get $argd values subject] |
|
set help_words [lrange $subargs 1 end] |
|
} |
|
} elseif {$wants_help} { |
|
set do_help 1 |
|
set help_subject $subcommand |
|
#'<subcommand> ?arg ...? -help' - the same contract as |
|
#'make.tcl help <subcommand> ?arg ...?': the remaining words are the |
|
#subcommand's command line, with the help flag itself removed |
|
#(wherever it appeared). |
|
set help_words [list] |
|
foreach w $subargs { |
|
if {$w ni $::punkboot::help_flags} {lappend help_words $w} |
|
} |
|
} elseif {$subcommand eq "shell"} { |
|
#declared passthrough: everything after 'shell' goes to the repl unparsed |
|
set ::punkboot::command shell |
|
} elseif {$subcommand eq "buildsuite"} { |
|
#declared passthrough: the handler parses action/name itself; driver |
|
#args (arbitrary suite flags) are forwarded untouched (G-104) |
|
set ::punkboot::command buildsuite |
|
set ::punkboot::bs_args $subargs |
|
} elseif {$subcommand eq "tool"} { |
|
#G-143: tool is declared multi-form (one @form per action) and dispatch |
|
#parses through the definition - unknown actions and unknown flags in |
|
#option position produce pointed punk::args usage errors (exit 1). The |
|
#definition's positional model puts -test before the tool names |
|
#('make.tcl tool build -test 0 <name> ...'); the historic flag-anywhere |
|
#order is not carried over (docs updated). Bare 'tool' selects the list |
|
#form. The degraded plain scan keeps the historic manual tail parse |
|
#(handler-side, exit-2 surface preserved there). |
|
if {![llength $subargs]} {set subargs [list list]} |
|
if {[catch {punk::args::parse $subargs -errorstyle $::punkboot::errstyle withid (script)::punkboot::tool} argd]} { |
|
puts stderr $argd |
|
exit 1 |
|
} |
|
set ::punkboot::command tool |
|
set ::punkboot::tool_action [dict get $argd form] |
|
set ::punkboot::tool_names [list] |
|
if {[dict exists $argd values toolname]} { |
|
set ::punkboot::tool_names [dict get $argd values toolname] |
|
} |
|
set ::punkboot::tool_dotest 1 |
|
if {[dict exists $argd opts -test]} { |
|
set ::punkboot::tool_dotest [dict get $argd opts -test] |
|
} |
|
} else { |
|
if {[catch {punk::args::parse $subargs -errorstyle $::punkboot::errstyle withid (script)::punkboot::$subcommand} argd]} { |
|
puts stderr $argd |
|
exit 1 |
|
} |
|
set ::punkboot::command $subcommand |
|
set _opts [dict get $argd opts] |
|
foreach {_optname _var} {-k opt_forcekill -dirty-abort opt_dirty_abort -confirm opt_confirm -serverurl opt_serverurl -trust-server opt_trust_server -force opt_force} { |
|
if {[dict exists $_opts $_optname]} { |
|
set ::punkboot::$_var [dict get $_opts $_optname] |
|
} |
|
} |
|
if {[dict exists $argd values kitname]} { |
|
#declared -multiple: a list of the supplied kit names (bake/bakelist - G-121) |
|
set ::punkboot::opt_kitnames [dict get $argd values kitname] |
|
} |
|
unset -nocomplain _opts _optname _var |
|
} |
|
} |
|
} else { |
|
#self-contained fallback scan (degraded mode: punk::args or a needed definition feature |
|
#unavailable). Keeps check/bootsupport/modules and the -k/-dirty-abort/-confirm flags working. |
|
set commands_found [list] |
|
set argsleft $scriptargs |
|
if {[lindex $scriptargs 0] eq "buildsuite"} { |
|
#declared passthrough (as in the punk::args path): driver args carry |
|
#arbitrary suite flags the fallback flag scan must not consume (G-104) |
|
set commands_found [list buildsuite] |
|
set argsleft [list] |
|
set ::punkboot::bs_args [lrange $scriptargs 1 end] |
|
} elseif {[lindex $scriptargs 0] eq "tool"} { |
|
#declared passthrough (as in the punk::args path) - the handler parses |
|
#action/names/-test itself (G-126) |
|
set commands_found [list tool] |
|
set argsleft [list] |
|
set ::punkboot::tool_args [lrange $scriptargs 1 end] |
|
} |
|
while {[llength $argsleft]} { |
|
set a [lindex $argsleft 0] |
|
set argsleft [lrange $argsleft 1 end] |
|
if {[string match -* $a] || $a eq "/?"} { |
|
switch -- $a { |
|
-k {set ::punkboot::opt_forcekill 1} |
|
-dirty-abort {set ::punkboot::opt_dirty_abort 1} |
|
-trust-server {set ::punkboot::opt_trust_server 1} |
|
-force {set ::punkboot::opt_force 1} |
|
-serverurl { |
|
set ::punkboot::opt_serverurl [lindex $argsleft 0] |
|
set argsleft [lrange $argsleft 1 end] |
|
} |
|
-confirm { |
|
set v [lindex $argsleft 0] |
|
set argsleft [lrange $argsleft 1 end] |
|
if {![string is boolean -strict $v]} { |
|
puts stderr "make.tcl: -confirm requires a boolean value (got '$v')" |
|
exit 1 |
|
} |
|
set ::punkboot::opt_confirm [expr {bool($v)}] |
|
} |
|
default { |
|
if {$a in $::punkboot::help_flags} { |
|
set do_help 1 |
|
} else { |
|
puts stderr "Unknown flag: $a\n" |
|
set do_help 1 |
|
set help_exitcode 1 |
|
} |
|
} |
|
} |
|
} else { |
|
lappend commands_found $a |
|
} |
|
} |
|
#G-121: bake/bakelist take optional trailing kit names - collect them here so |
|
#the single-command check below still holds in degraded mode (the handlers do |
|
#their own name validation). |
|
if {[lindex $commands_found 0] in {bake bakelist}} { |
|
set ::punkboot::opt_kitnames [lrange $commands_found 1 end] |
|
set commands_found [lrange $commands_found 0 0] |
|
} |
|
if {![llength $scriptargs] || [lindex $commands_found 0] eq "help"} { |
|
set do_help 1 |
|
} elseif {!$do_help} { |
|
if {[llength $commands_found] != 1} { |
|
set do_help 1 |
|
set help_exitcode 1 |
|
} elseif {[lindex $commands_found 0] ni $::punkboot::known_commands} { |
|
puts stderr "Unknown command: [lindex $commands_found 0]\n\n" |
|
set do_help 1 |
|
set help_exitcode 1 |
|
} |
|
} |
|
if {!$do_help} { |
|
set ::punkboot::command [lindex $commands_found 0] |
|
} |
|
} |
|
|
|
if {$do_help} { |
|
puts stdout "Checking package availability..." |
|
set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] |
|
foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { |
|
lassign $pkg_request pkgname vrequest |
|
package require $pkgname {*}$vrequest ;#todo |
|
} |
|
set help_shown 0 |
|
if {$::punkboot::punkargs_ok} { |
|
#tabled usage via punk::args - degrade to the plain fallback help if the rendering |
|
#stack (punk::ansi/textblock etc) can't produce it. The bare top level renders |
|
#the rich overview id (per-subcommand summary + synopsis cells); the lean |
|
#(script)::punkboot id remains the dispatch surface. |
|
set usage_id (script)::punkboot.overview |
|
if {$help_subject ne ""} { |
|
set usage_id (script)::punkboot::$help_subject |
|
} |
|
set usage_args [list] |
|
set accepted_note "" |
|
if {[llength $help_words]} { |
|
#G-143 (refined 2026-08-01): help_words is the subject's own command line |
|
#('make.tcl help tool build -test 0 punkzip') and help is a pure DRY-RUN |
|
#of it: the words parse through the subject's declaration exactly as |
|
#dispatch would parse them (punk::args form auto-selection - literal |
|
#action leaders, choice prefixes). A line the subcommand would accept |
|
#renders the matched form's single-form usage (whole usage for |
|
#single-form subjects) plus a one-line report of where each received |
|
#word landed; a line it would reject gets the same pointed punk::args |
|
#diagnosis dispatch would give on stderr with exit 1 - the error table |
|
#carries the all-forms synopsis, per-form reasons and argument rows, |
|
#so it IS the form documentation. Deliberately no bare-action |
|
#carve-out: 'help buildsuite build' shows the build form via the |
|
#diagnosis that a suitename is still required. Note punk::args' |
|
#positional model: flag-like words at or after the first value |
|
#position are consumed as VALUES - the accepted-line report makes |
|
#that visible ('kitname = punk91 -confirm 0'); declaration-level |
|
#passthroughs (shell args, buildsuite driver args) parse clean by |
|
#design. |
|
if {[catch {punk::args::parse $help_words -errorstyle $::punkboot::errstyle withid $usage_id} argd]} { |
|
puts stderr $argd |
|
exit 1 |
|
} |
|
set form_names [punk::args::forms $usage_id] |
|
if {[llength $form_names] > 1} { |
|
lappend usage_args -form [dict get $argd form] |
|
} |
|
#interim 'where did my words land' clue (punk::args has no annotated |
|
#success render yet): name = value pairs for RECEIVED args only |
|
#(defaulted opts omitted), so a swallowed flag-like word shows up |
|
#against the argument that consumed it. |
|
set recnames [list] |
|
foreach {rn ri} [dict get $argd received] { |
|
if {$rn ni $recnames} {lappend recnames $rn} |
|
} |
|
set parts [list] |
|
foreach section {leaders opts values} { |
|
foreach {an av} [dict get $argd $section] { |
|
if {$an in $recnames} {lappend parts "$an = $av"} |
|
} |
|
} |
|
set accepted_note "dry-run: line accepted" |
|
if {[llength $form_names] > 1} { |
|
append accepted_note " (form [dict get $argd form])" |
|
} |
|
if {[llength $parts]} { |
|
append accepted_note " - [join $parts { | }]" |
|
} |
|
} |
|
if {![catch {punk::args::usage {*}$usage_args $usage_id} usage_out]} { |
|
puts stdout $usage_out |
|
if {$accepted_note ne ""} { |
|
puts stdout $accepted_note |
|
} |
|
set availability_note [::punkboot::punkboot_availability_note] |
|
if {$availability_note ne ""} { |
|
puts stdout $availability_note |
|
} |
|
set help_shown 1 |
|
} else { |
|
puts stderr "make.tcl: punk::args tabled usage unavailable ($usage_out) - falling back to plain help" |
|
} |
|
} |
|
if {!$help_shown} { |
|
puts stdout [::punkboot::punkboot_gethelp] |
|
} |
|
exit $help_exitcode |
|
} |
|
|
|
if {[info exists ::punkboot::command]} { |
|
if {!$::punkboot::punkargs_ok && $::punkboot::command eq "bakehouse"} { |
|
#degraded fallback scan has flag-only -dirty-abort (no way to pass 0): |
|
#bakehouse's documented default is ON, so force it here. |
|
set ::punkboot::opt_dirty_abort 1 |
|
} |
|
} |
|
|
|
set forcekill $::punkboot::opt_forcekill |
|
#puts stdout "::argv $::argv" |
|
# ---------------------------------------- |
|
|
|
# Abort / prompt if bootsupport modules are stale relative to source. |
|
# Behaviour is version-aware based on the bump level between each stale |
|
# module's bootsupport version and source version: |
|
# - major bump -> abort unconditionally (breaking change, old bootsupport will not work) |
|
# - minor bump -> prompt user; backward-compat aliases *should* keep old bootsupport functional |
|
# - patch bump -> warn and proceed (non-breaking) |
|
# 'check' is exempt in all cases — the warning is shown at the end of its output instead. |
|
# 'projectversion', 'workflow' and 'bakelist' are informational/read-only and are likewise exempt. |
|
# 'buildsuite' and 'tool' are arm's-length subsystems that do not consume bootsupport modules. |
|
if {[info exists ::punkboot::stale_bootsupport] && $::punkboot::command ni {check projectversion workflow bakelist buildsuite tool}} { |
|
set _stale $::punkboot::stale_bootsupport |
|
set _have_major 0 |
|
set _have_minor 0 |
|
set _have_patch 0 |
|
foreach _entry $_stale { |
|
lassign $_entry _pkg _src_ver _bs_ver _bump |
|
switch -- $_bump { |
|
major {incr _have_major} |
|
minor {incr _have_minor} |
|
patch {incr _have_patch} |
|
default {incr _have_patch} |
|
} |
|
} |
|
puts stderr "==============================================================================" |
|
puts stderr "WARNING: bootsupport modules are stale relative to source modules:" |
|
foreach _entry $_stale { |
|
lassign $_entry _pkg _src_ver _bs_ver _bump |
|
puts stderr [format " %-15s bootsupport=%-10s source=%-10s bump=%s" $_pkg $_bs_ver $_src_ver $_bump] |
|
} |
|
puts stderr "" |
|
puts stderr " Recommended fix — update bootsupport before proceeding:" |
|
puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport" |
|
puts stderr "==============================================================================" |
|
if {$_have_major} { |
|
puts stderr "-aborted- (major version bump in stale bootsupport — breaking change, cannot proceed)" |
|
exit 1 |
|
} |
|
if {$_have_minor} { |
|
#G-030 prompt policy: -confirm 0 proceeds without prompting; with the default -confirm 1 |
|
#a non-interactive stdin aborts fast with guidance instead of reading stdin. |
|
if {!$::punkboot::opt_confirm} { |
|
puts stderr "-proceeding with stale bootsupport (-confirm 0 supplied)-" |
|
} elseif {![::punkboot::lib::stdin_is_interactive]} { |
|
puts stderr "-aborted- (minor-version bootsupport staleness and stdin is not interactive)" |
|
puts stderr " Update bootsupport (recommended - see above), or rerun with -confirm 0 to proceed with stale bootsupport." |
|
exit 1 |
|
} elseif {![::punkboot::lib::bootsupport_prompt_yesno "Minor-version staleness — backward-compat aliases should keep old bootsupport functional."]} { |
|
puts stderr "-aborted- by user" |
|
exit 1 |
|
} else { |
|
puts stderr "-proceeding with stale bootsupport at user's request-" |
|
} |
|
} |
|
# patch-only staleness: warn and proceed (warning already printed above) |
|
} |
|
|
|
set scriptfolder $::punkboot::scriptfolder |
|
|
|
|
|
|
|
#first look for a project root (something under fossil or git revision control AND matches punk project folder structure) |
|
#If that fails - just look for a 'project shaped folder' ie meets minimum requirements of /src /src/lib /src/modules /lib /modules |
|
#test |
|
if {[catch {punk::repo::find_project}]} { |
|
puts stderr "punk::repo [package provide punk::repo]" |
|
} |
|
if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]} { |
|
if {![string length [set projectroot [punk::repo::find_candidate $scriptfolder]]]} { |
|
puts stderr "punkboot script unable to determine an approprite project root at or above the path '$scriptfolder' ensure the make script is within a project folder structure" |
|
puts stderr " -aborted- " |
|
exit 2 |
|
#todo? |
|
#ask user for a project name and create basic structure? |
|
#call punk::mix::cli::new $projectname on parent folder? |
|
} else { |
|
puts stderr "WARNING punkboot script operating in project space that is not under version control" |
|
} |
|
} else { |
|
|
|
} |
|
|
|
set sourcefolder $projectroot/src |
|
set binfolder $projectroot/bin |
|
|
|
# ---------------------------------------- |
|
# G-121 selective bake: resolve requested kit names against the parsed kit-mapping |
|
# model before ANY bake machinery runs - an unknown name must error without baking, |
|
# and a selected-but-unbuildable kit (missing runtime/vfs) fails fast rather than |
|
# silently doing nothing (bare 'bake' keeps the historical warn-and-continue |
|
# behaviour for the full configured set). The kit machinery and the vfslibs phase |
|
# consult the bake_selected_* results to confine processing (and punkcheck events) |
|
# to the requested kits. |
|
set ::punkboot::bake_selected_kitnames [list] ;#empty = all configured (bare bake/bakehouse/bin) |
|
set ::punkboot::bake_selected_targetkits [list] ;#platform artifact names (e.g punk91.exe) |
|
set ::punkboot::bake_selected_vfs [list] ;#vfs folder tails the selected kits use |
|
set ::punkboot::bake_selected_runtimes [list] ;#unsuffixed runtime names the selected kits wrap |
|
if {$::punkboot::command eq "bake" && [llength $::punkboot::opt_kitnames]} { |
|
set _rtbase $binfolder/runtime |
|
set _mapmodel [punkboot::lib::mapvfs_model $sourcefolder/runtime $_rtbase $sourcefolder $::punkboot::target_platform] |
|
if {[llength [dict get $_mapmodel configerrors]]} { |
|
foreach _errline [dict get $_mapmodel configerrors] { |
|
puts stderr $_errline |
|
} |
|
exit 3 |
|
} |
|
set _kit_outputs [punkboot::lib::mapvfs_kit_outputs $_mapmodel $_rtbase $sourcefolder] |
|
set _matchinfo [punkboot::lib::mapvfs_match_outputs $_kit_outputs $::punkboot::opt_kitnames] |
|
if {[llength [dict get $_matchinfo unknown]]} { |
|
puts stderr "make.tcl bake: unknown kit name(s): [join [dict get $_matchinfo unknown] {, }] - nothing built" |
|
if {[llength $_kit_outputs]} { |
|
puts stderr " configured kit outputs: [join [lmap _r $_kit_outputs {dict get $_r kitname}] {, }]" |
|
if {[dict size [dict get $_mapmodel groups]]} { |
|
puts stderr " configured groups (select with @<group>): [join [dict keys [dict get $_mapmodel groups]] {, }]" |
|
} |
|
} else { |
|
puts stderr " no kit outputs are configured (src/runtime/mapvfs.toml)" |
|
} |
|
foreach _n [dict get $_matchinfo unknown] { |
|
if {[string match -* $_n]} { |
|
puts stderr " note: flags go before kit names, e.g 'make.tcl bake -confirm 0 punk91'" |
|
break |
|
} |
|
} |
|
puts stderr " ('make.tcl bakelist' shows the configured kit matrix)" |
|
exit 1 |
|
} |
|
foreach _rec [dict get $_matchinfo selected] { |
|
if {![dict get $_rec vfs_present]} { |
|
puts stderr "make.tcl bake: kit '[dict get $_rec kitname]' cannot be built - vfs folder src/vfs/[dict get $_rec vfs] is missing - nothing built" |
|
exit 1 |
|
} |
|
if {[dict get $_rec runtime] ne "-" && ![dict get $_rec runtime_present]} { |
|
puts stderr "make.tcl bake: kit '[dict get $_rec kitname]' cannot be built - runtime [dict get $_rec runtime_file] not present in bin/runtime/[dict get $_rec store_tier] (target [dict get $_rec target]) - nothing built" |
|
exit 1 |
|
} |
|
} |
|
foreach _rec [dict get $_matchinfo selected] { |
|
lappend ::punkboot::bake_selected_kitnames [dict get $_rec kitname] |
|
lappend ::punkboot::bake_selected_targetkits [dict get $_rec targetkit] |
|
if {[dict get $_rec vfs] ni $::punkboot::bake_selected_vfs} { |
|
lappend ::punkboot::bake_selected_vfs [dict get $_rec vfs] |
|
} |
|
if {[dict get $_rec runtime] ni $::punkboot::bake_selected_runtimes} { |
|
lappend ::punkboot::bake_selected_runtimes [dict get $_rec runtime] |
|
} |
|
} |
|
puts stdout "selective bake (G-121): [join $::punkboot::bake_selected_kitnames {, }]" |
|
unset -nocomplain _rtbase _mapmodel _kit_outputs _matchinfo _rec _r _errline |
|
} |
|
|
|
# ---------------------------------------- |
|
# Provenance-warning presentation + dirty-src check for producing commands (goal G-026 direction). |
|
# Producing commands (mint/promote/bake) stamp versions onto src content and propagate it into trees other |
|
# things consume (root modules/, bootsupport snapshots, vfs payloads, kits/zipkits). |
|
# Artifacts built from uncommitted src have no committed provenance - warn by default, |
|
# abort if the -dirty-abort flag was given. To evaluate uncommitted source without |
|
# minting or baking, use '<builtexe> src' / '<builtexe> src shell' instead. |
|
# Guarded require: a stale or missing punkboot::utils bootsupport snapshot must never |
|
# brick the make.tcl commands used to repair it - the check degrades to a skip notice |
|
# (but -dirty-abort still aborts rather than silently skipping the requested strictness). |
|
|
|
#Emit provenance warnings with a plain column-0 token for automated discovery (grep PROVENANCE-WARNING |
|
#in redirected output) and ANSI colour for humans. Lines are also accumulated in |
|
#::punkboot::provenance_warnings_pending unless -norecap is given, so the wrapped ::exit below can |
|
#recap them at the tail of the output - make.tcl progress output is chatty and the original warning |
|
#position may scroll out of sight or even out of scrollback. |
|
set ::punkboot::provenance_warnings_pending [list] |
|
proc ::punkboot::print_provenance_warnings {warninglines args} { |
|
global A |
|
if {![array size A]} {punkboot::define_global_ansi} |
|
foreach w $warninglines { |
|
regsub {^WARNING: } $w "" w |
|
puts stderr "PROVENANCE-WARNING: $A(BAD)$w$A(RST)" |
|
if {"-norecap" ni $args} { |
|
lappend ::punkboot::provenance_warnings_pending $w |
|
} |
|
} |
|
flush stderr |
|
} |
|
#General bake warnings that must stay noticeable despite chatty output - same |
|
#column-0 greppable-token + recap-at-exit treatment as provenance warnings above. |
|
set ::punkboot::bake_warnings_pending [list] |
|
proc ::punkboot::print_bake_warnings {warninglines args} { |
|
global A |
|
if {![array size A]} {punkboot::define_global_ansi} |
|
foreach w $warninglines { |
|
regsub {^WARNING: } $w "" w |
|
puts stderr "BAKE-WARNING: $A(BAD)$w$A(RST)" |
|
if {"-norecap" ni $args} { |
|
lappend ::punkboot::bake_warnings_pending $w |
|
} |
|
} |
|
flush stderr |
|
} |
|
#Availability probe + scoped dirty-src check, shared by the producing-commands gate below and the |
|
#'check' command report. Returns {available warninglist}. |
|
proc ::punkboot::get_src_provenance_warnings {projectroot label} { |
|
set available [expr {\ |
|
![catch {package require punkboot::utils}]\ |
|
&& [llength [info commands ::punkboot::utils::vcs_dirty_warnings]]\ |
|
&& "scope" in [info args ::punkboot::utils::vcs_dirty_warnings]\ |
|
}] |
|
if {!$available} { |
|
return [list 0 [list]] |
|
} |
|
set checked_vcs_roots [dict create] |
|
return [list 1 [::punkboot::utils::vcs_dirty_warnings $projectroot checked_vcs_roots $label src]] |
|
} |
|
#Replace a file that may be MEMORY-MAPPED by another process (or by this one). |
|
# |
|
#On windows an ordinary 'file copy -force' onto a mapped file is refused: a zipfs mount |
|
#maps its archive (tclZipfs.c CreateFileMappingW + MapViewOfFile), so a zip-based .tm |
|
#modpod that any running shell - including this make.tcl run - has mounted cannot be overwritten |
|
#in place. Windows reports ERROR_USER_MAPPED_FILE (1224); Tcl's Tcl_WinConvertError maps |
|
#only Win32 codes 0..267 and sends everything above them to EINVAL, so it surfaces as the |
|
#uninformative "invalid argument" (same code in 8.6 and 9.x). |
|
# |
|
#UNLINKING a mapped file IS allowed - the holder keeps reading its own mapping and new |
|
#content lands at the name - so delete-then-place succeeds where overwrite cannot. The new |
|
#content goes to a sibling temp FIRST so a mid-sequence failure can never leave the target |
|
#missing. |
|
# |
|
#Returns one of: ok (plain copy worked), replaced (needed the delete-then-place path), |
|
#failed (target untouched), broken (target was unlinked and could not be restored - the |
|
#caller must treat this as serious). The first copy's error message is written to the |
|
#variable named by firsterrvar. |
|
proc ::punkboot::replace_possibly_mapped_file {srcfile tgtfile firsterrvar} { |
|
upvar 1 $firsterrvar firsterr |
|
set firsterr "" |
|
if {![catch {file copy -force $srcfile $tgtfile} firsterr]} { |
|
return ok |
|
} |
|
if {![file exists $tgtfile]} { |
|
#nothing to unlink - whatever failed, it was not an in-place overwrite |
|
return failed |
|
} |
|
set tmpfile $tgtfile.punkboot-new |
|
catch {file delete -force -- $tmpfile} |
|
if {[catch {file copy -- $srcfile $tmpfile}]} { |
|
catch {file delete -force -- $tmpfile} |
|
return failed |
|
} |
|
if {[catch {file delete -- $tgtfile}]} { |
|
catch {file delete -force -- $tmpfile} |
|
return failed |
|
} |
|
if {[catch {file rename -- $tmpfile $tgtfile}]} { |
|
return broken |
|
} |
|
return replaced |
|
} |
|
#Actionable text for a file-operation failure whose message is windows' catch-all. |
|
#Returns "" when the error does not look like that case. |
|
proc ::punkboot::mapped_file_hint {errmsg tgtfile} { |
|
if {![string match -nocase "*invalid argument*" $errmsg]} { |
|
return "" |
|
} |
|
return "'invalid argument' is Tcl's catch-all for any windows error above 267 (Tcl_WinConvertError), not a bad argument.\ |
|
For a file replace the usual cause is ERROR_USER_MAPPED_FILE: '$tgtfile' is memory-mapped by a process that has it mounted -\ |
|
a zipfs/modpod mount does this, so a running punk shell (or this make.tcl run) holding that .tm blocks an in-place overwrite.\ |
|
Close shells holding it, or rerun - the update now replaces such files by delete-then-place rather than overwrite." |
|
} |
|
#Availability probe + boot-precondition check of an assembled kit vfs (G-125), shared by the |
|
#kit gate in the bake loop and the 'check' command report. Same guarded-require treatment as |
|
#the provenance check above: a stale or missing punkboot::utils snapshot must not brick the |
|
#commands used to repair it, so an unavailable check degrades to a notice rather than failing |
|
#every kit. Returns {available report}. |
|
proc ::punkboot::get_vfs_boot_library_report {vfsfolder} { |
|
set available [expr {\ |
|
![catch {package require punkboot::utils}]\ |
|
&& [llength [info commands ::punkboot::utils::vfs_boot_library_report]]\ |
|
}] |
|
if {!$available} { |
|
return [list 0 [dict create]] |
|
} |
|
return [list 1 [::punkboot::utils::vfs_boot_library_report $vfsfolder]] |
|
} |
|
#Availability probe + root startup-script census of a kit SOURCE .vfs folder (G-031 |
|
#startup-script collision gate), consumed by the bake loop's per-kit refusal. Same |
|
#guarded-require treatment as the boot-precondition check above: a stale bootsupport |
|
#snapshot degrades the gate to a NOTE. Returns {available report}. |
|
proc ::punkboot::get_vfs_startup_script_report {vfsfolder} { |
|
set available [expr {\ |
|
![catch {package require punkboot::utils}]\ |
|
&& [llength [info commands ::punkboot::utils::vfs_startup_script_report]]\ |
|
}] |
|
if {!$available} { |
|
return [list 0 [dict create]] |
|
} |
|
return [list 1 [::punkboot::utils::vfs_startup_script_report $vfsfolder]] |
|
} |
|
#Availability probe + advisory payload/target binary-arch scan of an assembled kit vfs |
|
#(G-133), shared by the bake loop and the 'check' command report. Same guarded-require |
|
#treatment as the boot-precondition check above: a stale bootsupport snapshot degrades |
|
#the scan to a NOTE. Returns {available report}. |
|
proc ::punkboot::get_vfs_binary_arch_report {vfsfolder targetplatform} { |
|
set available [expr {\ |
|
![catch {package require punkboot::utils}]\ |
|
&& [llength [info commands ::punkboot::utils::vfs_binary_arch_report]]\ |
|
}] |
|
if {!$available} { |
|
return [list 0 [dict create]] |
|
} |
|
return [list 1 [::punkboot::utils::vfs_binary_arch_report $vfsfolder $targetplatform]] |
|
} |
|
#Availability probe + advisory zip offset-style check of an assembled kit image |
|
#(G-134), shared by the bake loop and the 'check' command report. Same guarded- |
|
#require treatment as the checks above: a stale bootsupport snapshot degrades |
|
#the pin to a NOTE. Returns {available report}. |
|
proc ::punkboot::get_kit_offsetstyle_report {kitpath} { |
|
set available [expr {\ |
|
![catch {package require punkboot::utils}]\ |
|
&& [llength [info commands ::punkboot::utils::kit_offsetstyle_report]]\ |
|
}] |
|
if {!$available} { |
|
return [list 0 [dict create]] |
|
} |
|
return [list 1 [::punkboot::utils::kit_offsetstyle_report $kitpath]] |
|
} |
|
#G-133 smoke-require probe: execute a freshly built kit artifact via its 'tclsh' |
|
#subcommand and plain-'package require' each declared package inside it. This is the |
|
#only check that observes actual package RESOLUTION in the artifact - the punkluck86 |
|
#incident class (a higher-versioned wrong-arch Thread shadowing the runtime's working |
|
#copy on plain require) is invisible to every structural check because the working |
|
#file exists. The tclsh subcommand is used deliberately: it exits cleanly even on |
|
#runtimes whose full repl teardown is fragile, and a script argument with drained |
|
#stdin cannot reach any console-reopen path. ADVISORY: failures become recapped |
|
#BAKE-WARNINGs naming kit, package and the actual error - the kit still deploys. |
|
#Returns 1 when every declared package resolved, else 0. |
|
proc ::punkboot::kit_smoke_require_probe {kitpath targetkit packages} { |
|
set probescript [file rootname $kitpath]_smokerequire.tcl |
|
if {[catch { |
|
set fd [open $probescript w] |
|
chan configure $fd -translation lf |
|
puts $fd "#generated by make.tcl bake (G-133) - smoke-require probe for $targetkit" |
|
puts $fd "set packages [list $packages]" |
|
puts $fd {foreach pkg $packages { |
|
if {[catch {package require $pkg} v]} { |
|
puts stdout [list SMOKE-REQUIRE $pkg FAIL $v] |
|
} else { |
|
puts stdout [list SMOKE-REQUIRE $pkg OK $v] |
|
} |
|
} |
|
exit 0} |
|
close $fd |
|
} errM]} { |
|
catch {close $fd} |
|
::punkboot::print_bake_warnings [list "smoke-require for kit $targetkit could not write its probe script ($probescript): $errM"] |
|
return 0 |
|
} |
|
if {[catch { |
|
lassign [punk::lib::invoke [list [file nativename $kitpath] tclsh [file nativename $probescript] << ""]] p_stdout p_stderr p_exitcode |
|
} errM]} { |
|
::punkboot::print_bake_warnings [list "smoke-require FAILED for kit $targetkit: could not execute freshly built artifact via its tclsh subcommand ($errM)"] |
|
return 0 |
|
} |
|
set seen [dict create] |
|
foreach line [split $p_stdout \n] { |
|
set line [string trim $line] |
|
if {![string match "SMOKE-REQUIRE *" $line]} { |
|
continue |
|
} |
|
#each line is a well-formed tcl list: SMOKE-REQUIRE <pkg> OK|FAIL <version|error> |
|
if {[catch {lassign $line - r_pkg r_status r_detail}]} { |
|
continue |
|
} |
|
dict set seen $r_pkg [list $r_status $r_detail] |
|
} |
|
set allok 1 |
|
set warnings [list] |
|
foreach pkg $packages { |
|
if {![dict exists $seen $pkg]} { |
|
set allok 0 |
|
set tail [string trim [join [lrange [split [string trim $p_stderr] \n] end-2 end] " | "]] |
|
lappend warnings "smoke-require FAILED for kit $targetkit: no result for package '$pkg' (artifact exited $p_exitcode before reporting[expr {$tail ne "" ? "; stderr tail: $tail" : ""}])" |
|
continue |
|
} |
|
lassign [dict get $seen $pkg] r_status r_detail |
|
if {$r_status eq "OK"} { |
|
puts stdout " smoke-require OK for kit $targetkit: package require $pkg -> $r_detail" |
|
} else { |
|
set allok 0 |
|
lappend warnings "smoke-require FAILED for kit $targetkit: package require $pkg -> $r_detail" |
|
} |
|
} |
|
if {$p_exitcode != 0} { |
|
set allok 0 |
|
lappend warnings "smoke-require for kit $targetkit: artifact exited with code $p_exitcode via its tclsh subcommand (expected 0)" |
|
} |
|
if {[llength $warnings]} { |
|
::punkboot::print_bake_warnings $warnings |
|
} |
|
return $allok |
|
} |
|
#Wrap ::exit so accumulated provenance warnings are recapped at the very end of output no matter |
|
#which of make.tcl's many exit points a command takes. |
|
if {![llength [info commands ::punkboot::exit_original]]} { |
|
rename ::exit ::punkboot::exit_original |
|
proc ::exit {{returnCode 0}} { |
|
if {[info exists ::punkboot::provenance_warnings_pending] && [llength $::punkboot::provenance_warnings_pending]} { |
|
puts stderr "" |
|
puts stderr "PROVENANCE-WARNING: recap of warning(s) emitted earlier in this run:" |
|
::punkboot::print_provenance_warnings $::punkboot::provenance_warnings_pending -norecap |
|
} |
|
if {[info exists ::punkboot::bake_warnings_pending] && [llength $::punkboot::bake_warnings_pending]} { |
|
puts stderr "" |
|
puts stderr "BAKE-WARNING: recap of warning(s) emitted earlier in this run:" |
|
::punkboot::print_bake_warnings $::punkboot::bake_warnings_pending -norecap |
|
} |
|
::punkboot::exit_original $returnCode |
|
} |
|
} |
|
|
|
if {$::punkboot::command in {bakehouse packages modules libs bake vfslibs bin bootsupport vfscommonupdate}} { |
|
set dirty_abort $::punkboot::opt_dirty_abort |
|
lassign [::punkboot::get_src_provenance_warnings $projectroot "make.tcl $::punkboot::command"] have_scoped_dirty_check dirty_warnings |
|
if {$have_scoped_dirty_check} { |
|
if {[llength $dirty_warnings]} { |
|
::punkboot::print_provenance_warnings $dirty_warnings |
|
puts stderr " To evaluate uncommitted source without minting or baking, use '<builtexe> src' or '<builtexe> src shell'." |
|
if {$dirty_abort} { |
|
set ::punkboot::provenance_warnings_pending [list] ;#no recap needed - aborting adjacent to the warning |
|
if {$::punkboot::command eq "bakehouse"} { |
|
puts stderr "-aborted- bakehouse refuses to bake from uncommitted src (the bakehouse bakes from the committed recipe)." |
|
puts stderr " Developer flow for uncommitted changes:" |
|
puts stderr " make.tcl packages -> test ('<builtexe> src', src/tests/runtests.tcl)" |
|
puts stderr " make.tcl bootsupport + make.tcl vfscommonupdate (promotion gates)" |
|
puts stderr " commit -> make.tcl bake" |
|
puts stderr " To proceed anyway without committed provenance: make.tcl bakehouse -dirty-abort 0" |
|
} else { |
|
puts stderr "-aborted- (-dirty-abort given and src has uncommitted changes - commit first, or rerun without -dirty-abort to proceed with a warning)" |
|
} |
|
exit 1 |
|
} |
|
#Grace period for an attentive human to ctrl-c - only when stdin is a terminal |
|
#(-inputmode is only supported on terminal channels, Tcl 8.7+/9; pipes/redirects/8.6 skip the delay |
|
# so agent/CI runs pay nothing) |
|
if {![catch {chan configure stdin -inputmode}]} { |
|
puts -nonewline stderr " proceeding despite dirty src - ctrl-c now to abort " |
|
flush stderr |
|
foreach tick {3 2 1} { |
|
puts -nonewline stderr "..$tick" |
|
flush stderr |
|
after 1000 |
|
} |
|
puts stderr "" |
|
} |
|
} |
|
} else { |
|
if {$dirty_abort} { |
|
puts stderr "-aborted- (-dirty-abort given but the dirty-src provenance check is unavailable: punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport)" |
|
exit 1 |
|
} |
|
puts stderr "NOTE: dirty-src provenance check unavailable (punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport) - continuing without it" |
|
} |
|
} |
|
|
|
if {$::punkboot::command eq "check"} { |
|
set sep [string repeat - 75] |
|
puts stdout $sep |
|
puts stdout "colour policy (G-113): mode=$::punkboot::colour_mode colour_disabled=$::punk::console::colour_disabled ansistrip=[expr {[llength $::punkboot::ansistrip_pushed] ? [join $::punkboot::ansistrip_pushed +] : 0}]" |
|
puts stdout " (precedence: NO_COLOR > PUNK_FORCE_COLOR/FORCE_COLOR > stdout tty probe incl. the 8.6 windows console-encoding signature; piped/unknown output is fully ESC-stripped per channel unless forced - utf-16 console channels are never wrapped)" |
|
puts stdout $sep |
|
#G-122 host/target platform split - the self-diagnosis for "why is my kit set |
|
#addressed the way it is". One stable single line; the columns are key=value. |
|
set _chk_suffix [punkboot::lib::platform_exe_suffix $::punkboot::target_platform] |
|
if {$_chk_suffix eq ""} {set _chk_suffix "(none)"} |
|
puts stdout "platform (G-122): host=$::punkboot::host_platform target=$::punkboot::target_platform store=bin/runtime/[punkboot::lib::platform_store_tier $::punkboot::target_platform] exe-suffix=$_chk_suffix process-tooling=[punkboot::lib::platform_process_family $::punkboot::target_platform]" |
|
puts stdout " (host = this tclsh's punk::platform canon, from tcl_platform(os)='$::tcl_platform(os)' platform='$::tcl_platform(platform)'; target = default kit target - a cygwin-family host (msys2/cygwin runtime on windows) bakes win32 kits)" |
|
puts stdout " (mapvfs.toml entries may declare their own target platform (target key) - 'make.tcl bakelist' shows each kit's target, store tier and artifact name)" |
|
unset -nocomplain _chk_suffix |
|
puts stdout $sep |
|
puts stdout "module/library checks - paths from bootsupport only" |
|
puts stdout $sep |
|
puts stdout "- tcl::tm::list" |
|
foreach fld [tcl::tm::list] { |
|
if {[file exists $fld]} { |
|
puts stdout " $fld" |
|
} else { |
|
puts stdout " $fld (not present)" |
|
} |
|
} |
|
puts stdout "- auto_path" |
|
foreach fld $::auto_path { |
|
if {[file exists $fld]} { |
|
puts stdout " $fld" |
|
} else { |
|
puts stdout " $fld (not present)" |
|
} |
|
} |
|
flush stdout |
|
set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] |
|
foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { |
|
lassign $pkg_request pkgname vrequest |
|
package require $pkgname {*}$vrequest ;#todo? |
|
} |
|
flush stderr |
|
#punk::lib::showdict -channel stderr $::punkboot::pkg_availability |
|
set missing_out [::punkboot::get_display_missing_packages $::punkboot::pkg_availability] |
|
puts stdout $missing_out\n |
|
|
|
set broken_out [::punkboot::get_display_broken_packages $::punkboot::pkg_availability] |
|
puts stdout $broken_out |
|
|
|
set v [package require punk::mix::base] |
|
|
|
#don't exit yet - 2nd part of "check" below package path restore |
|
} |
|
# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- |
|
# - package path restore original module paths and auto_path entries to take effect in addition to bootsupport paths |
|
# - Order such that bootsupport entries are always higher priority (if same version number - prefer bootsupport) |
|
# - This must be done between the two "check" command sections |
|
|
|
# Ideally we would be running make.tcl purely from bootsupport packages - but binary packages such as Thread are required, |
|
# and without accelerators the performance is abysmal (e.g minutes vs seconds for common sha1 operations) |
|
|
|
if {$package_paths_modified} { |
|
set tm_list_boot [tcl::tm::list] |
|
tcl::tm::remove {*}$tm_list_boot |
|
|
|
set lower_prio [list] |
|
foreach p $original_tm_list { |
|
if {$p ni $tm_list_boot} { |
|
lappend lower_prio $p |
|
} |
|
} |
|
tcl::tm::add {*}[lreverse $lower_prio] {*}[lreverse $tm_list_boot] |
|
|
|
#set ::auto_path [list $bootsupport_lib {*}$original_auto_path] |
|
lappend ::auto_path {*}$original_auto_path |
|
} |
|
# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- |
|
|
|
|
|
# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- |
|
#The problem with forcing our main packages to load only from bootsupport/sourcesupport is that if they require packages that use accelerators |
|
# and no acceleration is available in bootsupport/sourcesupport - then they will stay unaccelerated even if the os packages provide it |
|
# Also - some packages such as struct::set don't seem to handle reloading after forget (at least - not without destroying the command first) |
|
#Packages that provide acceleration don't use a consistent API for testing acceleration e.g md5, sha1, struct::set in tcllib all differ in |
|
#whether they provide functions such as Loaded, Implementations, SwitchTo |
|
set acceleratable [list sha1 md5] |
|
lappend acceleratable {*}[lsearch -all -inline [package names] struct::*] |
|
set acceleratable_reload [list] |
|
foreach p $acceleratable { |
|
if {[package provide $p] ne ""} { |
|
#was actually loaded (not merely indexed) - must be re-required below or consumers |
|
#that already required it are left calling a destroyed/forgotten command |
|
lappend acceleratable_reload $p |
|
} |
|
package forget $p |
|
if {[string match struct::* $p]} { |
|
catch {rename $p ""} |
|
} |
|
} |
|
#Re-require whatever was loaded before the forget. The forget/rename exists so the reload can |
|
#pick up accelerators (e.g tcllibc) from the now-restored full package paths - but the reload |
|
#must actually happen here: when make.tcl runs under a built punk executable the consumers |
|
#(punk::lib, punk::du, flagfilter etc) were already loaded at kit boot, so no later |
|
#'package require' chain re-fires for these and e.g raw-mode repl paths would hit |
|
#'invalid command name struct::set'. (Under plain tclsh the shell-branch loads happened to |
|
#re-require them - relying on that was load-order luck, not design.) |
|
foreach p $acceleratable_reload { |
|
if {[catch {package require $p} _accelerr]} { |
|
puts stderr "make.tcl: failed to reload package $p after accelerator-reload forget ($_accelerr) - its commands are unavailable for the rest of this run" |
|
} |
|
} |
|
unset -nocomplain acceleratable_reload _accelerr |
|
# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- |
|
|
|
|
|
#2nd part of "check" |
|
if {$::punkboot::command eq "check"} { |
|
set sep [string repeat - 75] |
|
puts stdout $sep |
|
puts stdout "module/library checks - paths from bootsupport plus those provided by running interp [info nameofexecutable]" |
|
puts stdout $sep |
|
puts stdout "- tcl::tm::list" |
|
foreach fld [tcl::tm::list] { |
|
if {[file exists $fld]} { |
|
puts stdout " $fld" |
|
} else { |
|
#puts stdout " $fld (not present)" |
|
} |
|
} |
|
puts stdout "- auto_path" |
|
foreach fld $::auto_path { |
|
if {[file exists $fld]} { |
|
puts stdout " $fld" |
|
} else { |
|
#puts stdout " $fld (not present)" |
|
} |
|
} |
|
set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] |
|
foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { |
|
lassign $pkg_request pkgname vrequest |
|
if {[catch {package require $pkgname {*}$vrequest} errM]} { |
|
puts stderr "failed to load $pkgname\n - $errM\n - $::errorInfo" |
|
} |
|
} |
|
flush stderr |
|
#punk::lib::showdict -channel stderr $::punkboot::pkg_availability |
|
set missing_out [::punkboot::get_display_missing_packages $::punkboot::pkg_availability] |
|
puts stdout $missing_out\n |
|
set broken_out [::punkboot::get_display_broken_packages $::punkboot::pkg_availability] |
|
puts stdout $broken_out |
|
puts stdout $sep |
|
puts stdout $sep |
|
catch {package require struct::set} |
|
puts stdout ---[package ifneeded struct::set 2.2.3] |
|
# Show bootsupport staleness warning at the end of check output |
|
if {[info exists ::punkboot::stale_bootsupport]} { |
|
puts stderr "==============================================================================" |
|
puts stderr "WARNING: bootsupport modules are stale relative to source modules:" |
|
foreach _entry $::punkboot::stale_bootsupport { |
|
lassign $_entry _pkg _src_ver _bs_ver _bump |
|
puts stderr [format " %-15s bootsupport=%-10s source=%-10s bump=%s" $_pkg $_bs_ver $_src_ver $_bump] |
|
} |
|
puts stderr "" |
|
puts stderr " Run the following to update bootsupport before proceeding:" |
|
puts stderr " cd \[projectroot\]/src && tclsh make.tcl modules && tclsh make.tcl bootsupport" |
|
puts stderr "==============================================================================" |
|
} |
|
# Dirty-src provenance status - what the producing commands would do |
|
puts stdout $sep |
|
lassign [::punkboot::get_src_provenance_warnings $projectroot "make.tcl check"] _prov_available _prov_warnings |
|
if {!$_prov_available} { |
|
puts stdout "src provenance: check unavailable (punkboot::utils vcs_dirty_warnings with scope support not loadable from bootsupport)" |
|
puts stdout " producing commands (mint/promote/bake) will proceed with a NOTE; -dirty-abort would abort as unverifiable." |
|
} elseif {![llength $_prov_warnings]} { |
|
puts stdout "src provenance: OK (no uncommitted fossil/git changes under src/)" |
|
puts stdout " producing commands (bakehouse packages modules libs bake vfslibs bin bootsupport vfscommonupdate) will proceed without provenance warnings." |
|
} else { |
|
::punkboot::print_provenance_warnings $_prov_warnings -norecap |
|
puts stdout " producing commands (bakehouse packages modules libs bake vfslibs bin bootsupport vfscommonupdate) will WARN as above and proceed." |
|
puts stdout " With -dirty-abort they would abort. To evaluate uncommitted source without minting or baking, use '<builtexe> src' or '<builtexe> src shell'." |
|
} |
|
# Kit boot-precondition gate status - whether a bake can refuse an unbootable kit |
|
puts stdout $sep |
|
#availability probe only - the path deliberately does not exist |
|
lassign [::punkboot::get_vfs_boot_library_report [file join $projectroot __punkboot_bootgate_probe__]] _boot_available _boot_report |
|
if {$_boot_available} { |
|
puts stdout "boot-precondition gate (G-125): ACTIVE" |
|
puts stdout " bake checks each kit's merged vfs for a tcl library (tcl_library/, lib/tcl<major>.<minor>/ or" |
|
puts stdout " tcl<major>.<minor>/) before baking it. A kit with none is reported under FAILED KITS and is" |
|
puts stdout " neither built nor deployed, so a previously deployed kit is never replaced by an artifact that" |
|
puts stdout " cannot initialise." |
|
} else { |
|
puts stdout "boot-precondition gate (G-125): UNAVAILABLE (punkboot::utils vfs_boot_library_report not loadable from bootsupport)" |
|
puts stdout " bake will proceed with a NOTE and cannot refuse an unbootable kit - run 'make.tcl modules' then 'make.tcl bootsupport'." |
|
} |
|
# Payload/target consistency checks (G-133) - advisory arch scan + smoke-require probe |
|
puts stdout $sep |
|
#availability probe only - the path deliberately does not exist |
|
lassign [::punkboot::get_vfs_binary_arch_report [file join $projectroot __punkboot_archscan_probe__] $::punkboot::target_platform] _arch_available _arch_report |
|
if {$_arch_available} { |
|
puts stdout "payload/target arch scan (G-133): ACTIVE (advisory)" |
|
puts stdout " bake classifies each merged kit's binary libraries (*.dll/*.so/*.dylib header bytes - structural," |
|
puts stdout " nothing executed, cross-target kits included) against the kit's target platform and emits" |
|
puts stdout " recapped BAKE-WARNINGs for wrong-arch libraries outside platform-discriminated subdirs" |
|
puts stdout " (canonical <os>-<cpu> names and recognised vendor spellings such as win-x64 are exempt)." |
|
} else { |
|
puts stdout "payload/target arch scan (G-133): UNAVAILABLE (punkboot::utils vfs_binary_arch_report not loadable from bootsupport)" |
|
puts stdout " bake will proceed with a NOTE and cannot flag wrong-arch payload libraries - run 'make.tcl modules' then 'make.tcl bootsupport'." |
|
} |
|
# Kit offset-style pin (G-134) - advisory archive-relative output contract |
|
puts stdout $sep |
|
#availability probe only - the path deliberately does not exist |
|
lassign [::punkboot::get_kit_offsetstyle_report [file join $projectroot __punkboot_offsetstyle_probe__]] _off_available _off_report |
|
if {$_off_available} { |
|
puts stdout "kit offset-style pin (G-134): ACTIVE (advisory)" |
|
puts stdout " bake probes each assembled kit image with punk::zip::archive_info and emits a recapped" |
|
puts stdout " BAKE-WARNING when an attached zip payload records FILE-relative offsets (the pipeline" |
|
puts stdout " emits archive-relative by construction; the G-128 stamper refuses file-relative by default)." |
|
puts stdout " plain/none results (no attached zip - e.g the metakit kit shape) are silence, not warnings." |
|
} else { |
|
puts stdout "kit offset-style pin (G-134): UNAVAILABLE (punkboot::utils kit_offsetstyle_report not loadable from bootsupport)" |
|
puts stdout " bake will proceed with a NOTE and cannot flag a file-relative kit payload - run 'make.tcl modules' then 'make.tcl bootsupport'." |
|
} |
|
set _smoke_declared [list] |
|
if {[file exists [punkboot::lib::mapvfs_locate $sourcefolder/runtime]]} { |
|
set _smokemodel [punkboot::lib::mapvfs_model $sourcefolder/runtime [file dirname $sourcefolder]/bin/runtime $sourcefolder $::punkboot::target_platform] |
|
foreach _rec [punkboot::lib::mapvfs_kit_outputs $_smokemodel [file dirname $sourcefolder]/bin/runtime $sourcefolder] { |
|
if {[llength [dict get $_rec smokerequire]]} { |
|
lappend _smoke_declared "[dict get $_rec kitname] ([join [dict get $_rec smokerequire] {, }])" |
|
} |
|
} |
|
unset -nocomplain _smokemodel _rec |
|
} |
|
puts stdout "smoke-require probe (G-133, advisory): freshly built host-runnable kits declaring packages" |
|
puts stdout " (mapvfs.toml smokerequire key; legacy mapvfs.config 5th entry element) have each one plain-'package require'd inside the built" |
|
puts stdout " artifact via its tclsh subcommand - the only check that sees resolution-order defects such as" |
|
puts stdout " a wrong-arch higher-versioned package shadowing a working copy. Failures are recapped" |
|
puts stdout " BAKE-WARNINGs; cross-target kits skip with a stated reason; undeclared kits run nothing new." |
|
if {[llength $_smoke_declared]} { |
|
puts stdout " declared: [join $_smoke_declared {; }]" |
|
} else { |
|
puts stdout " declared: (none)" |
|
} |
|
puts stdout $sep |
|
exit 0 |
|
} |
|
|
|
if {![array size A]} { |
|
punkboot::define_global_ansi |
|
} |
|
|
|
#puts stderr ">>>>>>+ loaded:[info loaded]" |
|
#puts stderr "llength package names: [llength [package names]]" |
|
if {[info exists ::punk::libunknown::epoch]} { |
|
set untracked [dict get $::punk::libunknown::epoch pkg untracked] |
|
#puts stderr "punk::libunknown::epoch exists" |
|
} else { |
|
set untracked [list] |
|
#puts stderr "punk::libunknown::epoch does not exist" |
|
} |
|
#REVIEW - we shouldn't need to manually set the untracked packages - punk::libunknown::init should have done it? |
|
foreach p [package names] { |
|
if {![dict exists $untracked $p]} { |
|
dict set untracked $p "" |
|
} |
|
} |
|
dict set ::punk::libunknown::epoch pkg untracked $untracked |
|
|
|
if {[package provide punk::libunknown] eq ""} { |
|
puts "punk::libunknown not loaded" |
|
} else { |
|
puts "punk::libunknown loaded" |
|
} |
|
dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { |
|
set verspec [dict get $pkginfo version] ;#version wanted specification always exists and is empty or normalised |
|
if {[catch {package require $pkg {*}$verspec} errM]} { |
|
puts stdout "$A(BAD)$errM$A(RST)" |
|
} |
|
} |
|
|
|
if {$::punkboot::command eq "info"} { |
|
puts stdout "- -- --- --- --- --- --- --- --- --- -- -" |
|
puts stdout "- -- info -- -" |
|
puts stdout "- -- --- --- --- --- --- --- --- --- -- -" |
|
puts stdout "- projectroot : $projectroot" |
|
set sourcefolder $projectroot/src |
|
#todo show all but highlight the one that matches $this_platform_generic |
|
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib vendorlib_tcl*] |
|
puts stdout "- vendorlib folders: ([llength $vendorlibfolders])" |
|
foreach fld $vendorlibfolders { |
|
puts stdout " src/$fld" |
|
} |
|
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] |
|
puts stdout "- vendormodule folders: ([llength $vendormodulefolders])" |
|
foreach fld $vendormodulefolders { |
|
puts stdout " src/$fld" |
|
} |
|
#set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] ;#returns only those containing .tm files |
|
#foreach fld $source_module_folderlist { |
|
# set relpath [punkcheck::lib::path_relative $projectroot $fld] |
|
# puts stdout " $relpath" |
|
#} |
|
set projectmodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails modules_tcl* modules] |
|
puts stdout "- source module paths: [llength $projectmodulefolders]" |
|
#JJJ |
|
foreach fld $projectmodulefolders { |
|
puts stdout " $fld" |
|
} |
|
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl* lib] |
|
puts stdout "- source libary paths: [llength $projectlibfolders]" |
|
foreach fld $projectlibfolders { |
|
puts stdout " src/$fld" |
|
} |
|
if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { |
|
set vc "fossil" |
|
set rev [punk::repo::fossil_revision $scriptfolder] |
|
set rem [punk::repo::fossil_remote $scriptfolder] |
|
} elseif {[punk::repo::find_git $scriptfolder] eq $projectroot} { |
|
set vc "git" |
|
set rev [punk::repo::git_revision $scriptfolder] |
|
set rem [punk::repo::git_remote $scriptfolder] |
|
} else { |
|
set vc " - none found -" |
|
set rev "n/a" |
|
set remotes "n/a" |
|
} |
|
puts stdout "- version control : $vc" |
|
puts stdout "- revision : $rev" |
|
puts stdout "- remote" |
|
foreach ln [split $rem \n] { |
|
puts stdout " $ln" |
|
} |
|
puts stdout "- -- --- --- --- --- --- --- --- --- -- -" |
|
|
|
exit 0 |
|
} |
|
|
|
if {$::punkboot::command eq "projectversion"} { |
|
package require punkboot::utils |
|
set sep [string repeat - 75] |
|
puts stdout $sep |
|
puts stdout "project version check" |
|
puts stdout $sep |
|
|
|
set pp_file [file join $projectroot punkproject.toml] |
|
set cl_file [file join $projectroot CHANGELOG.md] |
|
set src_folder [file join $projectroot src] |
|
|
|
set pp_version [::punkboot::utils::read_punkproject_version $pp_file] |
|
set cl_version [::punkboot::utils::read_changelog_latest_version $cl_file] |
|
|
|
puts stdout "punkproject.toml version : [expr {[string length $pp_version] ? $pp_version : "(not found)"}]" |
|
puts stdout "CHANGELOG.md version : [expr {[string length $cl_version] ? $cl_version : "(not found)"}]" |
|
|
|
# 1. Consistency: CHANGELOG latest header must match punkproject.toml version. |
|
if {![string length $pp_version]} { |
|
puts stderr "WARNING: could not read version from $pp_file" |
|
} elseif {![string length $cl_version]} { |
|
puts stderr "WARNING: no '## \[X.Y.Z\]' version header found in $cl_file" |
|
} elseif {$pp_version ne $cl_version} { |
|
puts stderr "WARNING: version mismatch — punkproject.toml=$pp_version but CHANGELOG.md=$cl_version" |
|
puts stderr " The latest '## \[X.Y.Z\]' header in CHANGELOG.md must match the version in punkproject.toml." |
|
} else { |
|
puts stdout "consistency: OK (versions match)" |
|
} |
|
|
|
# 2. Staleness: warn if src/ has git commits since the last commit |
|
# touching punkproject.toml (version bump may be overdue). |
|
# If punkproject.toml has an uncommitted version change, the bump is |
|
# already in progress — report that only a commit is needed. |
|
# Best-effort — silently skipped if git is unavailable or the repo |
|
# is not under git revision control. |
|
set pp_commit "" |
|
if {![catch {exec git -C $projectroot log -1 --format=%H -- punkproject.toml} pp_raw]} { |
|
set pp_commit [string trim $pp_raw] |
|
} |
|
if {[string length $pp_commit]} { |
|
if {![catch {exec git -C $projectroot log --oneline ${pp_commit}..HEAD -- src/} src_raw]} { |
|
set src_changes [string trim $src_raw] |
|
if {[string length $src_changes]} { |
|
set n [llength [split $src_changes \n]] |
|
|
|
# Check whether a bump is already staged in the working tree |
|
# (punkproject.toml modified but uncommitted). If the working- |
|
# tree version differs from HEAD, the bump is done — only a |
|
# commit is needed. |
|
set head_version "" |
|
if {![catch {exec git -C $projectroot show HEAD:punkproject.toml} head_raw]} { |
|
set head_version [::punkboot::utils::parse_punkproject_version $head_raw] |
|
} |
|
set bump_uncommitted [expr {[string length $head_version] && [string length $pp_version] && $pp_version ne $head_version}] |
|
|
|
if {$bump_uncommitted} { |
|
puts stderr "NOTE: $n commit(s) in src/ since last punkproject.toml commit, but punkproject.toml already bumped ($head_version -> $pp_version, uncommitted)." |
|
puts stderr " Commit punkproject.toml (and CHANGELOG.md) to record the bump and clear this warning." |
|
} else { |
|
puts stderr "WARNING: $n commit(s) in src/ since last punkproject.toml change — a project-version bump may be overdue." |
|
puts stderr " Review the changes and bump punkproject.toml per the root AGENTS.md 'Project Versioning' section." |
|
} |
|
puts stderr " (showing first 5 commits below)" |
|
set i 0 |
|
foreach line [split $src_changes \n] { |
|
if {$i >= 5} break |
|
puts stderr " $line" |
|
incr i |
|
} |
|
} else { |
|
puts stdout "staleness: OK (no src/ changes since last punkproject.toml commit)" |
|
} |
|
} else { |
|
puts stdout "staleness: skipped (git query failed)" |
|
} |
|
} else { |
|
puts stdout "staleness: skipped (punkproject.toml has no git history or git unavailable)" |
|
} |
|
|
|
puts stdout $sep |
|
exit 0 |
|
} |
|
|
|
if {$::punkboot::command eq "workflow"} { |
|
puts stdout [::punkboot::workflow_text] |
|
exit 0 |
|
} |
|
|
|
if {$::punkboot::command eq "bakelist"} { |
|
#G-121: report the kit outputs configured in src/runtime/mapvfs.config, consuming |
|
#the same parsed mapping model as the bake kit machinery (::punkboot::lib::mapvfs_*). |
|
#Reporting only - never bakes. Data rows are single-line and column-stable for |
|
#grepping; expected state sits in the columns, anomalies surface in a trailing |
|
#sparse notes column (key=value tags). Kit name arguments filter the report and |
|
#add a per-kit detail block (resolved paths/sizes/mtimes). |
|
#G-122: store addressing is keyed by TARGET platform. The default target is |
|
#this host's own platform (a cygwin-family host targets win32) and mapvfs |
|
#entries may declare their own - so each row resolves its own tier under |
|
#bin/runtime and the report names the tiers it consulted. |
|
set rt_default_target $::punkboot::target_platform |
|
set rt_os_arch [punkboot::lib::platform_store_tier $rt_default_target] |
|
set rtbase $binfolder/runtime |
|
set rtfolder $rtbase/$rt_os_arch |
|
set bakefolder $sourcefolder/_bake |
|
set mapfile [punkboot::lib::mapvfs_locate $sourcefolder/runtime] |
|
set mapmodel [punkboot::lib::mapvfs_model $sourcefolder/runtime $rtbase $sourcefolder $rt_default_target] |
|
foreach errline [dict get $mapmodel configerrors] { |
|
puts stderr $errline |
|
} |
|
foreach badline [dict get $mapmodel badentries] { |
|
puts stderr $badline |
|
} |
|
if {[dict get $mapmodel format] eq "legacy"} { |
|
#deprecation NOTE (first warnings line) - bakelist is reporting-only, so |
|
#surface it here rather than relying on the bake path's warning printout |
|
foreach warnline [dict get $mapmodel warnings] { |
|
if {[string match NOTE:* $warnline]} { |
|
puts stderr $warnline |
|
} |
|
} |
|
} |
|
if {![dict get $mapmodel exists]} { |
|
puts stdout "no kit mapping config at $mapfile - no kit outputs configured" |
|
exit 0 |
|
} |
|
set kit_outputs [punkboot::lib::mapvfs_kit_outputs $mapmodel $rtbase $sourcefolder] |
|
if {![llength $kit_outputs]} { |
|
puts stdout "no kit outputs configured in $mapfile" |
|
exit 0 |
|
} |
|
#Loud store-tier guard: a nonexistent store folder makes every row addressing it |
|
#read runtime=missing for a reason that is not per-entry. Reported per tier |
|
#actually referenced, since entries may target different platforms (G-122). |
|
set report_tiers [list] |
|
foreach rec $kit_outputs { |
|
if {[dict get $rec runtime] eq "-"} {continue} |
|
set t [dict get $rec store_tier] |
|
if {$t ni $report_tiers} {lappend report_tiers $t} |
|
} |
|
set rt_store_missing [expr {![file isdirectory $rtfolder]}] |
|
if {$rt_os_arch ni $report_tiers} {lappend report_tiers $rt_os_arch} |
|
foreach t $report_tiers { |
|
if {[file isdirectory $rtbase/$t]} {continue} |
|
if {$t eq $rt_os_arch} { |
|
puts stderr "WARNING: runtime store folder bin/runtime/$t does not exist - every configured runtime on the default target will read runtime=missing." |
|
puts stderr " Default target '$rt_default_target' derives from THIS tclsh: tcl_platform(os)='$::tcl_platform(os)' tcl_platform(platform)='$::tcl_platform(platform)' -> host canon '$::punkboot::host_platform' -> target '$rt_default_target'." |
|
puts stderr " Populate it with 'bin/punk-runtime.cmd' (or by hand), or declare a per-entry target platform in mapvfs.toml for runtimes stored elsewhere." |
|
} else { |
|
puts stderr "WARNING: runtime store folder bin/runtime/$t does not exist - configured entries targeting $t will read runtime=missing." |
|
} |
|
} |
|
set reportset $kit_outputs |
|
if {[llength $::punkboot::opt_kitnames]} { |
|
set matchinfo [punkboot::lib::mapvfs_match_outputs $kit_outputs $::punkboot::opt_kitnames] |
|
if {[llength [dict get $matchinfo unknown]]} { |
|
puts stderr "bakelist: unknown kit name(s): [join [dict get $matchinfo unknown] {, }]" |
|
puts stderr " configured kit outputs: [join [lmap r $kit_outputs {dict get $r kitname}] {, }]" |
|
if {[dict size [dict get $mapmodel groups]]} { |
|
puts stderr " configured groups (select with @<group>): [join [dict keys [dict get $mapmodel groups]] {, }]" |
|
} |
|
exit 1 |
|
} |
|
set reportset [dict get $matchinfo selected] |
|
} |
|
#assemble rows before printing so columns can be sized to content |
|
set rows [list] |
|
foreach rec $reportset { |
|
set kitname [dict get $rec kitname] |
|
set kit_type [dict get $rec kit_type] |
|
set runtime [dict get $rec runtime] |
|
set vfstail [dict get $rec vfs] |
|
#G-127: deploy-state roots follow the record's output tier (non-default |
|
#targets live under kits/<platform>/ in both bin/ and src/_bake/) |
|
set out_tier [dict get $rec out_tier] |
|
if {$out_tier eq ""} { |
|
set deployed [punkboot::lib::kit_deploy_state $bakefolder $binfolder [dict get $rec targetkit]] |
|
} else { |
|
set deployed [punkboot::lib::kit_deploy_state $bakefolder/$out_tier $binfolder/$out_tier [dict get $rec targetkit]] |
|
} |
|
set notes [list] |
|
if {$runtime ne "-" && ![dict get $rec runtime_present]} { |
|
lappend notes runtime=missing |
|
} |
|
if {![dict get $rec vfs_present]} { |
|
lappend notes vfs=missing |
|
} |
|
if {[dict get $rec target] ne $rt_default_target} { |
|
#cross-target entry: its runtime, store tier and artifact naming follow |
|
#its own platform, not this host's default |
|
lappend notes target=[dict get $rec target] |
|
#G-127: and its bake/deploy locations sit under the kits/<platform>/ tier |
|
lappend notes out=$out_tier/ |
|
} |
|
if {[dict get $rec group] ne ""} { |
|
lappend notes group=[dict get $rec group] |
|
} |
|
if {![dict get $rec bake_default]} { |
|
#excluded from full bakes - bake by name or @group (G-024) |
|
lappend notes default=no |
|
} |
|
if {[dict get $rec scheme_role] ne ""} { |
|
lappend notes scheme=[dict get $rec scheme_role] |
|
} |
|
if {$runtime ne "-" && [dict get $rec runtime_present]} { |
|
set rtstale [punkboot::lib::runtime_materialization_check [dict get $rec runtime_dir] [dict get $rec runtime_file]] |
|
if {[dict size $rtstale]} { |
|
lappend notes rtrev=r[dict get $rtstale current_rev]<r[dict get $rtstale maxrev] |
|
} |
|
} |
|
lappend rows [list $kitname $kit_type $runtime $vfstail $deployed [join $notes " "]] |
|
} |
|
set headings [list kit type runtime vfs deployed] |
|
set widths [list] |
|
foreach h $headings { |
|
lappend widths [string length $h] |
|
} |
|
foreach row $rows { |
|
set newwidths [list] |
|
foreach w $widths cell [lrange $row 0 4] { |
|
lappend newwidths [expr {max($w,[string length $cell])}] |
|
} |
|
set widths $newwidths |
|
} |
|
set rt_store_note [expr {$rt_store_missing ? " (FOLDER MISSING)" : ""}] |
|
if {[info exists ::env(PUNK_MAPVFS_CONFIG)] && $::env(PUNK_MAPVFS_CONFIG) ne ""} { |
|
set map_display "$mapfile (PUNK_MAPVFS_CONFIG override)" |
|
} else { |
|
set map_display "src/runtime/[file tail $mapfile]" |
|
if {[dict get $mapmodel format] eq "legacy"} { |
|
append map_display " (deprecated format)" |
|
} |
|
} |
|
puts stdout "# mapvfs: $map_display runtimes: bin/runtime/$rt_os_arch$rt_store_note deployed: bin/<kit> vs src/_bake/<kit> (out= rows: under kits/<platform>/)" |
|
set headline "" |
|
foreach h $headings w $widths { |
|
append headline [format "%-*s " $w $h] |
|
} |
|
puts stdout [string trimright $headline] |
|
foreach row $rows { |
|
set line "" |
|
foreach cell [lrange $row 0 4] w $widths { |
|
append line [format "%-*s " $w $cell] |
|
} |
|
append line [lindex $row 5] |
|
puts stdout [string trimright $line] |
|
} |
|
if {[llength $::punkboot::opt_kitnames]} { |
|
#name filtering doubles as per-kit detail (punk-runtime list precedent) |
|
proc ::punkboot::lib::bakelist_file_detail {path} { |
|
if {![file isfile $path]} { |
|
return "(not present)" |
|
} |
|
return "([file size $path] bytes, [clock format [file mtime $path] -format {%Y-%m-%d %H:%M:%S}])" |
|
} |
|
foreach rec $reportset row $rows { |
|
puts stdout "" |
|
puts stdout "detail: [dict get $rec kitname]" |
|
set runtime [dict get $rec runtime] |
|
if {$runtime eq "-"} { |
|
puts stdout " runtime: (none - unwrapped .kit output)" |
|
} else { |
|
puts stdout " runtime file: bin/runtime/[dict get $rec store_tier]/[dict get $rec runtime_file] [expr {[dict get $rec runtime_present] ? {(present)} : {(MISSING)}}]" |
|
} |
|
puts stdout " vfs folder: src/vfs/[dict get $rec vfs] [expr {[dict get $rec vfs_present] ? {(present)} : {(MISSING)}}]" |
|
puts stdout " kit type: [dict get $rec kit_type]" |
|
puts stdout " target: [dict get $rec target][expr {[dict get $rec target] eq $rt_default_target ? " (host default)" : " (declared in the kit mapping)"}]" |
|
if {[dict get $rec entry] ne ""} { |
|
puts stdout " config entry: \[[dict get $rec entry]\]" |
|
} |
|
if {[dict get $rec group] ne ""} { |
|
puts stdout " group: [dict get $rec group][expr {[dict get $rec bake_default] ? "" : " (bake_default=false - bake by name or @[dict get $rec group])"}]" |
|
} elseif {![dict get $rec bake_default]} { |
|
puts stdout " bake_default: false (excluded from full bakes - bake it by name)" |
|
} |
|
set relkit [expr {[dict get $rec out_tier] eq "" ? [dict get $rec targetkit] : "[dict get $rec out_tier]/[dict get $rec targetkit]"}] |
|
puts stdout " bake product: src/_bake/$relkit [punkboot::lib::bakelist_file_detail $bakefolder/$relkit]" |
|
puts stdout " deployed: bin/$relkit [punkboot::lib::bakelist_file_detail $binfolder/$relkit] state=[lindex $row 4]" |
|
} |
|
} |
|
exit 0 |
|
} |
|
|
|
if {$::punkboot::command eq "buildsuite"} { |
|
#G-104: thin front for the buildsuites (zig runtime factory - arm's-length |
|
#subsystem building Tcl runtimes from external sources). Discovery is a |
|
#directory scan; description/info come from each suite's sources.config |
|
#records (description/product/doc/zigpin - the same manifest the suite.tcl |
|
#driver parses), so copied/retargeted trees are first-class with no edits |
|
#here. Contract: src/buildsuites/README.md. |
|
set bs_root [file join $sourcefolder buildsuites] |
|
if {![info exists ::punkboot::bs_args]} {set ::punkboot::bs_args [list]} |
|
set bsargs $::punkboot::bs_args |
|
set bs_action [lindex $bsargs 0] |
|
if {$bs_action eq ""} {set bs_action list} |
|
#tolerant manifest reader (make.tcl side): a suite with a malformed or absent |
|
#sources.config still lists - with the problem as its description - rather |
|
#than breaking discovery of the others. suite.tcl's own parser stays strict. |
|
proc ::punkboot::buildsuite_manifest {suitedir} { |
|
set m [dict create description "" products [list] docs [list] zigpin "" sources [list] note ""] |
|
set cfg [file join $suitedir sources.config] |
|
if {![file exists $cfg]} { |
|
dict set m note "(no sources.config manifest)" |
|
return $m |
|
} |
|
if {[catch { |
|
set f [open $cfg r]; set data [read $f]; close $f |
|
foreach line [split $data \n] { |
|
set line [string trim $line] |
|
if {$line eq "" || [string index $line 0] eq "#"} {continue} |
|
if {[catch {llength $line}]} {continue} |
|
switch -- [lindex $line 0] { |
|
source {dict lappend m sources [lrange $line 1 end]} |
|
description {dict set m description [join [lrange $line 1 end] " "]} |
|
product {dict lappend m products [join [lrange $line 1 end] " "]} |
|
doc {dict lappend m docs [lindex $line 1]} |
|
zigpin {dict set m zigpin [lindex $line 1]} |
|
} |
|
} |
|
} cfgerr]} { |
|
dict set m note "(sources.config unreadable: $cfgerr)" |
|
} |
|
return $m |
|
} |
|
proc ::punkboot::buildsuite_dirs {bs_root} { |
|
set dirs [list] |
|
foreach dir [lsort [glob -nocomplain -dir $bs_root -type d *]] { |
|
if {[file tail $dir] eq "_build"} {continue} |
|
if {![file exists [file join $dir suite.tcl]]} {continue} ;#not a suite (no driver) |
|
lappend dirs $dir |
|
} |
|
return $dirs |
|
} |
|
switch -- $bs_action { |
|
list { |
|
set suitedirs [::punkboot::buildsuite_dirs $bs_root] |
|
if {![llength $suitedirs]} { |
|
puts stdout "no buildsuites found under $bs_root (a suite = a directory carrying a suite.tcl driver)" |
|
exit 0 |
|
} |
|
puts stdout "buildsuites under $bs_root:" |
|
foreach dir $suitedirs { |
|
set m [::punkboot::buildsuite_manifest $dir] |
|
set desc [dict get $m description] |
|
if {$desc eq ""} {set desc [dict get $m note]} |
|
if {$desc eq ""} {set desc "(no description record in sources.config)"} |
|
puts stdout [format " %-16s %s" [file tail $dir] $desc] |
|
} |
|
puts stdout "" |
|
puts stdout " - 'make.tcl buildsuite info <name>' shows a suite's configured detail" |
|
puts stdout " - 'make.tcl buildsuite build <name> ?driver-args ...?' runs its driver" |
|
exit 0 |
|
} |
|
info { |
|
set bs_name [lindex $bsargs 1] |
|
if {$bs_name eq ""} { |
|
puts stderr "usage: make.tcl buildsuite info <suitename> ('make.tcl buildsuite list' shows the names)" |
|
exit 2 |
|
} |
|
set dir [file join $bs_root $bs_name] |
|
if {![file isdirectory $dir] || ![file exists [file join $dir suite.tcl]]} { |
|
puts stderr "buildsuite '$bs_name' not found (no [file join $dir suite.tcl]) - 'make.tcl buildsuite list' shows the suites" |
|
exit 2 |
|
} |
|
set m [::punkboot::buildsuite_manifest $dir] |
|
puts stdout "buildsuite: $bs_name" |
|
puts stdout " path: $dir" |
|
if {[dict get $m note] ne ""} {puts stdout " note: [dict get $m note]"} |
|
if {[dict get $m description] ne ""} {puts stdout " description: [dict get $m description]"} |
|
if {[llength [dict get $m sources]]} { |
|
puts stdout " sources (sources.config - the live dev-flow refs; the 'zig build' flow pins per-checkin via build.zig.zon):" |
|
puts stdout [format " %-10s %-7s %-40s %-16s %s" name kind url ref dir] |
|
foreach s [dict get $m sources] { |
|
lassign $s sname skind surl sref sdir |
|
puts stdout [format " %-10s %-7s %-40s %-16s %s" $sname $skind $surl $sref $sdir] |
|
} |
|
} |
|
set zigpin [dict get $m zigpin] |
|
if {$zigpin ne ""} { |
|
set pinpath [file normalize [file join $projectroot $zigpin]] |
|
set pinstate [expr {[file exists $pinpath] ? "present" : "NOT PRESENT (bin/punk-getzig.cmd can fetch it)"}] |
|
puts stdout " zig pin: $zigpin ($pinstate)" |
|
} else { |
|
puts stdout " zig pin: (no zigpin record in sources.config)" |
|
} |
|
if {[info exists ::env(PUNK_ZIG)]} { |
|
puts stdout " zig via env: PUNK_ZIG=$::env(PUNK_ZIG) (overrides the pin for driver runs)" |
|
} |
|
foreach p [dict get $m products] { |
|
puts stdout " product: $p" |
|
} |
|
foreach d [dict get $m docs] { |
|
puts stdout " doc: [file join $dir $d]" |
|
} |
|
exit 0 |
|
} |
|
build { |
|
set bs_name [lindex $bsargs 1] |
|
if {$bs_name eq ""} { |
|
puts stderr "usage: make.tcl buildsuite build <suitename> ?driver-args ...?" |
|
exit 2 |
|
} |
|
set dir [file join $bs_root $bs_name] |
|
set driver [file join $dir suite.tcl] |
|
if {![file exists $driver]} { |
|
puts stderr "buildsuite '$bs_name' not found (no $driver) - 'make.tcl buildsuite list' shows the suites" |
|
exit 2 |
|
} |
|
set fwdargs [lrange $bsargs 2 end] |
|
#interpreter for the driver: this tclsh - or, punk-exe-hosted (the |
|
#G-058 static-capture marker identifies a kit boot), the kit's |
|
#'script' subcommand so the driver runs with plain script semantics |
|
set launcher [list [info nameofexecutable]] |
|
if {[info exists ::punkboot::static_packages]} { |
|
set launcher [list [info nameofexecutable] script] |
|
} |
|
puts stdout "buildsuite build $bs_name: running '$driver build' with forwarded args: $fwdargs" |
|
flush stdout |
|
#stream driver output; exit with the driver's status |
|
if {[catch {exec {*}$launcher $driver build {*}$fwdargs >@stdout 2>@stderr} execerr execopts]} { |
|
set ecode [dict get $execopts -errorcode] |
|
if {[lindex $ecode 0] eq "CHILDSTATUS"} { |
|
exit [lindex $ecode 2] |
|
} |
|
puts stderr "buildsuite build $bs_name: failed to run the driver: $execerr" |
|
exit 1 |
|
} |
|
exit 0 |
|
} |
|
default { |
|
puts stderr "unknown buildsuite action '$bs_action' - expected list|info|build" |
|
puts stderr "usage: make.tcl buildsuite list|info|build ?<suitename>? ?driver-args ...?" |
|
exit 2 |
|
} |
|
} |
|
} |
|
|
|
if {$::punkboot::command eq "tool"} { |
|
#G-126: vendored first-party build tools under src/tools (zig source vendored in |
|
#full - boundary and editing policy in src/tools/AGENTS.md; per-tree origin, |
|
#re-vendor procedure and licence records in <tool>/PROVENANCE.md). Discovery is |
|
#convention-based: a directory under src/tools carrying build.zig is a tool, its |
|
#name is the directory name, its build artifact is <tooldir>/zig-out/bin/<name> |
|
#and its installed copy is <projectdir>/bin/<name> (host executable suffix). |
|
#zig stays OPTIONAL for punkshell builds: nothing in packages/bake depends on |
|
#this step; explicit build/test without a suitable toolchain exits nonzero with |
|
#fetch guidance. Build caches (.zig-cache/zig-out) are deliberately left in |
|
#place between builds for rebuild speed (both git- and fossil-ignored). |
|
set tool_root [file join $sourcefolder tools] |
|
if {$::punkboot::punkargs_ok} { |
|
#G-143: action/names/-test already parsed through the multi-form definition |
|
#at dispatch (pointed punk::args usage errors for unknown actions/flags). |
|
set tool_action $::punkboot::tool_action |
|
set tool_names $::punkboot::tool_names |
|
set tool_dotest $::punkboot::tool_dotest |
|
} else { |
|
#degraded plain scan: the handler's historic manual tail parse (its unknown |
|
#action / bad -test exit-2 surface is preserved in this mode) |
|
if {![info exists ::punkboot::tool_args]} {set ::punkboot::tool_args [list]} |
|
set targs $::punkboot::tool_args |
|
set tool_action [lindex $targs 0] |
|
if {$tool_action eq ""} {set tool_action list} |
|
#args after the action: tool names plus an optional '-test 0|1' flag (build) |
|
set tool_dotest 1 |
|
set tool_names [list] |
|
set _i 1 |
|
while {$_i < [llength $targs]} { |
|
set a [lindex $targs $_i] |
|
if {$a eq "-test"} { |
|
incr _i |
|
set v [lindex $targs $_i] |
|
if {![string is boolean -strict $v]} { |
|
puts stderr "make.tcl tool: -test requires a boolean value (got '$v')" |
|
exit 2 |
|
} |
|
set tool_dotest [expr {bool($v)}] |
|
} else { |
|
lappend tool_names $a |
|
} |
|
incr _i |
|
} |
|
unset -nocomplain _i a v |
|
} |
|
|
|
proc ::punkboot::tool_dirs {tool_root} { |
|
set dirs [list] |
|
foreach dir [lsort [glob -nocomplain -dir $tool_root -type d *]] { |
|
if {![file exists [file join $dir build.zig]]} {continue} ;#not a tool |
|
lappend dirs $dir |
|
} |
|
return $dirs |
|
} |
|
#tolerant build.zig.zon reader: tool version + declared minimum zig version |
|
proc ::punkboot::tool_zoninfo {tooldir} { |
|
set m [dict create version "" zigfloor ""] |
|
if {![catch { |
|
set f [open [file join $tooldir build.zig.zon] r] |
|
set data [read $f] |
|
close $f |
|
}]} { |
|
if {[regexp {\.version\s*=\s*"([^"]+)"} $data -> _v]} {dict set m version $_v} |
|
if {[regexp {\.minimum_zig_version\s*=\s*"([^"]+)"} $data -> _fl]} {dict set m zigfloor $_fl} |
|
} |
|
return $m |
|
} |
|
#tolerant PROVENANCE.md reader: vendored upstream commit + upstream location |
|
proc ::punkboot::tool_provenance {tooldir} { |
|
set m [dict create commit "" upstream ""] |
|
if {![catch { |
|
set f [open [file join $tooldir PROVENANCE.md] r] |
|
set data [read $f] |
|
close $f |
|
}]} { |
|
if {[regexp {Vendored state: commit\s+`?([0-9a-fA-F]{7,40})} $data -> _c]} {dict set m commit $_c} |
|
if {[regexp {Upstream repository:\s+`?([^`\n]+)} $data -> _u]} {dict set m upstream [string trim $_u]} |
|
} |
|
return $m |
|
} |
|
proc ::punkboot::tool_newest_src_mtime {dir} { |
|
set newest 0 |
|
foreach f [glob -nocomplain -dir $dir -type f *] { |
|
if {[file mtime $f] > $newest} {set newest [file mtime $f]} |
|
} |
|
foreach d [glob -nocomplain -dir $dir -type d *] { |
|
if {[file tail $d] in {zig-out .zig-cache zig-cache}} {continue} |
|
set sub [::punkboot::tool_newest_src_mtime $d] |
|
if {$sub > $newest} {set newest $sub} |
|
} |
|
return $newest |
|
} |
|
proc ::punkboot::tool_zig_version {zigexe} { |
|
if {[catch {exec $zigexe version 2>@1} v]} {return ""} |
|
return [string trim [lindex [split $v \n] 0]] |
|
} |
|
#a dev build's base version must EXCEED the floor (e.g 0.16.0-dev < 0.16.0) |
|
proc ::punkboot::tool_zig_satisfies {ver floor} { |
|
if {$floor eq ""} {return 1} |
|
set base $ver ; set isdev 0 |
|
if {[regexp {^([0-9][0-9.]*)[-+]} $ver -> b]} {set base $b ; set isdev 1} |
|
if {[catch {package vcompare $base $floor} cmp]} {return 0} |
|
if {$cmp > 0} {return 1} |
|
if {$cmp == 0 && !$isdev} {return 1} |
|
return 0 |
|
} |
|
#resolve a zig for the given floor: PUNK_ZIG env override (path to the zig |
|
#executable or its folder), else scan <projectdir>/bin/tools/zig* preferring |
|
#releases over dev builds and the LOWEST satisfying version - a deterministic |
|
#choice that stays stable as newer toolchains get unpacked beside the pinned one |
|
proc ::punkboot::tool_resolve_zig {projectroot floor} { |
|
if {[info exists ::env(PUNK_ZIG)] && $::env(PUNK_ZIG) ne ""} { |
|
set cand $::env(PUNK_ZIG) |
|
if {[file isdirectory $cand]} { |
|
foreach n {zig.exe zig} { |
|
if {[file exists [file join $cand $n]]} {set cand [file join $cand $n] ; break} |
|
} |
|
} |
|
set v [::punkboot::tool_zig_version $cand] |
|
if {$v eq ""} { |
|
return [dict create note "PUNK_ZIG='$::env(PUNK_ZIG)' did not answer 'zig version'"] |
|
} |
|
if {![::punkboot::tool_zig_satisfies $v $floor]} { |
|
return [dict create note "PUNK_ZIG zig is $v which does not satisfy this tool's floor (>= $floor)"] |
|
} |
|
return [dict create zig $cand version $v via PUNK_ZIG] |
|
} |
|
set best "" ; set bestv "" ; set bestbase "" ; set bestdev 1 |
|
foreach dir [lsort [glob -nocomplain -dir [file join $projectroot bin tools] -type d zig*]] { |
|
set p "" |
|
foreach n {zig.exe zig} { |
|
if {[file exists [file join $dir $n]]} {set p [file join $dir $n] ; break} |
|
} |
|
if {$p eq ""} {continue} |
|
set v [::punkboot::tool_zig_version $p] |
|
if {$v eq "" || ![::punkboot::tool_zig_satisfies $v $floor]} {continue} |
|
set base $v ; set isdev 0 |
|
if {[regexp {^([0-9][0-9.]*)[-+]} $v -> b]} {set base $b ; set isdev 1} |
|
set take 0 |
|
if {$best eq ""} { |
|
set take 1 |
|
} elseif {$bestdev && !$isdev} { |
|
set take 1 |
|
} elseif {$bestdev == $isdev && [package vcompare $base $bestbase] < 0} { |
|
set take 1 |
|
} |
|
if {$take} {set best $p ; set bestv $v ; set bestbase $base ; set bestdev $isdev} |
|
} |
|
if {$best eq ""} { |
|
set want [expr {$floor eq "" ? "any version" : ">= $floor"}] |
|
return [dict create note "no suitable zig toolchain ($want) under [file join $projectroot bin tools] - 'bin/punk-getzig.cmd <version>' fetches one; PUNK_ZIG=<path-to-zig> overrides"] |
|
} |
|
return [dict create zig $best version $bestv via scan] |
|
} |
|
proc ::punkboot::tool_installed_exe {projectroot name} { |
|
set suffix [punkboot::lib::platform_exe_suffix $::punkboot::target_platform] |
|
return [file join $projectroot bin ${name}$suffix] |
|
} |
|
proc ::punkboot::tool_install_state {projectroot tooldir} { |
|
set exe [::punkboot::tool_installed_exe $projectroot [file tail $tooldir]] |
|
if {![file exists $exe]} {return absent} |
|
if {[file mtime $exe] >= [::punkboot::tool_newest_src_mtime $tooldir]} {return current} |
|
return stale |
|
} |
|
#run 'zig <argl>' with cwd at the tool tree (the tree's CLI tests resolve |
|
#fixtures and zig-out relative to the build root). The gate is the EXIT CODE: |
|
#stderr legitimately carries expected warnings (punkzip's zip suite negative |
|
#tests print EOCD warnings while passing). Returns the child's exit status. |
|
proc ::punkboot::tool_zig_run {zig tooldir argl} { |
|
set saved [pwd] |
|
cd $tooldir |
|
set rc 0 |
|
if {[catch {exec $zig {*}$argl >@stdout 2>@stderr} _e _o]} { |
|
set ecode [dict get $_o -errorcode] |
|
if {[lindex $ecode 0] eq "CHILDSTATUS"} { |
|
set rc [lindex $ecode 2] |
|
} else { |
|
puts stderr "tool: failed to run '$zig $argl' in $tooldir: $_e" |
|
set rc 1 |
|
} |
|
} |
|
cd $saved |
|
return $rc |
|
} |
|
|
|
set alldirs [::punkboot::tool_dirs $tool_root] |
|
set byname [dict create] |
|
foreach d $alldirs {dict set byname [file tail $d] $d} |
|
if {[llength $tool_names]} { |
|
set selected [list] |
|
foreach n $tool_names { |
|
if {![dict exists $byname $n]} { |
|
if {[string match -* $n]} { |
|
puts stderr "tool: '$n' looks like a flag - options precede the tool names (e.g 'make.tcl tool build -test 0 <name> ...')" |
|
} |
|
puts stderr "tool '$n' not found under $tool_root - configured tools: [dict keys $byname]" |
|
exit 2 |
|
} |
|
lappend selected [dict get $byname $n] |
|
} |
|
} else { |
|
set selected $alldirs |
|
} |
|
if {![llength $alldirs] && $tool_action ne "list"} { |
|
puts stderr "no vendored tools found under $tool_root (a tool = a directory carrying build.zig)" |
|
exit 2 |
|
} |
|
|
|
switch -- $tool_action { |
|
list { |
|
if {![llength $alldirs]} { |
|
puts stdout "no vendored tools found under $tool_root (a tool = a directory carrying build.zig)" |
|
exit 0 |
|
} |
|
puts stdout "vendored tools under $tool_root (boundary: src/tools/AGENTS.md; per-tree PROVENANCE.md):" |
|
puts stdout [format " %-10s %-9s %-10s %-8s %s" name version zig-floor bin vendored-commit] |
|
set maxfloor "" |
|
foreach dir $alldirs { |
|
set name [file tail $dir] |
|
set zon [::punkboot::tool_zoninfo $dir] |
|
set prov [::punkboot::tool_provenance $dir] |
|
set floor [dict get $zon zigfloor] |
|
if {$floor ne "" && ($maxfloor eq "" || [package vcompare $floor $maxfloor] > 0)} { |
|
set maxfloor $floor |
|
} |
|
set commit [dict get $prov commit] |
|
set commit [expr {$commit eq "" ? "-" : [string range $commit 0 11]}] |
|
set floorshow [expr {$floor eq "" ? "-" : ">=$floor"}] |
|
puts stdout [format " %-10s %-9s %-10s %-8s %s" $name [dict get $zon version] $floorshow [::punkboot::tool_install_state $projectroot $dir] $commit] |
|
} |
|
set zres [::punkboot::tool_resolve_zig $projectroot $maxfloor] |
|
if {[dict exists $zres zig]} { |
|
puts stdout "toolchain: zig [dict get $zres version] via [dict get $zres via] ([dict get $zres zig])" |
|
} else { |
|
puts stdout "toolchain: [dict get $zres note]" |
|
} |
|
puts stdout "" |
|
puts stdout " - 'make.tcl tool info <name>' shows a tool's detail" |
|
puts stdout " - 'make.tcl tool build ?-test 0|1? ?<name> ...?' builds (test-gated) and installs to bin/" |
|
puts stdout " - zig is OPTIONAL for punkshell builds: packages/bake never require this step" |
|
exit 0 |
|
} |
|
info { |
|
if {![llength $tool_names]} { |
|
puts stderr "usage: make.tcl tool info <toolname> ('make.tcl tool list' shows the names)" |
|
exit 2 |
|
} |
|
foreach dir $selected { |
|
set name [file tail $dir] |
|
set zon [::punkboot::tool_zoninfo $dir] |
|
set prov [::punkboot::tool_provenance $dir] |
|
set floor [dict get $zon zigfloor] |
|
puts stdout "tool: $name" |
|
puts stdout " path: $dir" |
|
puts stdout " version: [dict get $zon version] (build.zig.zon)" |
|
puts stdout " zig floor: [expr {$floor eq "" ? "(none declared)" : ">= $floor"}]" |
|
puts stdout " upstream: [expr {[dict get $prov upstream] eq "" ? "(no PROVENANCE.md record)" : [dict get $prov upstream]}]" |
|
puts stdout " vendored commit: [expr {[dict get $prov commit] eq "" ? "(no PROVENANCE.md record)" : [dict get $prov commit]}]" |
|
puts stdout " provenance: [file join $dir PROVENANCE.md]" |
|
set exe [::punkboot::tool_installed_exe $projectroot $name] |
|
puts stdout " installed: $exe ([::punkboot::tool_install_state $projectroot $dir])" |
|
set zres [::punkboot::tool_resolve_zig $projectroot $floor] |
|
if {[dict exists $zres zig]} { |
|
puts stdout " toolchain: zig [dict get $zres version] via [dict get $zres via] ([dict get $zres zig])" |
|
} else { |
|
puts stdout " toolchain: [dict get $zres note]" |
|
} |
|
} |
|
exit 0 |
|
} |
|
build { |
|
foreach dir $selected { |
|
set name [file tail $dir] |
|
set floor [dict get [::punkboot::tool_zoninfo $dir] zigfloor] |
|
set zres [::punkboot::tool_resolve_zig $projectroot $floor] |
|
if {![dict exists $zres zig]} { |
|
puts stderr "tool build $name: [dict get $zres note]" |
|
exit 1 |
|
} |
|
set zig [dict get $zres zig] |
|
puts stdout "tool build $name: zig [dict get $zres version] via [dict get $zres via] ($zig)" |
|
flush stdout |
|
if {$tool_dotest} { |
|
puts stdout "tool build $name: test gate ('zig build test') ..." |
|
flush stdout |
|
set rc [::punkboot::tool_zig_run $zig $dir [list build test]] |
|
if {$rc != 0} { |
|
puts stderr "tool build $name: test gate FAILED (exit $rc) - nothing installed" |
|
exit 1 |
|
} |
|
puts stdout "tool build $name: test gate passed" |
|
} else { |
|
puts stdout "tool build $name: test gate SKIPPED (-test 0)" |
|
} |
|
puts stdout "tool build $name: building (ReleaseSafe) ..." |
|
flush stdout |
|
set rc [::punkboot::tool_zig_run $zig $dir [list build -Doptimize=ReleaseSafe]] |
|
if {$rc != 0} { |
|
puts stderr "tool build $name: build FAILED (exit $rc) - nothing installed" |
|
exit 1 |
|
} |
|
set suffix [punkboot::lib::platform_exe_suffix $::punkboot::target_platform] |
|
set built [file join $dir zig-out bin ${name}$suffix] |
|
if {![file exists $built]} { |
|
puts stderr "tool build $name: build reported success but $built is missing" |
|
exit 1 |
|
} |
|
set exe [::punkboot::tool_installed_exe $projectroot $name] |
|
if {[catch {file copy -force $built $exe} cperr]} { |
|
puts stderr "tool build $name: could not install $exe ($cperr) - is a copy currently running?" |
|
exit 1 |
|
} |
|
#stamp install time: file copy preserves the source mtime, and a zig |
|
#cache-hit rebuild leaves the zig-out artifact at its original link |
|
#time - without this, tool_install_state compares that old link time |
|
#against the tree and a doc-only edit keeps the tool 'stale' forever. |
|
file mtime $exe [clock seconds] |
|
puts stdout "tool build $name: installed $exe ([file size $exe] bytes)" |
|
} |
|
exit 0 |
|
} |
|
test { |
|
foreach dir $selected { |
|
set name [file tail $dir] |
|
set floor [dict get [::punkboot::tool_zoninfo $dir] zigfloor] |
|
set zres [::punkboot::tool_resolve_zig $projectroot $floor] |
|
if {![dict exists $zres zig]} { |
|
puts stderr "tool test $name: [dict get $zres note]" |
|
exit 1 |
|
} |
|
set zig [dict get $zres zig] |
|
puts stdout "tool test $name: zig [dict get $zres version] via [dict get $zres via] - running 'zig build test' ..." |
|
flush stdout |
|
set rc [::punkboot::tool_zig_run $zig $dir [list build test]] |
|
if {$rc != 0} { |
|
puts stderr "tool test $name: FAILED (exit $rc)" |
|
exit 1 |
|
} |
|
puts stdout "tool test $name: passed" |
|
} |
|
exit 0 |
|
} |
|
default { |
|
puts stderr "unknown tool action '$tool_action' - expected list|info|build|test" |
|
puts stderr "usage: make.tcl tool list|info|build|test ?-test 0|1? ?<toolname> ...?" |
|
exit 2 |
|
} |
|
} |
|
} |
|
|
|
if {$::punkboot::command eq "shell"} { |
|
#G-113: the ansistrip transform serves make.tcl's own output only - the repl's |
|
#colour behaviour is the shell's own concern (colour on/off + NO_COLOR there). |
|
#Pop exactly the channels the policy block wrapped (per-channel list). |
|
if {[info exists ::punkboot::ansistrip_pushed]} { |
|
foreach _ch $::punkboot::ansistrip_pushed { |
|
catch {chan pop $_ch} |
|
} |
|
set ::punkboot::ansistrip_pushed [list] |
|
} |
|
package require struct::list |
|
package require punk |
|
package require punk::repl |
|
#todo - make procs vars etc from this file available? |
|
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell." |
|
|
|
set ::argv [lrange $::argv 1 end] |
|
incr ::argc -1 |
|
|
|
#When make.tcl runs under a built punk executable, app-punkscript set |
|
#::tcl_interactive 0 (correct for script execution) and punk::repl was already loaded |
|
#at kit boot - the package require above re-loads nothing, so the repl's load-time |
|
#interactivity probe never re-ran and prompts would stay suppressed on a real console. |
|
#Recompute against the actual input channel now that a shell has been explicitly asked for. |
|
set ::tcl_interactive [punk::repl::is_interactive stdin] |
|
|
|
repl::init |
|
set replresult [repl::start stdin -title make.tcl] |
|
#review |
|
if {[string is integer -strict $replresult]} { |
|
exit $replresult |
|
} else { |
|
puts stdout $replresult |
|
exit 0 |
|
} |
|
} |
|
|
|
if {$::punkboot::command eq "vfscommonupdate"} { |
|
puts "projectroot: $projectroot" |
|
puts "script: [info script]" |
|
puts stdout "Updating vfs/_vfscommon.vfs" |
|
|
|
#G-030 prompt policy: -confirm 0 proceeds without prompting; with the default -confirm 1 |
|
#a non-interactive stdin aborts fast with guidance instead of reading stdin. |
|
set _proceed 0 |
|
if {!$::punkboot::opt_confirm} { |
|
puts stdout "REPLACE src/vfs/_vfscommon.vfs/* with project's modules and libs (-confirm 0 supplied - proceeding without prompting)" |
|
set _proceed 1 |
|
} elseif {![::punkboot::lib::stdin_is_interactive]} { |
|
puts stderr "-aborted- (vfscommonupdate REPLACE confirmation required but stdin is not interactive)" |
|
puts stderr " Rerun with -confirm 0 to proceed without prompting (see 'make.tcl vfscommonupdate -help')." |
|
exit 1 |
|
} else { |
|
puts stdout "REPLACE src/vfs/_vfscommon.vfs/* with project's modules and libs?? y|n" |
|
if {[string tolower [string trim [gets stdin]]] eq "y"} { |
|
set _proceed 1 |
|
} |
|
} |
|
if {!$_proceed} { |
|
puts stderr "-aborted- by user (vfscommonupdate: no changes made)" |
|
exit 1 |
|
} |
|
puts proceeding... |
|
|
|
proc vfscommonupdate {projectroot} { |
|
file delete -force $projectroot/src/vfs/_vfscommon.vfs/modules |
|
file copy $projectroot/modules $projectroot/src/vfs/_vfscommon.vfs/ |
|
#temp? (avoid zipfs mkimg windows dotfile bug) |
|
file delete $projectroot/src/vfs/_vfscommon.vfs/modules/.punkcheck |
|
|
|
file delete -force $projectroot/src/vfs/_vfscommon.vfs/lib |
|
file copy $projectroot/lib $projectroot/src/vfs/_vfscommon.vfs/ |
|
#temp? |
|
file delete $projectroot/src/vfs/_vfscommon.vfs/lib/.punkcheck |
|
|
|
#G-031 boot-core delivery: the layout-owned kit boot core rides the |
|
#_vfscommon merge as <vfsroot>/punkboot/core.tcl, regenerated here from |
|
#the _config master so every kit's thin main.tcl finds it in-kit. |
|
file delete -force $projectroot/src/vfs/_vfscommon.vfs/punkboot |
|
if {[file isfile $projectroot/src/vfs/_config/punkboot_core.tcl]} { |
|
file mkdir $projectroot/src/vfs/_vfscommon.vfs/punkboot |
|
file copy $projectroot/src/vfs/_config/punkboot_core.tcl $projectroot/src/vfs/_vfscommon.vfs/punkboot/core.tcl |
|
} else { |
|
puts stderr "vfscommonupdate: WARNING - no src/vfs/_config/punkboot_core.tcl master - kits will carry no punkboot/core.tcl and thin mains cannot boot" |
|
} |
|
} |
|
vfscommonupdate $projectroot |
|
|
|
puts stdout "\nvfscommonupdate done " |
|
flush stderr |
|
flush stdout |
|
::exit 0 |
|
} |
|
|
|
if {$::punkboot::command eq "vendorupdate"} { |
|
puts "projectroot: $projectroot" |
|
puts "script: [info script]" |
|
#puts "-- [tcl::tm::list] --" |
|
puts stdout "Updating vendor modules in src folder" |
|
|
|
#dirty-checkout provenance warnings via punkboot::utils::vcs_dirty_warnings (loaded from bootsupport). |
|
#Guarded require: vendorupdate must keep working even if the bootsupport punkboot::utils copy is |
|
#missing or stale (it may be the very thing being repaired) - the check degrades to skipped. |
|
set have_vcs_dirty_check [expr {![catch {package require punkboot::utils}] && [llength [info commands ::punkboot::utils::vcs_dirty_warnings]]}] |
|
if {!$have_vcs_dirty_check} { |
|
puts stderr "WARNING: vendorupdate dirty-checkout provenance check unavailable (punkboot::utils vcs_dirty_warnings not loadable from bootsupport) - continuing without it" |
|
} |
|
|
|
proc vendor_localupdate {projectroot} { |
|
set local_modules [list] |
|
set git_modules [list] |
|
set fossil_modules [list] |
|
set checked_source_paths [dict create] ;#skip repeat walk-ups for identical source paths |
|
set checked_vcs_roots [dict create] ;#report each VCS root at most once per run |
|
set sourcefolder $projectroot/src |
|
#todo vendor/lib |
|
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] |
|
#todo platform folders under vendor/lib_tcl<v> |
|
|
|
|
|
#todo platform folders under vendor/module_tcl<v> |
|
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] |
|
#lappend vendormodulefolders vendormodules |
|
foreach vf $vendormodulefolders { |
|
lassign [split $vf _] _vm tclx |
|
if {$tclx ne ""} { |
|
set which _$tclx |
|
} else { |
|
set which "" |
|
} |
|
|
|
set vendor_config $sourcefolder/vendormodules$which/include_modules.config ;#todo - change to toml |
|
if {[file exists $vendor_config]} { |
|
set targetroot $sourcefolder/vendormodules$which |
|
set local_modules [list] |
|
source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list |
|
if {![llength $local_modules]} { |
|
puts stderr "\nsrc/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)" |
|
} else { |
|
if {[catch { |
|
#---------- |
|
set vendor_installer [punkcheck::installtrack new make.tcl $sourcefolder/vendormodules$which/.punkcheck] |
|
$vendor_installer set_source_target $projectroot $sourcefolder/vendormodules$which |
|
set installation_event [$vendor_installer start_event {-make_step vendorupdate}] |
|
#---------- |
|
} errM]} { |
|
puts stderr "Unable to use punkcheck for vendormodules$which update. Error: $errM" |
|
set installation_event "" |
|
} |
|
#todo - sync alg with bootsupport_localupdate! |
|
foreach {localpath requested_module} $local_modules { |
|
set requested_module [string trim $requested_module :] |
|
set module_subpath [string map {:: /} [namespace qualifiers $requested_module]] |
|
if {[file pathtype $localpath] eq "relative"} { |
|
#This would actually work for absolute paths too as file join c:/test c:/etc ignores first arg and returns c:/etc |
|
set srclocation [file join $projectroot $localpath $module_subpath] |
|
} else { |
|
set srclocation [file join $localpath $module_subpath] |
|
} |
|
#dirty-checkout provenance check - each VCS root reported at most once per run |
|
if {$::have_vcs_dirty_check} { |
|
set normsrclocation [file normalize $srclocation] |
|
if {![dict exists $checked_source_paths $normsrclocation]} { |
|
dict set checked_source_paths $normsrclocation 1 |
|
::punkboot::print_provenance_warnings [::punkboot::utils::vcs_dirty_warnings $normsrclocation checked_vcs_roots vendorupdate] |
|
} |
|
} |
|
#puts stdout "$relpath $module $module_subpath $srclocation" |
|
|
|
#todo - check if requested_module has version extension and allow explicit versions instead of just latest |
|
#allow modulename-* literal in .config to request all versions |
|
|
|
set pkgmatches [glob -nocomplain -dir $srclocation -tail -- [namespace tail $requested_module]-*] |
|
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 |
|
if {![llength $pkgmatches]} { |
|
puts stderr "Missing local source for requested vendor module $requested_module - not found in $srclocation" |
|
continue |
|
} |
|
set latestfile [lindex $pkgmatches 0] ;#default |
|
set latestver [lindex [split [file rootname $latestfile] -] 1] |
|
foreach m $pkgmatches { |
|
lassign [split [file rootname $m] -] _pkg ver |
|
#puts "comparing $ver vs $latestver" |
|
if {[package vcompare $ver $latestver] == 1} { |
|
set latestver $ver |
|
set latestfile $m |
|
} |
|
} |
|
|
|
set srcfile [file join $srclocation $latestfile] |
|
set tgtfile [file join $targetroot $module_subpath $latestfile] |
|
if {$installation_event ne ""} { |
|
#---------- |
|
$installation_event targetset_init INSTALL $tgtfile |
|
$installation_event targetset_addsource $srcfile |
|
#---------- |
|
if {\ |
|
[llength [dict get [$installation_event targetset_source_changes] changed]]\ |
|
|| [llength [$installation_event get_targets_exist]] < [llength [$installation_event get_targets]]\ |
|
} { |
|
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists |
|
$installation_event targetset_started |
|
# -- --- --- --- --- --- |
|
puts "VENDORMODULES$which update: $srcfile -> $tgtfile" |
|
if {[catch { |
|
file copy -force $srcfile $tgtfile |
|
} errM]} { |
|
$installation_event targetset_end FAILED |
|
} else { |
|
$installation_event targetset_end OK |
|
} |
|
# -- --- --- --- --- --- |
|
} else { |
|
puts -nonewline stderr "." |
|
$installation_event targetset_end SKIPPED |
|
} |
|
$installation_event end |
|
} else { |
|
file copy -force $srcfile $tgtfile |
|
} |
|
} |
|
|
|
} |
|
} else { |
|
puts stderr "No config at $vendor_config - nothing configured to update" |
|
} |
|
} |
|
} |
|
|
|
vendor_localupdate $projectroot |
|
|
|
puts stdout " vendor package update done " |
|
flush stderr |
|
flush stdout |
|
::exit 0 |
|
} |
|
|
|
if {$::punkboot::command eq "bootsupport"} { |
|
puts "projectroot: $projectroot" |
|
puts "script: [info script]" |
|
#puts "-- [tcl::tm::list] --" |
|
puts stdout "Updating bootsupport from local files" |
|
|
|
proc modfile_sort {p1 p2} { |
|
lassign [split [file rootname $p1] -] _ v1 |
|
lassign [split [file rootname $p2] -] _ v2 |
|
package vcompare $v1 $v2 |
|
} |
|
proc bootsupport_localupdate {projectroot} { |
|
set sourcefolder $projectroot/src |
|
|
|
set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules modules_tcl*] |
|
foreach bm $bootmodulefolders { |
|
lassign [split $bm _] _bm tclx |
|
if {$tclx ne ""} { |
|
set which _$tclx |
|
} else { |
|
set which "" |
|
} |
|
set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# |
|
set bootsupport_modules [list] ;#variable populated by include_modules.config file - initialise empty for each bm folder |
|
set bootsupport_folders [list] |
|
if {[file exists $bootsupport_config]} { |
|
set targetroot $projectroot/src/bootsupport/modules$which |
|
source $bootsupport_config ;#populate $bootsupport_modules with project-specific list |
|
|
|
if {![llength $bootsupport_modules]} { |
|
puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" |
|
} else { |
|
|
|
if {[catch { |
|
#---------- |
|
set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] |
|
$boot_installer set_source_target $projectroot $projectroot/src/bootsupport |
|
set boot_event [$boot_installer start_event {-make_step bootsupport}] |
|
#---------- |
|
} errM]} { |
|
puts stderr "Unable to use punkcheck for bootsupport error: $errM" |
|
set boot_event "" |
|
} |
|
|
|
foreach {relpath modulematch} $bootsupport_modules { |
|
set modulematch [string trim $modulematch :] |
|
set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]] |
|
set srclocation [file join $projectroot $relpath $module_subpath] |
|
#puts stdout "$relpath $modulematch $module_subpath $srclocation" |
|
#we must always glob using the dash - or we will match libraries that are suffixes of others |
|
#bare lib.tm with no version is not valid. |
|
if {[string first - $modulematch] != -1} { |
|
#version or part thereof is specified. |
|
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f -- [namespace tail $modulematch]*.tm] |
|
} else { |
|
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f -- [namespace tail $modulematch]-*.tm] |
|
} |
|
if {![llength $pkgmatches]} { |
|
puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation" |
|
continue |
|
} |
|
|
|
set modulematch_is_glob [regexp {[*?\[\]]} $modulematch] |
|
if {!$modulematch_is_glob} { |
|
#if modulematch was specified without globs - only copy latest |
|
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func |
|
set pkgmatches [lsort -command modfile_sort $pkgmatches] |
|
set latestfile [lindex $pkgmatches end] |
|
#set latestver [lindex [split [file rootname $latestfile] -] 1] |
|
set copy_files $latestfile |
|
} else { |
|
#globs in modulematch - may be different packages matched by glob - copy all versions of matches |
|
#review |
|
set copy_files $pkgmatches |
|
} |
|
#if a file added manually to target dir - there will be no .punkcheck record - will be detected as changed |
|
foreach cfile $copy_files { |
|
set srcfile [file join $srclocation $cfile] |
|
set tgtfile [file join $targetroot $module_subpath $cfile] |
|
if {$boot_event ne ""} { |
|
#---------- |
|
$boot_event targetset_init INSTALL $tgtfile |
|
$boot_event targetset_addsource $srcfile |
|
catch { |
|
#virtual module identity/version sources so records identify the product |
|
#(guarded - older punkcheck snapshots lack targetset_addsource_virtual) |
|
lassign [punk::mix::util::split_modulename_version [file tail $cfile]] bs_module_name bs_module_version |
|
if {$bs_module_version ne ""} { |
|
$boot_event targetset_addsource_virtual module_name $bs_module_name |
|
$boot_event targetset_addsource_virtual module_version $bs_module_version |
|
} |
|
} |
|
#---------- |
|
# |
|
#puts "bootsuport target $tgtfile record size: [dict size [$boot_event targetset_last_complete]]" |
|
if {\ |
|
[llength [dict get [$boot_event targetset_source_changes] changed]]\ |
|
|| [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ |
|
} { |
|
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists |
|
$boot_event targetset_started |
|
# -- --- --- --- --- --- |
|
puts "\nBOOTSUPPORT module$which update: $srcfile -> $tgtfile" |
|
#An in-place overwrite is refused when the target is memory-mapped - |
|
#which is what a mounted zip-based .tm modpod (e.g punk::mix::templates) |
|
#is. replace_possibly_mapped_file falls back to delete-then-place, which |
|
#windows does allow. See its comment for why the error reads "invalid |
|
#argument" and why unlinking is safe for the process holding the mapping. |
|
switch -- [::punkboot::replace_possibly_mapped_file $srcfile $tgtfile errM] { |
|
ok { |
|
$boot_event targetset_end OK |
|
} |
|
replaced { |
|
puts stdout " (in-place overwrite refused - replaced by delete-then-place; target was memory-mapped, e.g a mounted modpod)" |
|
$boot_event targetset_end OK -note "overwrite refused ($errM) - replaced via delete-then-place (target memory-mapped)" |
|
} |
|
broken { |
|
puts stderr "BOOTSUPPORT module$which update FAILED: $tgtfile was unlinked and could not be replaced - restore it from $srcfile by hand ($errM)" |
|
$boot_event targetset_end FAILED |
|
} |
|
default { |
|
#target untouched. If its content is already identical, record OK so a |
|
#prior failed record converges instead of churning FAILED forever. |
|
set already_current 0 |
|
if {[file exists $tgtfile] && [file size $tgtfile] == [file size $srcfile]} { |
|
catch { |
|
set src_ck [dict get [punk::mix::base::lib::cksum_path $srcfile] cksum] |
|
set tgt_ck [dict get [punk::mix::base::lib::cksum_path $tgtfile] cksum] |
|
if {$src_ck ne "" && $src_ck eq $tgt_ck} { |
|
set already_current 1 |
|
} |
|
} |
|
} |
|
if {$already_current} { |
|
$boot_event targetset_end OK -note "copy failed ($errM) but target content already identical" |
|
} else { |
|
puts stderr "BOOTSUPPORT module$which update FAILED: $tgtfile ($errM)" |
|
set _hint [::punkboot::mapped_file_hint $errM $tgtfile] |
|
if {$_hint ne ""} { |
|
puts stderr " $_hint" |
|
} |
|
$boot_event targetset_end FAILED |
|
} |
|
} |
|
} |
|
# -- --- --- --- --- --- |
|
} else { |
|
puts -nonewline stderr "." |
|
$boot_event targetset_end SKIPPED |
|
} |
|
$boot_event end |
|
} else { |
|
file copy -force $srcfile $tgtfile |
|
} |
|
} |
|
if {!$modulematch_is_glob && $boot_event ne ""} { |
|
#non-glob config entry means only the latest version is tracked |
|
# - prune superseded punkcheck-recorded older versions from the bootsupport folder |
|
if {![catch {package require punk::mix::cli}] |
|
&& ![catch {package require punk::mix::util}] |
|
&& [llength [info commands ::punk::mix::cli::lib::prune_superseded_target_modules]] |
|
} { |
|
lassign [punk::mix::util::split_modulename_version [file tail $latestfile]] mod_basename mod_version |
|
if {$mod_version ne ""} { |
|
::punk::mix::cli::lib::prune_superseded_target_modules $boot_event $projectroot/src/bootsupport [file join $targetroot $module_subpath] $mod_basename $mod_version |
|
} |
|
} else { |
|
if {![info exists ::punkboot::warned_prune_helper_unavailable]} { |
|
set ::punkboot::warned_prune_helper_unavailable 1 |
|
puts stderr "bootsupport: prune helper punk::mix::cli::lib::prune_superseded_target_modules unavailable (older punk::mix::cli snapshot) - skipping prune of superseded bootsupport modules. Rerun 'make.tcl bootsupport' after rebuilding modules and bootsupport." |
|
} |
|
} |
|
} |
|
} |
|
if {$boot_event ne ""} { |
|
puts \n |
|
$boot_event destroy |
|
$boot_installer destroy |
|
} |
|
} |
|
if {![llength $bootsupport_folders]} { |
|
puts stderr "bootsupport/modules$which - No local bootsupport folders configured for updating" |
|
} else { |
|
|
|
} |
|
|
|
} |
|
} |
|
} |
|
|
|
bootsupport_localupdate $projectroot |
|
|
|
#G-087 stage 3: the former custom/_project layout bootsupport sync is retired. |
|
#Project layouts store no bootsupport module snapshots - 'dev project.new' injects bootsupport |
|
#into generated projects from the generating shell at generation time. Layout-carried scripts |
|
#and bootsupport manifests are kept current by the thin-layout sync step (see DIAGRAM 1b in |
|
#::punkboot::workflow_text), which runs during modules/libs/packages/bakehouse runs. |
|
|
|
puts stdout " bootsupport done " |
|
flush stderr |
|
flush stdout |
|
#punk86 can hang if calling make.tcl via 'run' without this 'after' delay. punk87 unaffected. cause unknown. |
|
#after 500 |
|
::exit 0 |
|
} |
|
|
|
|
|
|
|
if {$::punkboot::command eq "libfetch"} { |
|
#G-139 phase 1: fetch the punkbin LIB-TIER artifacts declared in |
|
#src/runtime/libpackages.toml into the untracked bin/packages/<target> input |
|
#tier (mirroring bin/runtime/<target>) with sha1 verification against the |
|
#server's per-target sha1sums.txt, then materialize each verified zip's |
|
#installed-shape package tree under bin/packages/<target>/tcl<N>/ (the tree |
|
#is self-describing via its embedded punkbin-artifact.toml - the G-138 |
|
#record). Consumption into lib_tcl<N>/ and kit vfs trees is the remainder |
|
#of G-139 - this entrypoint owns fetch + verify + materialize only. |
|
|
|
proc ::punkboot::libfetch_transfer {url outfile} { |
|
#one url -> local file. file:// is served natively (local mirrors, |
|
#fixtures - no network, no external tools). http(s) transports in |
|
#order: Tcl http (+tls for https) when loadable, curl (ubiquitous, |
|
#including stock windows 10+), powershell Invoke-WebRequest (windows). |
|
#Returns the transport used; errors when all fail. |
|
file mkdir [file dirname $outfile] |
|
if {[string match -nocase "file://*" $url]} { |
|
set path [string range $url 7 end] |
|
if {[regexp {^/+([A-Za-z]:/.*)$} $path -> winpath]} { |
|
set path $winpath ;#file:///C:/x -> C:/x |
|
} |
|
if {![file isfile $path]} { |
|
error "file origin has no such file: $path" |
|
} |
|
file copy -force $path $outfile |
|
return "file-copy" |
|
} |
|
set is_https [string match -nocase "https://*" $url] |
|
set tcl_http_ok 0 |
|
if {![catch {package require http}]} { |
|
if {!$is_https} { |
|
set tcl_http_ok 1 |
|
} elseif {![catch {package require tls}]} { |
|
catch {http::register https 443 [list ::tls::socket -autoservername true]} |
|
set tcl_http_ok 1 |
|
} |
|
} |
|
if {$tcl_http_ok} { |
|
set fd [open $outfile wb] |
|
set ok 0 |
|
if {![catch {http::geturl $url -channel $fd -binary 1} tok]} { |
|
if {[http::status $tok] eq "ok" && [http::ncode $tok] == 200} {set ok 1} |
|
http::cleanup $tok |
|
} |
|
close $fd |
|
if {$ok} {return "tcl-http"} |
|
file delete -force $outfile |
|
} |
|
set curl [auto_execok curl] |
|
if {$curl ne ""} { |
|
if {![catch {exec {*}$curl --fail -sSL -o $outfile $url 2>@1} curlerr]} { |
|
return "curl" |
|
} |
|
file delete -force $outfile |
|
} |
|
if {$::tcl_platform(platform) eq "windows"} { |
|
set ps [auto_execok powershell] |
|
if {$ps ne ""} { |
|
set pscmd "\$ProgressPreference='SilentlyContinue'; Invoke-WebRequest -Uri '$url' -OutFile '$outfile' -ErrorAction Stop" |
|
if {![catch {exec {*}$ps -NoProfile -NonInteractive -Command $pscmd 2>@1} pserr]} { |
|
return "powershell" |
|
} |
|
file delete -force $outfile |
|
} |
|
} |
|
set detail "" |
|
if {[info exists curlerr]} {set detail " (curl: [string range $curlerr 0 200])"} |
|
error "all transports failed for $url$detail" |
|
} |
|
|
|
set libfetch_config $sourcefolder/runtime/libpackages.toml |
|
set libfetch_packagesroot $projectroot/bin/packages |
|
#Isolation seams (env-only, the PUNK_RUNTIME_PLATFORM idiom): an alternate |
|
#declarations file and an alternate tier root, so fixture-driven runs (the |
|
#shell/testsuites/punkexe/maketcllibfetch.test characterization suite, |
|
#local-mirror experiments) never read the real declarations or write the |
|
#real bin/packages tier. The server-trust gate below is deliberately NOT |
|
#seam-bypassable - fixtures consent with -trust-server like any other |
|
#non-canonical origin. |
|
if {[info exists ::env(PUNK_LIBFETCH_CONFIG)] && $::env(PUNK_LIBFETCH_CONFIG) ne ""} { |
|
set libfetch_config [file normalize $::env(PUNK_LIBFETCH_CONFIG)] |
|
} |
|
if {[info exists ::env(PUNK_LIBFETCH_PACKAGES)] && $::env(PUNK_LIBFETCH_PACKAGES) ne ""} { |
|
set libfetch_packagesroot [file normalize $::env(PUNK_LIBFETCH_PACKAGES)] |
|
} |
|
#Canonical origin: the punkbin raw-file base (the punk-runtime.cmd |
|
#convention; lib tier addressed as <origin>/lib/<target>/...). |
|
#Server-trust consent (G-139, the G-123 posture): the canonical origin |
|
#never gates; ANY other origin - flag or PUNKBIN_URL env - requires the |
|
#explicit -trust-server flag. Never an interactive prompt: unattended |
|
#runs stay unattended, and refusal happens before any network access. |
|
set libfetch_canonical "https://www.gitea1.intx.com.au/jn/punkbin/raw/branch/master" |
|
set libfetch_origin $libfetch_canonical |
|
if {[info exists ::env(PUNKBIN_URL)] && $::env(PUNKBIN_URL) ne ""} { |
|
set libfetch_origin $::env(PUNKBIN_URL) |
|
} |
|
if {$::punkboot::opt_serverurl ne ""} { |
|
set libfetch_origin $::punkboot::opt_serverurl |
|
} |
|
set libfetch_origin [string trimright $libfetch_origin /] |
|
if {$libfetch_origin ne $libfetch_canonical && !$::punkboot::opt_trust_server} { |
|
puts stderr "$A(BAD)LIBFETCH: origin '$libfetch_origin' is not the canonical punkbin origin$A(RST)" |
|
puts stderr "LIBFETCH: canonical: $libfetch_canonical" |
|
puts stderr "LIBFETCH: fetching from a non-canonical server requires the explicit -trust-server flag (consent keyed to server trust - G-139/G-123). Nothing was fetched." |
|
exit 3 |
|
} |
|
if {![file exists $libfetch_config]} { |
|
puts stdout "LIBFETCH: no config at $libfetch_config - nothing declared, nothing to fetch" |
|
} else { |
|
if {[catch {package require tomlish} tomlish_err]} { |
|
puts stderr "$A(BAD)LIBFETCH: cannot process $libfetch_config - tomlish package unavailable ($tomlish_err)$A(RST)" |
|
exit 3 |
|
} |
|
if {[catch {package require sha1} sha1_err]} { |
|
puts stderr "$A(BAD)LIBFETCH: sha1 package unavailable ($sha1_err) - cannot verify artifacts$A(RST)" |
|
exit 3 |
|
} |
|
if {[catch {package require punk::zip} punkzip_err]} { |
|
puts stderr "$A(BAD)LIBFETCH: punk::zip package unavailable ($punkzip_err) - cannot materialize package trees$A(RST)" |
|
exit 3 |
|
} |
|
set fd [open $libfetch_config r] |
|
fconfigure $fd -encoding utf-8 |
|
set libfetch_tomldata [read $fd] |
|
close $fd |
|
if {[catch {tomlish::to_dict [tomlish::from_toml $libfetch_tomldata]} libfetch_dict]} { |
|
puts stderr "$A(BAD)LIBFETCH: failed to parse $libfetch_config\n$libfetch_dict$A(RST)" |
|
exit 3 |
|
} |
|
#tomlish::to_dict values are type-tagged - ::punkboot::lib::toml_untag (defined |
|
#with the shared toml helpers near the top of this script) resolves them |
|
set libfetch_artifacts [dict create] |
|
if {[dict exists $libfetch_dict artifact]} { |
|
set libfetch_artifacts [dict get $libfetch_dict artifact] |
|
} |
|
if {![dict size $libfetch_artifacts]} { |
|
puts stdout "LIBFETCH: no \[artifact.<name>\] entries found in $libfetch_config" |
|
} |
|
puts stdout "LIBFETCH: origin $libfetch_origin ([dict size $libfetch_artifacts] declared artifact(s))" |
|
set libfetch_sums [dict create] ;#target -> dict(filename -> sha1) from the server's sha1sums.txt |
|
set libfetch_failed 0 |
|
set libfetch_actions [list] |
|
dict for {aname aentry} $libfetch_artifacts { |
|
foreach reqkey {name target} { |
|
if {![dict exists $aentry $reqkey]} { |
|
puts stderr "$A(BAD)LIBFETCH: entry artifact.$aname in $libfetch_config is missing required key '$reqkey'$A(RST)" |
|
exit 3 |
|
} |
|
} |
|
set artifact [punkboot::lib::toml_untag [dict get $aentry name]] |
|
set target [punkboot::lib::toml_untag [dict get $aentry target]] |
|
if {![regexp {^(.+)-(tcl[0-9]+)-r([0-9]+)\.zip$} $artifact -> pkgfolder generation rev]} { |
|
puts stderr "$A(BAD)LIBFETCH: artifact.$aname name '$artifact' does not match <pkgfolder>-tcl<N>-r<N>.zip$A(RST)" |
|
exit 3 |
|
} |
|
set tierdir $libfetch_packagesroot/$target |
|
file mkdir $tierdir |
|
#server truth per target: lib/<target>/sha1sums.txt (fetched once per |
|
#run per target; the local copy in the tier mirrors the punk-runtime |
|
#store idiom) |
|
if {![dict exists $libfetch_sums $target]} { |
|
set sumsurl "$libfetch_origin/lib/$target/sha1sums.txt" |
|
set sumslocal $tierdir/sha1sums.txt |
|
if {[catch {::punkboot::libfetch_transfer $sumsurl $sumslocal} terr]} { |
|
puts stderr "$A(BAD)LIBFETCH: cannot fetch $sumsurl - $terr$A(RST)" |
|
exit 3 |
|
} |
|
set sfd [open $sumslocal r] |
|
set sumsdata [read $sfd] |
|
close $sfd |
|
set sums [dict create] |
|
foreach ln [split $sumsdata \n] { |
|
set ln [string trim $ln] |
|
if {$ln eq ""} {continue} |
|
set sp [string first " " $ln] |
|
if {$sp < 1} {continue} |
|
set h [string range $ln 0 $sp-1] |
|
set tag [string range $ln $sp+1 end] |
|
dict set sums [string range $tag 1 end] [string tolower $h] |
|
} |
|
dict set libfetch_sums $target $sums |
|
} |
|
set sums [dict get $libfetch_sums $target] |
|
if {![dict exists $sums $artifact]} { |
|
puts stderr "$A(BAD)LIBFETCH: artifact.$aname: '$artifact' is not listed in the server's lib/$target/sha1sums.txt$A(RST)" |
|
set libfetch_failed 1 |
|
continue |
|
} |
|
set want_sha1 [dict get $sums $artifact] |
|
set ziplocal $tierdir/$artifact |
|
set have_ok 0 |
|
if {[file isfile $ziplocal] && !$::punkboot::opt_force} { |
|
if {[string tolower [sha1::sha1 -hex -file $ziplocal]] eq $want_sha1} { |
|
set have_ok 1 |
|
} |
|
} |
|
if {!$have_ok} { |
|
set zipurl "$libfetch_origin/lib/$target/$artifact" |
|
set partfile $ziplocal.part |
|
if {[catch {::punkboot::libfetch_transfer $zipurl $partfile} terr]} { |
|
puts stderr "$A(BAD)LIBFETCH: artifact.$aname: fetch failed - $terr$A(RST)" |
|
set libfetch_failed 1 |
|
continue |
|
} |
|
set got_sha1 [string tolower [sha1::sha1 -hex -file $partfile]] |
|
if {$got_sha1 ne $want_sha1} { |
|
file delete -force $partfile |
|
puts stderr "$A(BAD)LIBFETCH: artifact.$aname: sha1 MISMATCH for $artifact (got $got_sha1, server sha1sums says $want_sha1) - deleted$A(RST)" |
|
set libfetch_failed 1 |
|
continue |
|
} |
|
file rename -force $partfile $ziplocal |
|
lappend libfetch_actions "fetched lib/$target/$artifact" |
|
} else { |
|
lappend libfetch_actions "verified-present lib/$target/$artifact" |
|
} |
|
#beside-toml sidecar (also sha1sums-listed by emission) |
|
set sidecar "[string range $artifact 0 end-4].toml" |
|
set sidecarlocal $tierdir/$sidecar |
|
set sidecar_ok 0 |
|
if {[dict exists $sums $sidecar]} { |
|
set want_side [dict get $sums $sidecar] |
|
if {[file isfile $sidecarlocal] && !$::punkboot::opt_force} { |
|
if {[string tolower [sha1::sha1 -hex -file $sidecarlocal]] eq $want_side} { |
|
set sidecar_ok 1 |
|
} |
|
} |
|
if {!$sidecar_ok} { |
|
if {[catch {::punkboot::libfetch_transfer "$libfetch_origin/lib/$target/$sidecar" $sidecarlocal.part} terr]} { |
|
puts stderr "$A(BAD)LIBFETCH: artifact.$aname: sidecar fetch failed - $terr$A(RST)" |
|
set libfetch_failed 1 |
|
continue |
|
} |
|
if {[string tolower [sha1::sha1 -hex -file $sidecarlocal.part]] ne $want_side} { |
|
file delete -force $sidecarlocal.part |
|
puts stderr "$A(BAD)LIBFETCH: artifact.$aname: sidecar sha1 MISMATCH for $sidecar - deleted$A(RST)" |
|
set libfetch_failed 1 |
|
continue |
|
} |
|
file rename -force $sidecarlocal.part $sidecarlocal |
|
} |
|
} else { |
|
puts stderr "LIBFETCH: note - $sidecar not listed in server sha1sums (artifact accepted; sidecar skipped)" |
|
} |
|
#materialize: installed-shape tree under <target>/tcl<N>/<pkgfolder> |
|
#(generation subdir because both generations install identically-named |
|
#folders). Fresh tree per materialization; -mtime restores member |
|
#mtimes so the tree mirrors what was zipped. |
|
set gendir $tierdir/$generation |
|
file mkdir $gendir |
|
set treedir $gendir/$pkgfolder |
|
if {[file isdirectory $treedir] && !$::punkboot::opt_force} { |
|
#re-materialize only when the tree's embedded record no longer |
|
#matches this artifact name (self-describing tier - G-138) |
|
set embrec $treedir/punkbin-artifact.toml |
|
set tree_current 0 |
|
if {[file isfile $embrec]} { |
|
set efd [open $embrec r] |
|
set edata [read $efd] |
|
close $efd |
|
if {[regexp -line "^name = \"$artifact\"$" $edata]} { |
|
set tree_current 1 |
|
} |
|
} |
|
if {$tree_current} { |
|
lappend libfetch_actions "tree-current $target/$generation/$pkgfolder" |
|
continue |
|
} |
|
} |
|
file delete -force $treedir |
|
#defaults: whole archive, -overwrite 1 -mtime 1 (member mtimes restored) |
|
#-verify 1 (per-member crc32) - and accelerator-eligible (punkzip exe) |
|
if {[catch {punk::zip::unzip $ziplocal $gendir} unzip_err]} { |
|
puts stderr "$A(BAD)LIBFETCH: artifact.$aname: materialization failed - $unzip_err$A(RST)" |
|
file delete -force $treedir |
|
set libfetch_failed 1 |
|
continue |
|
} |
|
if {![file isfile $treedir/pkgIndex.tcl] || ![file isfile $treedir/punkbin-artifact.toml]} { |
|
puts stderr "$A(BAD)LIBFETCH: artifact.$aname: materialized tree at $treedir lacks pkgIndex.tcl and/or punkbin-artifact.toml$A(RST)" |
|
set libfetch_failed 1 |
|
continue |
|
} |
|
lappend libfetch_actions "materialized $target/$generation/$pkgfolder" |
|
} |
|
foreach act $libfetch_actions { |
|
puts stdout "LIBFETCH: $act" |
|
} |
|
if {$libfetch_failed} { |
|
puts stderr "$A(BAD)LIBFETCH: FAILED - one or more declared artifacts could not be fetched/verified/materialized (see above)$A(RST)" |
|
exit 3 |
|
} |
|
puts stdout "LIBFETCH: done ([llength $libfetch_actions] action(s)) -> $libfetch_packagesroot" |
|
} |
|
flush stdout |
|
::exit 0 |
|
} |
|
|
|
if {$::punkboot::command ni {bakehouse packages modules libs bake vfslibs bin}} { |
|
puts stderr "Command $::punkboot::command not implemented - aborting." |
|
flush stderr |
|
after 100 |
|
exit 1 |
|
} |
|
|
|
|
|
|
|
#external libs and modules first - and any supporting files - no minting required |
|
|
|
#install src vendor contents (from version controlled src folder) to base of project (same target folders as our own src/modules etc ie to paths that go on the auto_path and in tcl::tm::list) |
|
|
|
if {$::punkboot::command in {bakehouse packages modules}} { |
|
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] |
|
foreach vf $vendormodulefolders { |
|
lassign [split $vf _] _vm tclx |
|
if {$tclx ne ""} { |
|
set which _$tclx |
|
} else { |
|
set which "" |
|
} |
|
set target_module_folder $projectroot/modules$which |
|
file mkdir $target_module_folder |
|
|
|
#install .tm *and other files* |
|
puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" |
|
set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder {*}{ |
|
-installer make.tcl |
|
-overwrite installedsourcechanged-targets |
|
-progresschannel stdout |
|
-exclude-filetails {AGENTS.md include_modules.config} |
|
-exclude-paths {README.md} |
|
}] |
|
# -exclude-paths {README.md AGENTS.md **/AGENTS.md include_modules.config} |
|
#-exclude-filetails {AGENTS.md include_modules.config} |
|
#-exclude-paths {README.md} |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
if {![catch {package require punk::mix::cli}] |
|
&& [llength [info commands ::punk::mix::cli::lib::prune_sourcevanished_targets]] |
|
} { |
|
#remove make.tcl-installed .tm copies whose recorded source files no longer exist |
|
#(e.g vendormodule versions deleted from src/vendormodules) |
|
::punk::mix::cli::lib::prune_sourcevanished_targets $target_module_folder make.tcl -glob *.tm |
|
} else { |
|
puts stderr "VENDORMODULES$which: prune helper punk::mix::cli::lib::prune_sourcevanished_targets unavailable (older punk::mix::cli snapshot) - skipping sourcevanished prune for $target_module_folder" |
|
} |
|
} |
|
if {![llength $vendormodulefolders]} { |
|
puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found." |
|
} |
|
} |
|
|
|
if {$::punkboot::command in {bakehouse packages libs}} { |
|
#exclude README.md from source folder - but only the root one |
|
#-exclude-paths takes relative patterns e.g |
|
# */test.txt will only match test.txt exactly one level deep. |
|
# */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. |
|
# **/test.txt will match at any level below the root (but not in the root) |
|
set antipaths [list {*}{ |
|
README.md |
|
AGENTS.md |
|
**/AGENTS.md |
|
}] |
|
#step1 - vendorlib - pkgIndex.tcl based libraries that are platform neutral and tcl-majorversion neutral |
|
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib] |
|
foreach lf $vendorlibfolders { |
|
set source_lib_folder $sourcefolder/$lf |
|
set target_lib_folder $projectroot/lib |
|
file mkdir $target_lib_folder |
|
puts stdout "VENDORLIB: copying tcl-version neutral and platform neutral libraries from $source_lib_folder to $target_lib_folder (if source file changed)" |
|
set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ |
|
-overwrite installedsourcechanged-targets\ |
|
-exclude-paths $antipaths\ |
|
-progresschannel stdout\ |
|
] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} |
|
if {![llength $vendorlibfolders]} { |
|
puts stderr "VENDORLIB: No src/vendorlib folder found." |
|
} |
|
#step2 - vendorlib_tcl<majorv> - platform-neutral in 'allplatforms' folder + platform specific based on current platform |
|
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] |
|
foreach lf $vendorlibfolders { |
|
lassign [split $lf _] _vm which ;#which is tcl8|tcl9 etc |
|
|
|
set source_lib_folder $sourcefolder/vendorlib_$which/allplatforms |
|
set target_lib_folder $projectroot/lib_$which/allplatforms |
|
if {[file exists $source_lib_folder] && [llength [punkboot::lib::folder_nondotted_folders $source_lib_folder]]} { |
|
file mkdir $target_lib_folder |
|
puts stdout "VENDORLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" |
|
set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ |
|
-overwrite installedsourcechanged-targets\ |
|
-exclude-paths $antipaths\ |
|
-progresschannel stdout\ |
|
] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} else { |
|
puts stdout "$A(BAD)VENDORLIB_$which - no platform neutral folder found at $source_lib_folder$A(RST)" |
|
} |
|
#this_platform_generic |
|
set source_lib_folder $sourcefolder/vendorlib_$which/$this_platform_generic |
|
set target_lib_folder $projectroot/lib_$which/$this_platform_generic |
|
if {[file exists $source_lib_folder] && [llength [punkboot::lib::folder_nondotted_folders $source_lib_folder]]} { |
|
file mkdir $target_lib_folder |
|
puts stdout "VENDORLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" |
|
set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ |
|
-overwrite installedsourcechanged-targets\ |
|
-exclude-paths $antipaths\ |
|
-progresschannel stdout\ |
|
] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} else { |
|
puts stdout "$A(BAD)mVENDORLIB_$which - no platform specific folder found at $source_lib_folder$A(RST)" |
|
} |
|
|
|
} |
|
if {![llength $vendorlibfolders]} { |
|
puts stderr "$A(BAD)VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found.$A(RST)" |
|
} |
|
#G-139: punkbin lib-tier packages from the bin/packages input tier (populated |
|
#by 'make.tcl libfetch') into the deployed lib_tcl<N> trees - allplatforms + |
|
#this host's platform dir, mirroring the vendorlib_tcl<N> shape above. The |
|
#materialized trees are self-describing (embedded punkbin-artifact.toml |
|
#records - G-138) and the records ride along into the deployed trees, and |
|
#from there into kit vfs payloads via the vfslibs declarations. An absent |
|
#tier (or target/generation subdir) is a silent per-item no-op: the tier is |
|
#fetch-regenerable and optional until artifacts are declared and fetched. |
|
set packages_root $projectroot/bin/packages |
|
if {[file isdirectory $packages_root]} { |
|
foreach ptarget [list allplatforms $this_platform_generic] { |
|
foreach gendir [lsort [glob -nocomplain -dir $packages_root/$ptarget -type d tcl*]] { |
|
set which [file tail $gendir] ;#tcl8|tcl9 ... |
|
foreach pkgdir [lsort [glob -nocomplain -dir $gendir -type d *]] { |
|
set pkgtail [file tail $pkgdir] |
|
set target_lib_folder $projectroot/lib_$which/$ptarget |
|
file mkdir $target_lib_folder |
|
puts stdout "PACKAGES_$which: copying $ptarget/$which/$pkgtail from the bin/packages tier to $target_lib_folder (if source file changed)" |
|
set resultdict [punkcheck::install $pkgdir $target_lib_folder/$pkgtail\ |
|
-createdir 1\ |
|
-overwrite installedsourcechanged-targets\ |
|
-progresschannel stdout\ |
|
] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} |
|
} |
|
} |
|
} else { |
|
puts stdout "PACKAGES: no bin/packages tier at $packages_root (populate via 'make.tcl libfetch') - skipping lib-tier package deployment" |
|
} |
|
} |
|
|
|
if {$::punkboot::command in {bakehouse bake vfslibs}} { |
|
#G-115: declarative .vfs payload composition. Each src/vfs/<name>.vfs may have a |
|
#SIBLING declaration file src/vfs/<name>.vfs.toml declaring payload package folders |
|
#to materialize INTO it - while the folder remains the operative assembly area: |
|
#drop-ins need no declaration and are never clobbered. The declaration file's own |
|
#header comment (and src/vfs/README.md) is the user-facing spec. Entry keys per |
|
#[payload.<name>]: source (folder path, resolved per source_root), source_root |
|
#('src' default - vendor trees / suite build products under src/; or 'packages' - |
|
#the consent-gated punkbin lib tier at <projectroot>/bin/packages populated by |
|
#'make.tcl libfetch'), target (folder path INSIDE the .vfs, e.g "lib_tcl9"; |
|
#default the .vfs root), supersedes (explicit legacy sibling folder removals), |
|
#replace (boolean clean-slate of the SAME-NAMED target folder before install). |
|
#A source containing %platform% is a PER-PLATFORM entry (G-127): one copy per |
|
#consuming kit target (derived from the kit mapping below), staged under |
|
#_targets/<platform>/ and selected into each kit's merged image at bake time. |
|
#Materialization is punkcheck-tracked (records in src/vfs/.punkcheck, outside kit |
|
#payloads) with -overwrite synced-targets: a target file punkcheck did not install, |
|
#or that changed since it was installed (a drop-in or hand edit), is PRESERVED and |
|
#reported, never overwritten - the G-115 drop-in-wins precedence; supersedes and |
|
#replace are the explicit declared exceptions. A .vfs with no declaration file is |
|
#untouched (pure drop-in mode, exactly as before G-115). |
|
#This phase supersedes the per-package src/runtime/vendorlib_vfs.toml surface |
|
#(G-037/G-139): its [install.<name>] entries were migrated into per-.vfs files |
|
#2026-07-31 - rationale in goals/G-115-declarative-vfs-composition.md. |
|
set legacy_vfslibs $sourcefolder/runtime/vendorlib_vfs.toml |
|
if {[file exists $legacy_vfslibs]} { |
|
puts stderr "WARNING: $legacy_vfslibs is superseded by per-.vfs payload declarations (src/vfs/<name>.vfs.toml - G-115) and is IGNORED - migrate its \[install.*\] entries into per-.vfs files and remove it." |
|
} |
|
set payload_files [lsort [glob -nocomplain -dir $sourcefolder/vfs -types f -tail *.vfs.toml]] |
|
if {![llength $payload_files]} { |
|
puts stdout "VFSPAYLOAD: no per-.vfs payload declarations (src/vfs/<name>.vfs.toml) - nothing to materialize" |
|
} |
|
#G-127 per-platform payload derivation: a payload source containing %platform% |
|
#declares ONE payload materialized per CONSUMING KIT TARGET - the platform set |
|
#is derived from the kit mapping (every mapvfs kit output pairing this vfs, |
|
#whatever its bake_default), never declared a second time in the payload file. |
|
#Each platform's copy lands under _targets/<platform>/<target>/ inside the .vfs |
|
#folder (VCS-ignored staging); the bake selects the consuming kit's subtree |
|
#into its merged image and drops the staging tree, so an assembled kit carries |
|
#only its own target's payload. |
|
set vfspayload_kit_targets [dict create] |
|
if {[llength $payload_files]} { |
|
set _pmapmodel [punkboot::lib::mapvfs_model $sourcefolder/runtime $binfolder/runtime $sourcefolder $::punkboot::target_platform] |
|
if {[llength [dict get $_pmapmodel configerrors]]} { |
|
puts stderr "WARNING: VFSPAYLOAD: kit-mapping config errors - per-platform (%platform%) payload derivation unavailable this run (the mapping's own gates report the errors)" |
|
} else { |
|
foreach _prec [punkboot::lib::mapvfs_kit_outputs $_pmapmodel $binfolder/runtime $sourcefolder] { |
|
if {![dict exists $vfspayload_kit_targets [dict get $_prec vfs]] |
|
|| [dict get $_prec target] ni [dict get $vfspayload_kit_targets [dict get $_prec vfs]]} { |
|
dict lappend vfspayload_kit_targets [dict get $_prec vfs] [dict get $_prec target] |
|
} |
|
} |
|
} |
|
unset -nocomplain _pmapmodel _prec |
|
} |
|
foreach ptail $payload_files { |
|
set pfile $sourcefolder/vfs/$ptail |
|
set vfstail [file rootname $ptail] ;#punkdeclare.vfs.toml -> punkdeclare.vfs |
|
if {[llength $::punkboot::bake_selected_kitnames] && $vfstail ni $::punkboot::bake_selected_vfs} { |
|
#G-121 selective bake: narrow to the selected kits' vfs folders (skip |
|
#precedes the existence checks so an unselected declaration's problem |
|
#cannot abort a selective run) |
|
puts stdout "VFSPAYLOAD $vfstail: skipping (selective bake - not a selected kit's vfs)" |
|
continue |
|
} |
|
if {![file isdirectory $sourcefolder/vfs/$vfstail]} { |
|
puts stderr "$A(BAD)VFSPAYLOAD: declaration $pfile has no matching vfs folder at $sourcefolder/vfs/$vfstail$A(RST)" |
|
exit 3 |
|
} |
|
lassign [punkboot::lib::toml_file_to_dict $pfile] pstatus ppayload |
|
if {$pstatus ne "ok"} { |
|
puts stderr "$A(BAD)VFSPAYLOAD: $ppayload$A(RST)" |
|
exit 3 |
|
} |
|
dict for {topkey -} $ppayload { |
|
if {$topkey ne "payload"} { |
|
puts stderr "$A(BAD)VFSPAYLOAD: $pfile: unknown top-level table or key '$topkey' (expected \[payload.<name>\] entries)$A(RST)" |
|
exit 3 |
|
} |
|
} |
|
set payload_entries [dict create] |
|
if {[dict exists $ppayload payload]} { |
|
set payload_entries [dict get $ppayload payload] |
|
} |
|
if {![dict size $payload_entries]} { |
|
puts stdout "VFSPAYLOAD $vfstail: no \[payload.<name>\] entries in $ptail" |
|
continue |
|
} |
|
dict for {iname ientry} $payload_entries { |
|
set entrylabel "payload.$iname ($ptail)" |
|
set isource "" |
|
set isource_root "src" |
|
set itarget "" |
|
set isupersedes [list] |
|
set ireplace 0 |
|
dict for {k v} $ientry { |
|
switch -- $k { |
|
source {set isource [punkboot::lib::toml_untag $v]} |
|
source_root {set isource_root [punkboot::lib::toml_untag $v]} |
|
target {set itarget [punkboot::lib::toml_untag $v]} |
|
supersedes {set isupersedes [punkboot::lib::toml_untag $v]} |
|
replace { |
|
set ireplace [punkboot::lib::toml_untag $v] |
|
if {![string is boolean -strict $ireplace]} { |
|
puts stderr "$A(BAD)VFSPAYLOAD: entry $entrylabel: 'replace' must be boolean (got '$ireplace')$A(RST)" |
|
exit 3 |
|
} |
|
} |
|
default { |
|
puts stderr "$A(BAD)VFSPAYLOAD: entry $entrylabel: unknown key '$k' (expected source, source_root, target, supersedes, replace)$A(RST)" |
|
exit 3 |
|
} |
|
} |
|
} |
|
if {$isource eq ""} { |
|
puts stderr "$A(BAD)VFSPAYLOAD: entry $entrylabel is missing required key 'source'$A(RST)" |
|
exit 3 |
|
} |
|
if {$itarget ne "" && ([file pathtype $itarget] ne "relative" || ".." in [file split $itarget])} { |
|
puts stderr "$A(BAD)VFSPAYLOAD: entry $entrylabel target '$itarget' must be a relative path inside the .vfs folder (no '..')$A(RST)" |
|
exit 3 |
|
} |
|
#G-127 per-platform axis: %platform% in 'source' selects the payload per |
|
#consuming kit target (set derived above); 'target' stays literal - its |
|
#per-platform staging prefix (_targets/<platform>/) is implicit. |
|
if {[string match *%platform%* $itarget]} { |
|
puts stderr "$A(BAD)VFSPAYLOAD: entry $entrylabel: 'target' must not contain %platform% - the per-platform staging prefix (_targets/<platform>/) is implicit for a %platform% source$A(RST)" |
|
exit 3 |
|
} |
|
if {[string match *%platform%* $isource]} { |
|
if {![dict exists $vfspayload_kit_targets $vfstail] |
|
|| ![llength [dict get $vfspayload_kit_targets $vfstail]]} { |
|
puts stderr "WARNING: VFSPAYLOAD entry $entrylabel declares a per-platform source (%platform%) but no kit in the mapping consumes $vfstail - no platform set to derive, entry skipped" |
|
continue |
|
} |
|
set entry_platforms [dict get $vfspayload_kit_targets $vfstail] |
|
} else { |
|
set entry_platforms [list ""] ;#platform-neutral entry - materialize once, directly in the folder |
|
} |
|
foreach eplatform $entry_platforms { |
|
if {$eplatform eq ""} { |
|
set esource $isource |
|
set elabel $entrylabel |
|
set evfsprefix "" |
|
} else { |
|
set esource [string map [list %platform% $eplatform] $isource] |
|
set elabel "$entrylabel \[$eplatform\]" |
|
set evfsprefix _targets/$eplatform |
|
} |
|
switch -- $isource_root { |
|
src { |
|
set source_pkg_folder $sourcefolder/$esource |
|
set source_missing_hint "" |
|
} |
|
packages { |
|
set source_pkg_folder $projectroot/bin/packages/$esource |
|
set source_missing_hint " - populate the bin/packages tier first: 'tclsh src/make.tcl libfetch' (declarations in src/runtime/libpackages.toml)" |
|
} |
|
default { |
|
puts stderr "$A(BAD)VFSPAYLOAD: entry $elabel has unknown source_root '$isource_root' (expected src|packages)$A(RST)" |
|
exit 3 |
|
} |
|
} |
|
if {![file isdirectory $source_pkg_folder]} { |
|
puts stderr "$A(BAD)VFSPAYLOAD: entry $elabel source '$esource' not found at $source_pkg_folder$source_missing_hint$A(RST)" |
|
exit 3 |
|
} |
|
set pkgtail [file tail $source_pkg_folder] |
|
set etarget_subpath $itarget |
|
if {$evfsprefix ne ""} { |
|
set etarget_subpath [expr {$itarget eq "" ? $evfsprefix : "$evfsprefix/$itarget"}] |
|
} |
|
if {$etarget_subpath eq ""} { |
|
set target_lib_folder $sourcefolder/vfs/$vfstail |
|
set target_display vfs/$vfstail |
|
} else { |
|
set target_lib_folder $sourcefolder/vfs/$vfstail/$etarget_subpath |
|
set target_display vfs/$vfstail/$etarget_subpath |
|
} |
|
file mkdir $target_lib_folder |
|
#supersession first - no silent mixed-version provision (G-035 concerns) |
|
foreach sup $isupersedes { |
|
if {$sup eq $pkgtail} { |
|
continue ;#never remove what we are about to install - use replace for that |
|
} |
|
set suppath $target_lib_folder/$sup |
|
if {[file exists $suppath]} { |
|
puts stdout "VFSPAYLOAD $elabel: removing superseded '$sup' from $target_display" |
|
file delete -force $suppath |
|
} |
|
} |
|
if {$ireplace && [file isdirectory $target_lib_folder/$pkgtail]} { |
|
puts stdout "VFSPAYLOAD $elabel: replace=true - removing existing '$pkgtail' from $target_display (clean-slate install)" |
|
file delete -force $target_lib_folder/$pkgtail |
|
} |
|
puts stdout "VFSPAYLOAD $elabel: $isource_root:$esource -> $target_display/$pkgtail (if source changed; drop-ins/hand-edits preserved)" |
|
set resultdict [punkcheck::install $source_pkg_folder $target_lib_folder/$pkgtail\ |
|
-installer make.tcl\ |
|
-createdir 1\ |
|
-overwrite synced-targets\ |
|
-punkcheck-folder $sourcefolder/vfs\ |
|
-progresschannel stdout\ |
|
] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
#preserved-collision report: a file skipped although its SOURCE changed was |
|
#withheld by synced-targets (a drop-in, or hand-modified since install) - |
|
#distinct from the routine source-unchanged skips. |
|
set _preserved [list] |
|
foreach _sk [dict get $resultdict files_skipped] { |
|
if {$_sk ni [dict get $resultdict sources_unchanged]} { |
|
lappend _preserved $_sk |
|
} |
|
} |
|
if {[llength $_preserved]} { |
|
puts stdout "VFSPAYLOAD $elabel: NOTE - [llength $_preserved] changed file(s) NOT overwritten (existing target content was not installed by this mechanism, or was modified since) - the G-115 drop-in-wins precedence. Declare 'replace = true' (whole package folder) or remove the target files to hand control to the declaration." |
|
} |
|
unset -nocomplain _preserved _sk |
|
} |
|
} |
|
} |
|
} |
|
|
|
|
|
if {$::punkboot::command in {bakehouse packages libs}} { |
|
######################################################## |
|
lappend projectlibfolders lib |
|
#exclude README.md from source folder - but only the root one |
|
#-exclude-paths takes relative patterns e.g |
|
# */test.txt will only match test.txt exactly one level deep. |
|
# */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. |
|
# **/test.txt will match at any level below the root (but not in the root) |
|
set antipaths [list {*}{ |
|
README.md |
|
AGENTS.md |
|
**/AGENTS.md |
|
}] |
|
#step1 - src/lib - pkgIndex.tcl based libraries that are platform neutral and tcl-majorversion neutral |
|
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib] |
|
foreach lf $projectlibfolders { |
|
set target_lib_folder $projectroot/lib |
|
file mkdir $target_lib_folder |
|
puts stdout "PROJECTLIB: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" |
|
set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder\ |
|
-overwrite installedsourcechanged-targets\ |
|
-exclude-paths $antipaths\ |
|
-progresschannel stdout\ |
|
] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} |
|
if {![llength $projectlibfolders]} { |
|
puts stderr "PROJECTLIB: No src/lib folder found." |
|
} |
|
#step2 - src/lib_<majorv> - platform-neutral in 'allplatforms' folder + platform specific based on current platform |
|
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] |
|
foreach lf $projectlibfolders { |
|
lassign [split $lf _] _vm which |
|
set source_lib_folder $sourcefolder/lib_$which/allplatforms |
|
set target_lib_folder $projectroot/lib_$which/allplatforms |
|
if {[file exists $source_lib_folder] && [llength [punkboot::lib::folder_nondotted_folders $source_lib_folder]]} { |
|
file mkdir $target_lib_folder |
|
puts stdout "PROJECTLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" |
|
set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ |
|
-overwrite installedsourcechanged-targets\ |
|
-exclude-paths $antipaths\ |
|
-progresschannel stdout\ |
|
] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} else { |
|
puts stdout "$A(BAD)mPROJECTLIB_$which - no platform neutral folder found at $source_lib_folder$A(RST)" |
|
} |
|
|
|
#this_platform_generic |
|
set source_lib_folder $sourcefolder/lib_$which/$this_platform_generic |
|
set target_lib_folder $projectroot/lib_$which/$this_platform_generic |
|
if {[file exists $source_lib_folder] && [llength [punkboot::lib::folder_nondotted_folders $source_lib_folder]]} { |
|
file mkdir $target_lib_folder |
|
puts stdout "PROJECTLIB_$which: copying from $source_lib_folder to $target_lib_folder (if source file changed)" |
|
set resultdict [punkcheck::install $source_lib_folder $target_lib_folder\ |
|
-overwrite installedsourcechanged-targets\ |
|
-exclude-paths $antipaths\ |
|
-progresschannel stdout\ |
|
] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} else { |
|
puts stdout "$A(BAD)mPROJECTLIB_$which - no platform specific folder found at $source_lib_folder$A(RST)" |
|
} |
|
|
|
|
|
} |
|
if {![llength $projectlibfolders]} { |
|
puts stderr "PROJECTLIB: No src/lib_tcl* folder found." |
|
} |
|
|
|
|
|
} |
|
|
|
if {$::punkboot::command in {bakehouse packages modules libs}} { |
|
######################################################## |
|
#templates - thin-layout sync (G-087 stage 3; see DIAGRAM 1b in ::punkboot::workflow_text) |
|
#sync the canonical root .gitignore into every vendor layout as the inert gitignore.in |
|
#payload (G-012 - materialized to .gitignore at project generation), sync boot scripts |
|
#(build.tcl, make.tcl) and bootsupport include_modules.config manifests into the thin |
|
#layouts that carry src/make.tcl, then sync the punk.project layout payload from the |
|
#store into the punk::mix::templates modpod source tree so the built module ships it. |
|
#Layouts store no bootsupport/vfs module snapshots - 'dev project.new' injects bootsupport into |
|
#generated projects from the generating shell at generation time. |
|
set layout_bases [list {*}{ |
|
} $sourcefolder/project_layouts/vendor/punk {*}{ |
|
} |
|
] |
|
|
|
foreach layoutbase $layout_bases { |
|
if {![file exists $layoutbase]} { |
|
continue |
|
} |
|
set project_layouts [glob -nocomplain -dir $layoutbase -type d -tail *] |
|
foreach layoutname $project_layouts { |
|
set config [dict create {*}{ |
|
-make-step sync_layouts |
|
}] |
|
#---------- |
|
set tpl_installer [punkcheck::installtrack new make.tcl $sourcefolder/project_layouts/.punkcheck] |
|
$tpl_installer set_source_target $sourcefolder $layoutbase/$layoutname |
|
set tpl_event [$tpl_installer start_event $config] |
|
#---------- |
|
#G-012: every layout's gitignore payload is a derived mirror of the canonical root |
|
#.gitignore, stored inert as gitignore.in (materialized to .gitignore in the |
|
#generated project by punk::mix::commandset::layout::lib::layout_materialize). |
|
#Canonical source is the REPO root .gitignore ($projectroot, not $sourcefolder). |
|
set pairs [list {*}{ |
|
} [list $projectroot/.gitignore $layoutbase/$layoutname/gitignore.in] {*}{ |
|
} |
|
] |
|
if {[file exists $layoutbase/$layoutname/src/make.tcl]} { |
|
#layout carries boot scripts - sync them too (layouts that don't, e.g minimal, |
|
#sample-0.1, receive only the gitignore payload) |
|
lappend pairs {*}{ |
|
} [list $sourcefolder/build.tcl $layoutbase/$layoutname/src/build.tcl] {*}{ |
|
} [list $sourcefolder/make.tcl $layoutbase/$layoutname/src/make.tcl] {*}{ |
|
} |
|
#bootsupport manifests: sync only into bootsupport modules folders the layout already carries |
|
foreach bm [glob -nocomplain -dir $layoutbase/$layoutname/src/bootsupport -type d -tails modules modules_tcl*] { |
|
set src_manifest $sourcefolder/bootsupport/$bm/include_modules.config |
|
if {[file exists $src_manifest]} { |
|
lappend pairs [list $src_manifest $layoutbase/$layoutname/src/bootsupport/$bm/include_modules.config] |
|
} |
|
} |
|
} |
|
|
|
foreach filepair $pairs { |
|
lassign $filepair srcfile tgtfile |
|
|
|
file mkdir [file dirname $tgtfile] |
|
#---------- |
|
$tpl_event targetset_init INSTALL $tgtfile |
|
$tpl_event targetset_addsource $srcfile |
|
#---------- |
|
if { [llength [dict get [$tpl_event targetset_source_changes] changed]] |
|
|| [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]] |
|
} { |
|
$tpl_event targetset_started |
|
# -- --- --- --- --- --- |
|
puts stdout "PROJECT LAYOUT update - layoutname: $layoutname Copying from $srcfile to $tgtfile" |
|
if {[catch { |
|
file copy -force $srcfile $tgtfile |
|
} errM]} { |
|
$tpl_event targetset_end FAILED -note "layout:$layoutname copy failed with err: $errM" |
|
} else { |
|
$tpl_event targetset_end OK -note "layout:$layoutname" |
|
} |
|
# -- --- --- --- --- --- |
|
} else { |
|
puts stderr "." |
|
$tpl_event targetset_end SKIPPED |
|
} |
|
} |
|
|
|
$tpl_event end |
|
$tpl_event destroy |
|
$tpl_installer destroy |
|
} |
|
} |
|
|
|
#store -> modpod payload sync: the punk::mix::templates module ships the thin punk.project layout |
|
#so module-pathtype layout refs resolve and a bare kit outside any project can generate from it. |
|
#The modpod copy is sync-managed - do not hand-edit it. Excludes: bin/sdx.kit (no new binaries |
|
#inside zip-based .tm modules). (The unimplemented child-side src/PROJECT_LAYOUTS_* marker was |
|
#retired by G-087 stage 5 - thin layouts + generation-time injection made it moot.) |
|
set store_layout $sourcefolder/project_layouts/vendor/punk/project-0.1 |
|
set modpod_layout "$sourcefolder/modules/punk/mix/#modpod-templates-999999.0a1.0/templates/project_layouts/vendor/punk/project-0.1" |
|
if {[file isdirectory $store_layout]} { |
|
file mkdir $modpod_layout |
|
puts stdout "LAYOUT->MODPOD: syncing thin punk.project layout payload into punk::mix::templates modpod source (if source file changed)" |
|
#override the default core excludes: .fossil-custom/.fossil-settings are layout content the |
|
#generated project needs (project.new installs them into projects with the same override) |
|
set resultdict [punkcheck::install $store_layout $modpod_layout {*}{ |
|
-punkcheck-folder |
|
} $sourcefolder/project_layouts {*}{ |
|
-installer make.tcl |
|
-overwrite installedsourcechanged-targets |
|
-createempty 1 |
|
-exclude-paths-core {#* **/#* _aside **/_aside _build **/_build _mint **/_mint _bake **/_bake .git **/.git} |
|
-exclude-paths {bin/sdx.kit} |
|
}] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
if {![catch {package require punk::mix::cli}] |
|
&& [llength [info commands ::punk::mix::cli::lib::prune_sourcevanished_targets]] |
|
} { |
|
#remove synced layout/modpod copies whose recorded source files no longer exist |
|
::punk::mix::cli::lib::prune_sourcevanished_targets $sourcefolder/project_layouts make.tcl -glob * |
|
} else { |
|
puts stderr "sync_layouts: prune helper punk::mix::cli::lib::prune_sourcevanished_targets unavailable (older punk::mix::cli snapshot) - skipping sourcevanished prune for $modpod_layout" |
|
} |
|
} |
|
} |
|
|
|
if {$::punkboot::command in {bakehouse packages modules}} { |
|
#consolidated /modules /modules_tclX folder used for target where X is tcl major version |
|
#the make process will process for any _tclX not just the major version of the current interpreter |
|
|
|
#default source module folders are at projectroot/src/modules and projectroot/src/modules_tclX (where X is tcl major version) |
|
#There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) |
|
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] |
|
puts stdout "SOURCEMODULES: scanning [llength $source_module_folderlist] folders" |
|
foreach src_module_dir $source_module_folderlist { |
|
set mtail [file tail $src_module_dir] |
|
if {[string match "modules_tcl*" $mtail]} { |
|
set target_modules_base $projectroot/$mtail |
|
} else { |
|
set target_modules_base $projectroot/modules |
|
} |
|
file mkdir $target_modules_base |
|
|
|
puts stderr "Processing source module dir: $src_module_dir" |
|
set dirtail [file tail $src_module_dir] |
|
#modules and associated files belonging to this package/app |
|
set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm |
|
#set copied [list] |
|
puts stdout "--------------------------" |
|
puts stderr "Copied [llength $copied] tm modules from src/$dirtail to $target_modules_base " |
|
puts stdout "--------------------------" |
|
|
|
set overwrite "installedsourcechanged-targets" |
|
#set overwrite "ALL-TARGETS" |
|
puts stdout "MODULEFOLDER non_tm_files $src_module_dir - copying to $target_modules_base (if source file changed)" |
|
set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base\ |
|
-installer make.tcl\ |
|
-overwrite $overwrite\ |
|
-exclude-paths {README.md **/AGENTS.md AGENTS.md}\ |
|
-progresschannel stdout\ |
|
] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} |
|
} |
|
|
|
if {$::punkboot::command in {bakehouse packages modules libs}} { |
|
set installername "make.tcl" |
|
# ---------------------------------------- |
|
if {[punk::repo::is_fossil_root $projectroot]} { |
|
set config [dict create {*}{ |
|
-make-step configure_fossil |
|
}] |
|
#---------- |
|
set installer [punkcheck::installtrack new $installername $projectroot/.punkcheck] |
|
$installer set_source_target $projectroot $projectroot |
|
|
|
set event [$installer start_event $config] |
|
$event targetset_init VIRTUAL fossil_settings_mainmenu ;#VIRTUAL - since there is no actual target file |
|
set menufile $projectroot/.fossil-custom/mainmenu |
|
$event targetset_addsource $menufile |
|
#---------- |
|
|
|
if {\ |
|
[llength [dict get [$event targetset_source_changes] changed]]\ |
|
} { |
|
$event targetset_started |
|
# -- --- --- --- --- --- |
|
puts stdout "Configuring fossil setting: mainmenu from: $menufile" |
|
if {[catch { |
|
set fd [open $menufile r] |
|
fconfigure $fd -translation binary |
|
set data [read $fd] |
|
close $fd |
|
exec fossil settings mainmenu $data |
|
} errM]} { |
|
$event targetset_end FAILED -note "fossil update failed: $errM" |
|
} else { |
|
$event targetset_end OK |
|
} |
|
# -- --- --- --- --- --- |
|
} else { |
|
puts stderr "." |
|
$event targetset_end SKIPPED |
|
} |
|
$event end |
|
$event destroy |
|
$installer destroy |
|
} |
|
} |
|
|
|
#review |
|
set installername "make.tcl" |
|
|
|
if {$::punkboot::command ni {bakehouse bake bin}} { |
|
#command = packages/modules/libs/vfslibs - stops before kit assembly |
|
puts stdout "vfs folders not checked" |
|
puts stdout " - use 'make.tcl vfscommonupdate' to promote minted modules into the base vfs folder (promotion gate - commit for provenance)" |
|
puts stdout " - use 'make.tcl bake' to bake executable kits/zipkits from the vfs folders if you have runtimes installed" |
|
puts stdout " Note that without the vfscommonupdate step, 'make.tcl bake' will include any manual changes in the *custom* vfs folders but" |
|
puts stdout " without the latest minted modules." |
|
puts stdout " calling 'builtexename(.exe) minted' will allow testing of minted modules before they are baked into the kits/zipkits via 'vfscommonupdate' then 'bake'" |
|
puts stdout " - consumer full path from a clean checkout: 'make.tcl bakehouse'" |
|
puts stdout "-done-" |
|
exit 0 |
|
} |
|
|
|
|
|
#G-155: the bake workdir resolver was renamed get_build_workdir -> get_bake_workdir with the |
|
#src/_build -> src/_bake flip. Fall back to a direct mkdir when driving a stale punk::mix |
|
#snapshot (old bootsupport, or a generated project mid-update) so the mixed state stays runnable. |
|
if {[llength [info commands ::punk::mix::cli::lib::get_bake_workdir]]} { |
|
set bakefolder [punk::mix::cli::lib::get_bake_workdir $sourcefolder] |
|
} else { |
|
puts stderr "NOTE: punk::mix snapshot predates get_bake_workdir (G-155) - using $sourcefolder/_bake directly. Refresh with 'make.tcl modules' + 'make.tcl bootsupport'." |
|
file mkdir $sourcefolder/_bake |
|
set bakefolder $sourcefolder/_bake |
|
} |
|
if {$bakefolder ne "$sourcefolder/_bake"} { |
|
puts stderr "$sourcefolder/_bake doesn't match the project bakefolder $bakefolder - check project filestructure" |
|
puts stdout " -aborted- " |
|
exit 2 |
|
} |
|
|
|
if {$::punkboot::command eq "bin"} { |
|
puts stdout "checking $sourcefolder/bin" |
|
set resultdict [punkcheck::install $sourcefolder/bin $binfolder\ |
|
-overwrite synced-targets\ |
|
-installer "punkboot-bin"\ |
|
-progresschannel stdout\ |
|
] |
|
|
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
flush stdout |
|
} |
|
|
|
#find runtimes |
|
#set rtfolder $sourcefolder/runtime |
|
#AAA |
|
|
|
#G-122: the runtime store is addressed by TARGET platform, not by the driving |
|
#tclsh's personality. $rt_default_target is this host's default target (a |
|
#cygwin-family host targets win32; macOS collapses to the universal 'macosx' |
|
#tier) and $rtfolder is that target's store. mapvfs.config entries may declare |
|
#their own target platform - those runtimes live in their own tier under $rtbase |
|
#and are resolved through $rtfolder_of below. |
|
set rt_default_target $::punkboot::target_platform |
|
set rt_os_arch [punkboot::lib::platform_store_tier $rt_default_target] |
|
set rtbase $binfolder/runtime |
|
set rtfolder $rtbase/$rt_os_arch |
|
set rt_exe_suffix [punkboot::lib::platform_exe_suffix $rt_default_target] |
|
set rt_sourcefolder $sourcefolder/runtime ;#where our config lives |
|
|
|
#G-122: derive the BUILDCOPY name from the runtime FILENAME rather than from the |
|
#driving tclsh's platform. The copy is the same binary as its source, so it must |
|
#keep the source's executable convention - an .exe stays an .exe whether a native |
|
#windows tclsh, an msys/cygwin-runtime tclsh (platform 'unix', .exe files) or a |
|
#cross-target host is driving the bake. |
|
#Mapping key for a runtime FILE name: the name as mapvfs.config spells it, i.e |
|
#with a windows .exe suffix removed. Only .exe may be stripped - 'file rootname' |
|
#would eat the last dotted segment of version-named runtimes such as tclsh9.0.5, |
|
#which carry no suffix at all on non-windows targets (G-122). |
|
proc ::punkboot::lib::runtime_mapkey {runtimefile} { |
|
if {[string match -nocase *.exe $runtimefile]} { |
|
return [string range $runtimefile 0 end-4] |
|
} |
|
return $runtimefile |
|
} |
|
proc ::punkboot::lib::runtime_buildcopyname {runtime} { |
|
set rttail [file tail $runtime] |
|
if {[string match -nocase *.exe $rttail]} { |
|
return "[file rootname $rttail]_BUILDCOPY.exe" |
|
} |
|
return "${rttail}_BUILDCOPY" |
|
} |
|
|
|
#Local runtime-materialization staleness check (warn-only, no network). The kit |
|
#wrap consumes the punk-runtime WORKING COPY (<root>[.exe]) - a developer may |
|
#deliberately 'punk-runtime use' an older -r<N> artifact (e.g to exercise |
|
#'list -remote' row marking) and forget to switch back, silently baking kits on |
|
#a stale runtime (field incident 2026-07-25: punk9_beta wrapped an r1 runtime |
|
#while r2 sat beside it - caught only by a piperepl test pin). Compares the |
|
#working copy's beside-toml revision (G-103/G-117 metadata) against the highest |
|
#-r<N> artifact revision present in the same folder. Pre-family runtimes (no |
|
#toml) and direct -r<N> references stay silent; one warning per runtime per run. |
|
#G-121: the comparison core lives in ::punkboot::lib::runtime_materialization_check, |
|
#shared with the bakelist report's rtrev= note. |
|
#G-122: run a command whose arguments must reach a NATIVE WINDOWS program |
|
#verbatim. The msys2 runtime rewrites any argument that looks like an absolute |
|
#posix path when it spawns a native windows executable, so 'taskkill /PID 1234' |
|
#arrives as 'taskkill C:/msys64-root/PID 1234' - field-verified 2026-07-26: the |
|
#pre-deploy process sweep found the running kit with tasklist and then could not |
|
#kill it, failing the whole kit. MSYS2_ARG_CONV_EXCL=* is msys2's documented |
|
#opt-out and is inert on every other host (real cygwin does not convert arguments |
|
#at all), so one command spelling stays correct from every host personality. |
|
proc ::punkboot::exec_nativeargs {cmdlist} { |
|
set had [info exists ::env(MSYS2_ARG_CONV_EXCL)] |
|
if {$had} { |
|
set prev $::env(MSYS2_ARG_CONV_EXCL) |
|
} |
|
set ::env(MSYS2_ARG_CONV_EXCL) * |
|
try { |
|
return [exec {*}$cmdlist] |
|
} finally { |
|
if {$had} { |
|
set ::env(MSYS2_ARG_CONV_EXCL) $prev |
|
} else { |
|
unset -nocomplain ::env(MSYS2_ARG_CONV_EXCL) |
|
} |
|
} |
|
} |
|
|
|
set ::punkboot::runtime_rev_warned [dict create] |
|
proc ::punkboot::runtime_materialization_warning {rtfolder runtime_fullname} { |
|
if {[dict exists $::punkboot::runtime_rev_warned $runtime_fullname]} { |
|
return |
|
} |
|
dict set ::punkboot::runtime_rev_warned $runtime_fullname 1 |
|
set stale [punkboot::lib::runtime_materialization_check $rtfolder $runtime_fullname] |
|
if {[dict size $stale]} { |
|
set current_rev [dict get $stale current_rev] |
|
set maxrev [dict get $stale maxrev] |
|
set maxname [dict get $stale maxname] |
|
::punkboot::print_bake_warnings [list "runtime $runtime_fullname working copy is materialized from revision r$current_rev but $maxname (r$maxrev) is present beside it - kits wrapping this runtime get r$current_rev. To bake with r$maxrev: bin/punk-runtime.cmd use $maxname then re-run the bake"] |
|
} |
|
return |
|
} |
|
|
|
# -- --- --- --- --- --- --- --- --- --- |
|
#load mapvfs.config file (if any) in runtime folder to map runtimes to vfs folders. |
|
#build a dict keyed on runtime executable name. |
|
#If no mapfile (or no mapfile entry for that runtime) - the runtime will be paired with a matching .vfs folder in src folder. e.g punk.exe to src/punk.vfs |
|
#If vfs folders or runtime executables which are explicitly listed in the mapfile don't exist - warn on stderr - but continue. if such nonexistants found; prompt user for whether to continue or abort. |
|
#G-121: parsing lives in ::punkboot::lib::mapvfs_parse - the shared model consumed here, |
|
#by 'bakelist' and by the selective-bake name resolution (never the file format directly). |
|
#G-122: parsed BEFORE runtime discovery, because the mapping is what says which |
|
#store tiers this bake must look in - an entry declaring a target platform other |
|
#than the host default addresses its own bin/runtime/<tier>. |
|
set mapfile [punkboot::lib::mapvfs_locate $rt_sourcefolder] |
|
set mapmodel [punkboot::lib::mapvfs_model $rt_sourcefolder $rtbase $sourcefolder $rt_default_target] |
|
foreach warnline [dict get $mapmodel warnings] { |
|
puts stderr $warnline |
|
} |
|
if {[llength [dict get $mapmodel configerrors]]} { |
|
foreach errline [dict get $mapmodel configerrors] { |
|
puts stderr $errline |
|
} |
|
exit 3 |
|
} |
|
set runtime_vfs_map [dict get $mapmodel runtime_vfs_map] |
|
set vfs_runtime_map [dict get $mapmodel vfs_runtime_map] |
|
set runtime_target [dict get $mapmodel runtime_target] |
|
set missing [dict get $mapmodel missing] |
|
if {[llength $missing]} { |
|
if {[dict get $mapmodel format] eq "toml" && ![llength $::punkboot::bake_selected_kitnames]} { |
|
#G-024 strictness (toml models): a full bake with unresolvable DEFAULT entries |
|
#reports each one BY ENTRY rather than as a bare item list. A missing vfs |
|
#folder is fatal - vfs folders are repo content, so its absence means a wrong |
|
#declaration. A missing runtime FILE is environment, not declaration: store |
|
#tiers are legitimately part-populated (fresh clones; runtimes arrive via the |
|
#consent-gated fetch tiers), so those entries skip with a recapped |
|
#BAKE-WARNING naming the entry (cross-target wording states the tier reason). |
|
#bake_default=false entries are not in the full-bake set; selective bakes |
|
#fail fast at selection instead. |
|
set _strict_fatal [list] |
|
set _strict_warn [list] |
|
foreach _rec [punkboot::lib::mapvfs_kit_outputs $mapmodel $rtbase $sourcefolder] { |
|
if {![dict get $_rec bake_default]} { |
|
continue |
|
} |
|
set _entrylabel [expr {[dict get $_rec entry] ne "" ? [dict get $_rec entry] : [dict get $_rec kitname]}] |
|
if {![dict get $_rec vfs_present]} { |
|
lappend _strict_fatal "entry $_entrylabel: vfs folder src/vfs/[dict get $_rec vfs] is missing" |
|
continue |
|
} |
|
if {[dict get $_rec runtime] ne "-" && ![dict get $_rec runtime_present]} { |
|
if {[dict get $_rec target] eq $rt_default_target} { |
|
lappend _strict_warn "kit [dict get $_rec kitname] (entry $_entrylabel) skipped - runtime [dict get $_rec runtime_file] not present in bin/runtime/[dict get $_rec store_tier]" |
|
} else { |
|
lappend _strict_warn "kit [dict get $_rec kitname] (entry $_entrylabel) skipped - cross-target runtime [dict get $_rec runtime_file] not present in bin/runtime/[dict get $_rec store_tier] (target [dict get $_rec target] tier not populated on this host)" |
|
} |
|
} |
|
} |
|
if {[llength $_strict_fatal]} { |
|
puts stderr "CONFIG ERROR: unresolvable kit mapping entries in $mapfile - nothing built:" |
|
foreach _line $_strict_fatal { |
|
puts stderr " $_line" |
|
} |
|
exit 3 |
|
} |
|
if {[llength $_strict_warn]} { |
|
::punkboot::print_bake_warnings $_strict_warn |
|
} |
|
unset -nocomplain _rec _entrylabel _strict_fatal _strict_warn _line |
|
} else { |
|
puts stderr "WARNING [llength $missing] missing items from $mapfile. (TODO - prompt user to continue/abort)" |
|
foreach m $missing { |
|
puts stderr " $m" |
|
} |
|
puts stderr "continuing..." |
|
} |
|
} |
|
# -- --- --- --- --- --- --- --- --- --- |
|
puts "-- runtime_vfs_map --" |
|
punk::lib::pdict runtime_vfs_map |
|
puts "---------------------" |
|
puts "-- vfs_runtime_map--" |
|
punk::lib::pdict vfs_runtime_map |
|
puts "---------------------" |
|
|
|
# -- --- --- --- --- --- --- --- --- --- |
|
#Runtime discovery. The default-target store is scanned wholesale (a runtime |
|
#there needs no mapping entry - it can pair with a same-named .vfs folder); |
|
#cross-target runtimes are only picked up when the mapping names them, since |
|
#scanning every tier would pull in runtimes nothing asked to be built. |
|
#$rtfolder_of resolves a discovered runtime FILE name to the store folder it |
|
#came from (runtime_target_of gives its target platform) - every later store |
|
#address, suffix and process-tooling decision goes through these rather than |
|
#assuming the driving tclsh's platform (G-122). |
|
set runtimes [list] |
|
set rtfolder_of [dict create] |
|
proc ::punkboot::lib::runtime_target_of {rtname} { |
|
#target platform of a runtime name (unsuffixed), from the parsed mapping |
|
upvar #0 runtime_target runtime_target rt_default_target rt_default_target |
|
if {[info exists runtime_target] && [dict exists $runtime_target $rtname]} { |
|
return [dict get $runtime_target $rtname] |
|
} |
|
return $rt_default_target |
|
} |
|
if {[file dirname [info nameofexecutable]] eq $rtfolder && [file isdirectory [info nameofexecutable]]} { |
|
#info name will only appear to be a directory when the runtime is a tclkit that is mounted at the same path as the physical file. |
|
#This is not a problem for zip based kits. |
|
#fix so that we can find and use a runtime tclkit that is currently in use as the runtime that is running this script. |
|
# - when the current runtime is using a runtime in the rtfolder that is a tclkit, it is mounted at the same path as the physical file and so appears to Tcl as if it's a directory. |
|
# - use external filesystem tools to make a copy of the file |
|
#(copy tooling is a HOST concern - the running executable is by definition a host binary) |
|
if {$::punkboot::host_windows} { |
|
#exec cmd /c copy [info nameofexecutable] $rtfolder/[file rootname [file tail [info nameofexecutable]]]_BUILDCOPY.exe |
|
::punkboot::exec_nativeargs [list cmd /c copy [file nativename [info nameofexecutable]] [file nativename $rtfolder/[punkboot::lib::runtime_buildcopyname [info nameofexecutable]]]] |
|
} else { |
|
#exec cp [info nameofexecutable] $rtfolder/[file tail [info nameofexecutable]]_BUILDCOPY |
|
exec cp [info nameofexecutable] $rtfolder/[punkboot::lib::runtime_buildcopyname [info nameofexecutable]] |
|
} |
|
#we need to add the base name of the current exe to the runtimes list because the next section will look for files in the runtime folder |
|
#and won't find the mounted runtime since it's mounted as a directory. |
|
lappend runtimes [file tail [info nameofexecutable]] |
|
dict set rtfolder_of [file tail [info nameofexecutable]] $rtfolder |
|
} |
|
|
|
set rtfolder_files [glob -nocomplain -dir $rtfolder -types {f} -tail *] |
|
set exclusions {.config .md .ico .txt .doc .pdf .htm .html} ;#we don't encourage other files in runtime folder aside from mapvfs.config - but lets ignore some common possibilities |
|
lappend exclusions .zip .7z .pea .bz2 .tar .gz .tgz .z .xz ;#don't allow archives to directly be treated as runtimes - tolerate presence but require user to unpack or rename if they're to be used as runtimes |
|
lappend exclusions .tail ;#result of running sdx mksplit on a kit - in theory the .head could be used - review/test |
|
lappend exclusions .toml ;#G-103 runtime artifact metadata sits beside its runtime |
|
foreach f $rtfolder_files { |
|
if {[string match "*_BUILDCOPY*" $f]} { |
|
continue |
|
} |
|
if {[string tolower [file extension $f]] in $exclusions} { |
|
continue |
|
} |
|
if {$f ni $runtimes} { |
|
lappend runtimes $f |
|
dict set rtfolder_of $f $rtfolder |
|
} |
|
} |
|
#cross-target runtimes named by the mapping (their own tier, their own suffix) |
|
set cross_target_tiers [list] |
|
dict for {_rtname _rttarget} $runtime_target { |
|
if {$_rtname eq "-" || $_rttarget eq $rt_default_target} { |
|
continue |
|
} |
|
set _tier [punkboot::lib::platform_store_tier $_rttarget] |
|
set _dir $rtbase/$_tier |
|
set _file $_rtname[punkboot::lib::platform_exe_suffix $_rttarget] |
|
if {$_tier ni $cross_target_tiers} { |
|
lappend cross_target_tiers $_tier |
|
} |
|
if {![file exists [file join $_dir $_file]]} { |
|
continue ;#absent cross-target runtime already warned by the parse |
|
} |
|
if {[dict exists $rtfolder_of $_file]} { |
|
puts stderr "WARNING: runtime file $_file is present in more than one store tier ([dict get $rtfolder_of $_file] and $_dir) - using the first found. Rename one of them to bake both." |
|
continue |
|
} |
|
lappend runtimes $_file |
|
dict set rtfolder_of $_file $_dir |
|
} |
|
if {[llength $cross_target_tiers]} { |
|
puts stdout "cross-target runtime tiers in use (kit-mapping target platforms): [join $cross_target_tiers {, }]" |
|
} |
|
unset -nocomplain _rtname _rttarget _tier _dir _file |
|
if {![llength $runtimes]} { |
|
puts stderr "No executable runtimes found in $rtfolder - unable to bake any .vfs folders into executables." |
|
puts stderr "Add runtimes to $rtfolder if required" |
|
if {![file isdirectory $rtfolder]} { |
|
#same store-tier self-diagnosis as bakelist |
|
puts stderr "NOTE: that runtime store folder does not exist. Default target '$rt_default_target' derives from THIS tclsh: tcl_platform(os)='$::tcl_platform(os)' tcl_platform(platform)='$::tcl_platform(platform)' -> host canon '$::punkboot::host_platform' -> target '$rt_default_target'." |
|
puts stderr " Populate it with 'bin/punk-runtime.cmd' (or by hand), or declare a per-entry target platform in mapvfs.toml for runtimes stored elsewhere." |
|
} |
|
#todo - don't exit - it is valid to use runtime of - to just bake a .kit/.zipkit ? |
|
exit 0 |
|
} |
|
#G-121 selective bake: restrict processing to the runtimes the selected kits wrap - |
|
#other runtimes get no BUILDCOPY refresh, no capability probe and no punkcheck events. |
|
if {[llength $::punkboot::bake_selected_kitnames]} { |
|
set runtimes [lmap _rtfile $runtimes { |
|
#NOTE: only an .exe suffix may be stripped to recover the mapping key - |
|
#'file rootname' would eat the last dotted version segment of names like |
|
#tclsh9.0.5 (suffixless on non-windows targets). |
|
set _rtkey [punkboot::lib::runtime_mapkey $_rtfile] |
|
if {$_rtkey ni $::punkboot::bake_selected_runtimes} { |
|
continue |
|
} |
|
set _rtfile |
|
}] |
|
unset -nocomplain _rtfile _rtkey |
|
} |
|
|
|
#previous have_sdx test location |
|
|
|
|
|
#only test the runtime capabilities for runtimes that are actually in our map |
|
#how can we do this for runtimes from other platforms? |
|
#method1 try to mount as zip and kit - depends on current runtime to have mkzip - just because there is zip data doesn't mean the kit can mount it |
|
#method2 analyze executable to determine if its for another platform - then ask user and save answers in a config file.? |
|
#mthod3 qemu? |
|
set runtime_caps [dict create] |
|
foreach runtime [dict keys $runtime_vfs_map] { |
|
if {[llength $::punkboot::bake_selected_kitnames] && $runtime ni $::punkboot::bake_selected_runtimes} { |
|
continue ;#G-121 selective bake - probe only the runtimes being wrapped |
|
} |
|
set capscript { |
|
set caps [dict create] |
|
dict set caps patchlevel [info patchlevel] |
|
if {[lsearch -index 1 [info loaded] tclkitpath] >=0} { |
|
#for a bare kit that has had vfs removed (ie head made with sdx mksplit) |
|
#we can't use package require starkit |
|
dict set caps has_starkit 1 |
|
} else { |
|
#fallback - review if necessary |
|
if {![catch { |
|
package require starkit |
|
} errM]} { |
|
dict set caps has_starkit 1 |
|
} else { |
|
dict set caps has_starkit 0 |
|
} |
|
} |
|
#G-129: key zipfs capability on tcl::zipfs::mount - present in every zipfs |
|
#generation including the androwish/undroidwish 8.6 backport, which has no |
|
#tcl::zipfs::root. (This block previously rode a body-less 'if {![catch ..]}' |
|
#that only worked because piped-stdin tclsh continues past command errors.) |
|
if {[info commands tcl::zipfs::mount] ne ""} { |
|
dict set caps has_zipfs 1 |
|
} else { |
|
dict set caps has_zipfs 0 |
|
} |
|
if {![catch { |
|
package require cookfs |
|
} errM]} { |
|
dict set caps has_cookfs 1 |
|
} else { |
|
dict set caps has_cookfs 0 |
|
} |
|
puts -nonewline stdout $caps |
|
exit 0 |
|
} |
|
|
|
#G-122: address the runtime in ITS target's store tier, with ITS target's |
|
#executable suffix. (Before the split this probed a suffixless name in the |
|
#host-derived folder, so on windows every runtime silently reported |
|
#find-fail and no capability was ever learned.) |
|
set rt_target [punkboot::lib::runtime_target_of $runtime] |
|
set rt_dir $rtbase/[punkboot::lib::platform_store_tier $rt_target] |
|
set rt_file $runtime[punkboot::lib::platform_exe_suffix $rt_target] |
|
if {![file exists $rt_dir/$rt_file]} { |
|
dict set runtime_caps $runtime exitcode -1 error "find-fail $rt_dir/$rt_file" |
|
continue |
|
} |
|
if {[punkboot::lib::platform_process_family $rt_target] ne [punkboot::lib::platform_process_family $::punkboot::host_platform]} { |
|
#cross-target runtime: this host cannot execute it, so its capabilities |
|
#stay unknown (the kit machinery falls back to trying the configured type) |
|
dict set runtime_caps $runtime exitcode -1 error "cross-target ($rt_target) - not executable on this host" |
|
continue |
|
} |
|
|
|
#invoke can fail if runtime not an executable file for the current platform |
|
if {[file type $rt_dir/$rt_file] eq "directory"} { |
|
#assume it's a mounted tclkit (because tcl kits mount in same place as their underlying path and mask the executable as a directory) |
|
#use the BUILDCOPY created above - REVIEW |
|
set useruntime [punkboot::lib::runtime_buildcopyname $rt_file] |
|
} else { |
|
set useruntime $rt_file |
|
} |
|
if {![catch { |
|
lassign [punk::lib::invoke [list $rt_dir/$useruntime <<$capscript]] stdout stderr exitcode |
|
} errM]} { |
|
if {$exitcode == 0} { |
|
dict set runtime_caps $runtime $stdout |
|
} |
|
dict set runtime_caps $runtime exitcode $exitcode |
|
} else { |
|
dict set runtime_caps $runtime exitcode -1 error "launch-fail" |
|
} |
|
} |
|
puts stdout "Runtime capabilities:" |
|
punk::lib::pdict runtime_caps |
|
|
|
set vfs_tails [glob -nocomplain -dir $sourcefolder/vfs -types d -tail *.vfs] |
|
#add any extra .vfs folders found in runtime/mapvfs.config file (e.g myotherruntimes/something.vfs) |
|
dict for {vfstail -} $vfs_runtime_map { |
|
if {$vfstail ni $vfs_tails} { |
|
lappend vfs_tails $vfstail |
|
} |
|
} |
|
#G-121 selective bake: only the selected kits' vfs folders get checked/checksummed - |
|
#other vfs folders' punkcheck bake events never fire. |
|
if {[llength $::punkboot::bake_selected_kitnames]} { |
|
set vfs_tails [lmap _vt $vfs_tails { |
|
if {$_vt ni $::punkboot::bake_selected_vfs} { |
|
continue |
|
} |
|
set _vt |
|
}] |
|
unset -nocomplain _vt |
|
} |
|
if {![llength $vfs_tails]} { |
|
puts stdout "No .vfs folders found at '$sourcefolder/vfs' - no kits to bake" |
|
puts stdout " -done- " |
|
exit 0 |
|
} |
|
|
|
set vfs_folder_changes [dict create] ;#cache whether each .vfs folder has changes so we don't re-run tests if baking from same .vfs with multiple runtime executables |
|
|
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
#make build copy for all runtimes - not just those in the map - because even without a mapvfs.config file entry we bake an exe for a runtime that matches .vfs folder name - REVIEW. |
|
foreach runtimefile $runtimes { |
|
#runtimefile e.g tclkit86bi.exe for a win32 target, tclkit86bi for a posix one |
|
|
|
#sdx *may* be pointed to use the runtime we use to bake the kit, or the user may manually use this runtime if they don't have tclsh |
|
#sdx will complain if the same runtime is used for the shell as is used in the -runtime argument - so we make a copy (REVIEW) |
|
#if {![file exists $bakefolder/buildruntime.exe]} { |
|
# file copy $rtfolder/$runtimefile $bakefolder/buildruntime.exe |
|
#} |
|
|
|
#G-122: each runtime is read from the tier its target platform names, not |
|
#from one host-derived folder. Build copies keep the flat build_<file> name - |
|
#the mapping cannot hold one runtime name in two tiers, so they cannot collide. |
|
set rt_dir [dict get $rtfolder_of $runtimefile] |
|
if {![file exists $rt_dir/$runtimefile]} { |
|
puts stderr " >> skipping $runtimefile not present in $rt_dir" |
|
continue |
|
} |
|
|
|
if {[file type $rt_dir/$runtimefile] eq "directory"} { |
|
#assume it's a mounted tclkit (because tcl kits mount in same place as their underlying path and mask the executable) |
|
#use the BUILDCOPY created above - REVIEW |
|
set useruntimefile [punkboot::lib::runtime_buildcopyname $runtimefile] |
|
} else { |
|
set useruntimefile $runtimefile |
|
} |
|
|
|
set basedir $bakefolder |
|
set config [dict create {*}{ |
|
-make-step copy_runtime |
|
}] |
|
#---------- |
|
set installer [punkcheck::installtrack new $installername $basedir/.punkcheck] |
|
$installer set_source_target $rt_dir $bakefolder |
|
set event [$installer start_event $config] |
|
$event targetset_init INSTALL $bakefolder/build_$runtimefile |
|
#$event targetset_addsource $rt_dir/$runtimefile |
|
$event targetset_addsource $rt_dir/$useruntimefile ;#possibly the _BUILDCOPY in the runtime folder (created for when mounted in current executable as a tclkit) |
|
$event targetset_addsource $bakefolder/build_$runtimefile ;#self as source for change detection |
|
#---------- |
|
|
|
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
|
if {\ |
|
[llength [dict get [$event targetset_source_changes] changed]]\ |
|
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
|
} { |
|
$event targetset_started |
|
# -- --- --- --- --- --- |
|
#This is the full runtime - *possibly* with some sort of vfs attached. |
|
puts stdout "Copying runtime (as is) from $rt_dir/$useruntimefile to $bakefolder/build_$runtimefile" |
|
if {[catch { |
|
file copy -force $rt_dir/$useruntimefile $bakefolder/build_$runtimefile ;#becomes baking_runtime |
|
} errM]} { |
|
puts stderr " >> copy runtime to $bakefolder/build_$runtimefile FAILED" |
|
$event targetset_end FAILED |
|
} else { |
|
$event targetset_end OK |
|
} |
|
# -- --- --- --- --- --- |
|
} else { |
|
puts stderr "unchanged: $runtimefile" |
|
$event targetset_end SKIPPED |
|
} |
|
$event end |
|
|
|
} |
|
|
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
set have_sdx 1 |
|
set sdxpath [auto_execok $binfolder/sdx] |
|
if {$sdxpath eq ""} { |
|
set sdxpath [auto_execok [file dirname [info nameofexecutable]]/sdx] |
|
if {$sdxpath eq ""} { |
|
#last resort - look on path |
|
set sdxpath [auto_execok sdx] |
|
} |
|
if {$sdxpath eq ""} { |
|
#last resorts - a tclkit and sdx.kit file |
|
if {[file exists $binfolder/sdx.kit]} { |
|
set tclkitpath [auto_execok $binfolder/tclkit] |
|
if {$tclkitpath eq ""} { |
|
set tclkitpath [auto_execok tclkit] |
|
} |
|
if {$tclkitpath ne ""} { |
|
set sdxpath [list {*}$tclkitpath $binfolder/sdx.kit] |
|
} else { |
|
#see if the runtime (or any runtime *for current platform*) has tclkit in the name or has_starkit(?) and use that |
|
#todo - review |
|
#picking first found for now - fix |
|
#G-122: only a runtime this HOST can execute can drive sdx - the |
|
#capability probe already skipped cross-target runtimes, so a |
|
#has_starkit record means the runtime ran here. |
|
dict for {rtname rtprops} $runtime_caps { |
|
if {[dict exists $rtprops has_starkit] && [dict get $rtprops has_starkit]} { |
|
set _rt_target [punkboot::lib::runtime_target_of $rtname] |
|
set testpath $rtbase/[punkboot::lib::platform_store_tier $_rt_target]/$rtname[punkboot::lib::platform_exe_suffix $_rt_target] |
|
if {[file exists $testpath]} { |
|
if {[file type $testpath] eq "directory"} { |
|
set alt_tclkitpath [file dirname $testpath]/[punkboot::lib::runtime_buildcopyname $testpath] |
|
} else { |
|
set alt_tclkitpath $testpath |
|
} |
|
if {[file exists $alt_tclkitpath]} { |
|
set sdxpath [list {*}$alt_tclkitpath $binfolder/sdx.kit] |
|
break |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
if {$sdxpath eq "" || [catch {exec {*}$sdxpath help} errM]} { |
|
puts stderr "FAILED to find usable sdx command or tclkit executable with sdx.bat" |
|
puts stderr "If tclkit-based runtimes are required - check that sdx executable is in bin folder of project or in same folder as tcl/punk executable or on path" |
|
puts stderr "This is not a problem if tcl8.7/tcl9+ kits using the preferred method 'zipfs' are to be used, or if cookfs based kits are to be used." |
|
puts stderr "err: $errM" |
|
#exit 1 |
|
set have_sdx 0 |
|
} |
|
} |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
set failed_kits [list] |
|
set installed_kits [list] |
|
set skipped_kits [list] |
|
set skipped_kit_installs [list] |
|
|
|
proc ::make_file_traversal_error {args} { |
|
error "file_traverse error: $args" |
|
} |
|
|
|
#fauxlink aware recursive copy of files and folders |
|
#will follow fauxlinks with 'merge_over' tag, will copy other fauxlinks |
|
proc merge_over {sourcedir targetdir {depth 0}} { |
|
package require fileutil |
|
package require fauxlink |
|
set margin [string repeat " " [expr {$depth * 4}]] |
|
|
|
set ver [package require fileutil::traverse] |
|
puts stdout "${margin}using fileutil::traverse $ver\n[package ifneeded fileutil::traverse $ver]" |
|
package require control |
|
|
|
if {![file exists $sourcedir]} { |
|
puts stderr "${margin}merge_over sourcedir '$sourcedir' not found" |
|
return |
|
} |
|
if {![file exists $targetdir]} { |
|
puts stderr "${margin}merge_over targetdir '$targetdir' not found - target folder must already exist" |
|
return |
|
} |
|
puts stdout "${margin}merge vfs $sourcedir over $targetdir STARTING" |
|
|
|
#The tails should be unique enough for clarity in progress emissions to stdout |
|
set sourcename [file tail $sourcedir] |
|
set targetname [file tail $targetdir] |
|
|
|
set t [fileutil::traverse %AUTO% $sourcedir -errorcmd ::make_file_traversal_error] |
|
set last_type "-" |
|
$t foreach file_or_dir { |
|
set relpath [fileutil::stripPath $sourcedir $file_or_dir] |
|
set target [file join $targetdir $relpath] |
|
set this_type [file type $file_or_dir] |
|
switch -exact -- $this_type { |
|
directory { |
|
if {$last_type ne "directory"} { |
|
puts -nonewline stdout \n |
|
} |
|
if {![file exists $target]} { |
|
#puts stdout "-- mkdir $target" |
|
puts stdout "${margin}$sourcename -> $targetname mkdir $relpath" |
|
#puts stdout "calling: file mkdir $target" |
|
#note - file mkdir can fail on vfs mounts with non-existant intermediate paths. |
|
#e.g if mount is at: //cookfstemp:/subpath/file.exe |
|
#if mounted lower, e.g //cookfstemp:/file.exe it works |
|
#todo - determine where the bug lies - submit ticket? |
|
file mkdir $target |
|
file mtime $target [file mtime $file_or_dir] |
|
} else { |
|
puts stdout "${margin}$sourcename -> $targetname existing dir $relpath" |
|
} |
|
} |
|
file { |
|
if {[file extension $file_or_dir] in {.fxlnk .fauxlink}} { |
|
puts stdout "fauxlink: $file_or_dir" |
|
flush stdout |
|
if {[catch { |
|
puts stdout ">";flush stdout |
|
set linkinfo [fauxlink::resolve $file_or_dir] |
|
} errM]} { |
|
puts stdout ">>";flush stdout |
|
puts stdout "${margin}--->fauxlink::resolve error\n $errM" |
|
flush stdout |
|
error $errM |
|
} |
|
puts stdout ">>>";flush stdout |
|
puts stdout "--- '$linkinfo'" |
|
flush stdout |
|
set flinktags [dict get $linkinfo tags] |
|
puts stdout "fauxlink tags: $flinktags" |
|
flush stdout |
|
if {"punk::boot,merge_over" in $flinktags} { |
|
puts stdout "fauxlink got correct tag from $flinktags" |
|
flush stdout |
|
set linktarget [dict get $linkinfo targetpath] |
|
if {[file pathtype $linktarget] eq "relative"} { |
|
#fauxlink targets are link-location-relative (symlink semantics - |
|
#the fauxlink module doc's 'file in parent dir' example). Same as |
|
#the old sourcedir-relative resolution for the historical |
|
#root-level links; differs for nested ones (G-129 app/main.tcl). |
|
set actualsource [file join [file dirname $file_or_dir] $linktarget] |
|
} else { |
|
set actualsource $linktarget |
|
} |
|
set name [dict get $linkinfo name] ;#name the linked file will become |
|
set aliased_file_or_dir [file join [file dirname $file_or_dir] $name] |
|
set relpath [fileutil::stripPath $sourcedir $aliased_file_or_dir] |
|
set target [file join $targetdir $relpath] |
|
if {[file type $actualsource] eq "file"} { |
|
#fauxlink linktarget (source data) is a file |
|
puts -nonewline stdout "[punkboot::sgr 32]<fxlnk.targetfor.${name}>[punkboot::sgr]" |
|
puts "file copy -force $actualsource $target" |
|
file copy -force $actualsource $target |
|
} else { |
|
#fauxlink linktarget (source data) is a folder |
|
puts stdout "${margin}RECURSING merge_over for link-target $actualsource due to fauxlink:[file tail $file_or_dir]" |
|
#merge_over initial target dir must exist - use file mkdir to ensure |
|
file mkdir $target |
|
puts stdout "merge_over $actualsource $target [expr {$depth + 1}]" |
|
merge_over $actualsource $target [expr {$depth + 1}] |
|
} |
|
} else { |
|
puts stdout "fauxlink tag not matched" |
|
flush stdout |
|
#tag not targetted at us - just copy the fauxlink as an ordinary file |
|
puts -nonewline stdout "<fxlnk>" |
|
file copy -force $file_or_dir $target |
|
} |
|
} else { |
|
puts -nonewline stdout "." |
|
if {[file exists $target]} { |
|
puts stderr "Warning: merge_over is overwriting $target" |
|
} |
|
file copy -force $file_or_dir $target |
|
} |
|
} |
|
default { |
|
puts stderr "${margin}merge vfs $sourcedir !!! unhandled file type $this_type !!!" |
|
} |
|
} |
|
set last_type $this_type |
|
} |
|
$t destroy |
|
puts stdout "\n${margin}merge vfs $sourcedir over $targetdir done." |
|
} |
|
|
|
#Startup-script presence check for a .vfs source folder about to be built into a kit. |
|
#A kit's boot entry is a root-level main.tcl - either an actual file, or a root-level fauxlink |
|
#resolving to the name main.tcl whose target exists and is a .tcl file (materialised into the |
|
#build copy by the merge_over fauxlink handling above). |
|
#Returns an empty string when a startup script is present, otherwise warning text. |
|
#A kit without a startup script is legal (e.g a bare runtime + payload) - callers warn and |
|
#continue rather than aborting. |
|
proc vfs_startup_script_warning {vfsfolder} { |
|
if {[file isfile [file join $vfsfolder main.tcl]]} { |
|
return "" |
|
} |
|
package require fauxlink |
|
set detail "" |
|
foreach link [glob -nocomplain -dir $vfsfolder -types f *.fxlnk *.fauxlink] { |
|
if {[catch {fauxlink::resolve $link} linkinfo]} { |
|
append detail "; unresolvable fauxlink: [file tail $link]" |
|
continue |
|
} |
|
if {[dict get $linkinfo name] ne "main.tcl"} { |
|
continue |
|
} |
|
set linktarget [dict get $linkinfo targetpath] |
|
if {[file pathtype $linktarget] eq "relative"} { |
|
set linktarget [file join $vfsfolder $linktarget] |
|
} |
|
if {[file isfile $linktarget]} { |
|
if {[string tolower [file extension $linktarget]] eq ".tcl"} { |
|
return "" |
|
} |
|
append detail "; main.tcl fauxlink target '$linktarget' is not a .tcl file" |
|
} else { |
|
append detail "; main.tcl fauxlink target '$linktarget' does not exist" |
|
} |
|
} |
|
return "vfs folder $vfsfolder has NO STARTUP SCRIPT: no root main.tcl and no root fauxlink resolving to main.tcl with an existing .tcl target - kits built from it will have no boot script (bake proceeding anyway)$detail" |
|
} |
|
#Cat-style zipkit assembly: a raw (vfs-free) runtime followed by a freshly built |
|
#zip, concatenated. This is the zipfs-less assembly path for BOTH zip-type kits |
|
#(G-122): Tcl's zipfs locates an image by scanning back from the END of the file |
|
#and reads the central directory with ARCHIVE-START-RELATIVE offsets, so a plain |
|
#concatenation mounts. 'zipfs mkimg's file-relative offset rewrite is one |
|
#convention, not a mounting requirement - the zipcat kit type is the in-repo |
|
#proof, and this lets a driving tcl with no zipfs at all (any 8.6) assemble zip |
|
#kits. The zip itself is written by tcl::zipfs::mkzip when the driving tcl has |
|
#it, else by punk::zip::mkzip (pure Tcl). |
|
#Returns the number of zip bytes appended. |
|
proc ::punkboot::assemble_zipcat_image {raw_runtime wrapvfs outfile zipfile} { |
|
file copy -force $raw_runtime $outfile |
|
#runtime in runtime folder may not have write perm set - ensure the copy does as we need to append |
|
catch {exec chmod +w $outfile} |
|
file delete $zipfile |
|
if {[info commands ::tcl::zipfs] ne ""} { |
|
puts stdout "tcl::zipfs::mkzip $zipfile $wrapvfs $wrapvfs" |
|
::tcl::zipfs::mkzip $zipfile $wrapvfs $wrapvfs |
|
} else { |
|
puts stdout "punk::zip::mkzip -directory $wrapvfs -base $wrapvfs $zipfile *" |
|
package require punk::zip |
|
punk::zip::mkzip -directory $wrapvfs -base $wrapvfs $zipfile * |
|
} |
|
puts stderr "concatenating zip to executable.." |
|
set fdout [open $outfile a] |
|
chan conf $fdout -translation binary |
|
puts stderr "runtime bytes: [tell $fdout]" |
|
set fdzip [open $zipfile r] |
|
chan conf $fdzip -translation binary |
|
set zipbytes [fcopy $fdzip $fdout] |
|
close $fdzip |
|
puts stderr "zip bytes: $zipbytes" |
|
puts stderr "exezip bytes: [tell $fdout]" |
|
close $fdout |
|
return $zipbytes |
|
} |
|
|
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
#G-057 kit icon step. Every built kit gets a <kitname>.resources.toml sidecar |
|
#recording the bake-time icon choice (default src/runtime/punkshell.ico, |
|
#overridable by a root-level punkshell.ico in the kit's own custom .vfs folder, |
|
#consulted PRE-merge so the _vfscommon copy never reads as an override), and |
|
#win32-target kits get that icon embedded as PE RT_ICON/RT_GROUP_ICON resources |
|
#when this host can write them. Two mechanisms share one semantic (delete ALL |
|
#icon/group entries, write the .ico images as ids 1..N; the RT_GROUP_ICON is |
|
#NAMED from the icon file - uppercased rootname, so punkshell.ico gives |
|
#PUNKSHELL (user decision 2026-07-29, RC uppercase convention) - with language |
|
#adopted from the first replaced group; idempotent by construction, parity |
|
#recorded in the G-128 detail file): the vendored punkres portable stamper |
|
#(G-128, src/tools/punkres, built by 'make.tcl tool build punkres') is |
|
#selected when bin/punkres(.exe) exists and works from ANY bake host; |
|
#otherwise the twapi arm (tcl-sfe sfe-0.2.tm ReplaceIconInStub lineage; Ashok |
|
#P. Nadkarni) serves windows hosts with nothing built. Ordering is stub-first either way: a per-kit |
|
#copy of the payload-free raw runtime prefix is stamped BEFORE any payload is |
|
#appended (punkres could also stamp post-hoc - the bake keeps stub-first so |
|
#both arms stay interchangeable). kit_icon_process is the single internal |
|
#entry point - mechanism selection lives inside it. Non-PE targets skip as NOT |
|
#APPLICABLE; a win32 target on an incapable host skips with a distinct notice; |
|
#both still write the sidecar. |
|
#Decisions and skip taxonomy: goals G-057 detail file. Sidecar format doc: |
|
#bin/AGENTS.md. |
|
#sha256 is self-contained (same algorithm as src/assets/logo/make-ico.tcl and |
|
#scriptlib/developer/assetorigin_check.tcl - each stays standalone: make.tcl |
|
#must not depend on scriptlib, and this step must not depend on bootsupport |
|
#freshness; bootsupport carries only sha1/md5). Memoized per path per run. |
|
namespace eval ::punkboot::kiticon { |
|
variable sha256_cache |
|
if {![info exists sha256_cache]} {set sha256_cache [dict create]} |
|
variable twapi_state "" |
|
variable punkres_state "" |
|
variable K { |
|
0x428a2f98 0x71374491 0xb5c0fbcf 0xe9b5dba5 0x3956c25b 0x59f111f1 0x923f82a4 0xab1c5ed5 |
|
0xd807aa98 0x12835b01 0x243185be 0x550c7dc3 0x72be5d74 0x80deb1fe 0x9bdc06a7 0xc19bf174 |
|
0xe49b69c1 0xefbe4786 0x0fc19dc6 0x240ca1cc 0x2de92c6f 0x4a7484aa 0x5cb0a9dc 0x76f988da |
|
0x983e5152 0xa831c66d 0xb00327c8 0xbf597fc7 0xc6e00bf3 0xd5a79147 0x06ca6351 0x14292967 |
|
0x27b70a85 0x2e1b2138 0x4d2c6dfc 0x53380d13 0x650a7354 0x766a0abb 0x81c2c92e 0x92722c85 |
|
0xa2bfe8a1 0xa81a664b 0xc24b8b70 0xc76c51a3 0xd192e819 0xd6990624 0xf40e3585 0x106aa070 |
|
0x19a4c116 0x1e376c08 0x2748774c 0x34b0bcb5 0x391c0cb3 0x4ed8aa4a 0x5b9cca4f 0x682e6ff3 |
|
0x748f82ee 0x78a5636f 0x84c87814 0x8cc70208 0x90befffa 0xa4506ceb 0xbef9a3f7 0xc67178f2 |
|
} |
|
} |
|
proc ::punkboot::kiticon::sha256_data {data} { |
|
variable K |
|
set bitlen [expr {wide([string length $data]) * 8}] |
|
append data \x80 |
|
set pad [expr {(56 - [string length $data] % 64 + 64) % 64}] |
|
append data [string repeat \x00 $pad] [binary format W $bitlen] |
|
set h0 0x6a09e667; set h1 0xbb67ae85; set h2 0x3c6ef372; set h3 0xa54ff53a |
|
set h4 0x510e527f; set h5 0x9b05688c; set h6 0x1f83d9ab; set h7 0x5be0cd19 |
|
set n [string length $data] |
|
for {set off 0} {$off < $n} {incr off 64} { |
|
binary scan [string range $data $off [expr {$off + 63}]] Iu16 w |
|
for {set t 16} {$t < 64} {incr t} { |
|
set x [lindex $w [expr {$t - 15}]] |
|
set s0 [expr {((($x >> 7) | ($x << 25)) ^ (($x >> 18) | ($x << 14)) ^ ($x >> 3)) & 0xffffffff}] |
|
set x [lindex $w [expr {$t - 2}]] |
|
set s1 [expr {((($x >> 17) | ($x << 15)) ^ (($x >> 19) | ($x << 13)) ^ ($x >> 10)) & 0xffffffff}] |
|
lappend w [expr {([lindex $w [expr {$t - 16}]] + $s0 + [lindex $w [expr {$t - 7}]] + $s1) & 0xffffffff}] |
|
} |
|
set a $h0; set b $h1; set c $h2; set d $h3 |
|
set e $h4; set f $h5; set g $h6; set h $h7 |
|
for {set t 0} {$t < 64} {incr t} { |
|
set S1 [expr {((($e >> 6) | ($e << 26)) ^ (($e >> 11) | ($e << 21)) ^ (($e >> 25) | ($e << 7))) & 0xffffffff}] |
|
set ch [expr {(($e & $f) ^ (~$e & $g)) & 0xffffffff}] |
|
set T1 [expr {($h + $S1 + $ch + [lindex $K $t] + [lindex $w $t]) & 0xffffffff}] |
|
set S0 [expr {((($a >> 2) | ($a << 30)) ^ (($a >> 13) | ($a << 19)) ^ (($a >> 22) | ($a << 10))) & 0xffffffff}] |
|
set maj [expr {($a & $b) ^ ($a & $c) ^ ($b & $c)}] |
|
set T2 [expr {($S0 + $maj) & 0xffffffff}] |
|
set h $g; set g $f; set f $e; set e [expr {($d + $T1) & 0xffffffff}] |
|
set d $c; set c $b; set b $a; set a [expr {($T1 + $T2) & 0xffffffff}] |
|
} |
|
set h0 [expr {($h0 + $a) & 0xffffffff}]; set h1 [expr {($h1 + $b) & 0xffffffff}] |
|
set h2 [expr {($h2 + $c) & 0xffffffff}]; set h3 [expr {($h3 + $d) & 0xffffffff}] |
|
set h4 [expr {($h4 + $e) & 0xffffffff}]; set h5 [expr {($h5 + $f) & 0xffffffff}] |
|
set h6 [expr {($h6 + $g) & 0xffffffff}]; set h7 [expr {($h7 + $h) & 0xffffffff}] |
|
} |
|
return [format %08x%08x%08x%08x%08x%08x%08x%08x $h0 $h1 $h2 $h3 $h4 $h5 $h6 $h7] |
|
} |
|
proc ::punkboot::kiticon::sha256_file {path} { |
|
variable sha256_cache |
|
set key [file normalize $path] |
|
if {[dict exists $sha256_cache $key]} { |
|
return [dict get $sha256_cache $key] |
|
} |
|
set f [open $path rb] |
|
set data [read $f] |
|
close $f |
|
set hex [sha256_data $data] |
|
dict set sha256_cache $key $hex |
|
return $hex |
|
} |
|
proc ::punkboot::kiticon::toml_escape {s} { |
|
return [string map {\\ \\\\ \" \\\"} $s] |
|
} |
|
#Tolerant subset reader for the chosen icon's G-135 assetorigin sidecar - lifts |
|
#source/source_hash so the kit record reaches back to the SVG-derived master. |
|
#Missing sidecar, unknown schema or malformed content simply yields no |
|
#provenance fields (never an error). |
|
proc ::punkboot::kiticon::assetorigin_read {assetpath} { |
|
set sc $assetpath.assetorigin.toml |
|
set out [dict create] |
|
if {![file isfile $sc]} { |
|
return $out |
|
} |
|
if {[catch { |
|
set f [open $sc rb] |
|
set raw [read $f] |
|
close $f |
|
}]} { |
|
return $out |
|
} |
|
foreach line [split [encoding convertfrom utf-8 $raw] \n] { |
|
set line [string trim [string map [list \r {}] $line]] |
|
if {$line eq "" || [string index $line 0] eq "#"} continue |
|
if {[string index $line 0] eq "\["} break |
|
set eq [string first = $line] |
|
if {$eq < 1} continue |
|
set key [string trim [string range $line 0 [expr {$eq - 1}]]] |
|
if {$key ni {schema source source_hash}} continue |
|
set val [string trim [string range $line [expr {$eq + 1}] end]] |
|
if {[string index $val 0] eq "\""} { |
|
set parsed "" |
|
set ok 0 |
|
set len [string length $val] |
|
for {set i 1} {$i < $len} {incr i} { |
|
set chr [string index $val $i] |
|
if {$chr eq "\\"} { |
|
incr i |
|
append parsed [string index $val $i] |
|
} elseif {$chr eq "\""} { |
|
set ok 1 |
|
break |
|
} else { |
|
append parsed $chr |
|
} |
|
} |
|
if {!$ok} continue |
|
set val $parsed |
|
} else { |
|
set cmt [string first # $val] |
|
if {$cmt >= 0} { |
|
set val [string trim [string range $val 0 [expr {$cmt - 1}]]] |
|
} |
|
} |
|
dict set out $key $val |
|
} |
|
if {![dict exists $out schema] || [dict get $out schema] ne "1"} { |
|
return [dict create] |
|
} |
|
return $out |
|
} |
|
proc ::punkboot::kiticon::writefile_ifchanged {path content} { |
|
if {[file exists $path]} { |
|
set f [open $path rb] |
|
set existing [read $f] |
|
close $f |
|
if {$existing eq $content} { |
|
return unchanged |
|
} |
|
} |
|
set f [open $path wb] |
|
puts -nonewline $f $content |
|
close $f |
|
return written |
|
} |
|
proc ::punkboot::kiticon::copy_ifchanged {from to} { |
|
if {![file isfile $from]} { |
|
return absent |
|
} |
|
set f [open $from rb] |
|
set fromdata [read $f] |
|
close $f |
|
if {[file exists $to]} { |
|
set f [open $to rb] |
|
set todata [read $f] |
|
close $f |
|
if {$todata eq $fromdata} { |
|
return unchanged |
|
} |
|
} |
|
file copy -force $from $to |
|
return copied |
|
} |
|
#Memoized once per run: can this host's tclsh write PE resources? Returns |
|
#{1 {}} or {0 reason} with the reason distinguishing cross-host from |
|
#twapi-unavailable (the acceptance requires distinct notices). |
|
proc ::punkboot::kiticon::twapi_available {} { |
|
variable twapi_state |
|
if {$twapi_state eq "ok"} { |
|
return [list 1 {}] |
|
} |
|
if {$twapi_state ne ""} { |
|
return [list 0 $twapi_state] |
|
} |
|
if {[punkboot::lib::platform_process_family $::punkboot::host_platform] ne "windows"} { |
|
set twapi_state "cross-host: win32 target baked on a $::punkboot::host_platform host cannot run the twapi resource APIs (portable post-hoc stamping is the G-128 remedy)" |
|
return [list 0 $twapi_state] |
|
} |
|
if {[catch {package require twapi_resource}] && [catch {package require twapi}]} { |
|
set twapi_state "twapi resource APIs not loadable in this tclsh ([info nameofexecutable]) - the vendored twapi under vendorlib_tcl<N>/win32-x86_64 serves native windows tclsh builds" |
|
return [list 0 $twapi_state] |
|
} |
|
if {![llength [info commands ::twapi::begin_resource_update]]} { |
|
set twapi_state "twapi loaded but its resource-update APIs are absent" |
|
return [list 0 $twapi_state] |
|
} |
|
set twapi_state ok |
|
return [list 1 {}] |
|
} |
|
#Memoized once per run: locate the built punkres portable stamper (G-128). |
|
#Returns {1 <exepath>} or {0 <reason>}. Presence of the binary IS the |
|
#mechanism-selection signal: with no tool built the twapi arm and its skip |
|
#taxonomy behave exactly as they did before G-128 (zig stays optional). |
|
proc ::punkboot::kiticon::punkres_available {repo_root} { |
|
variable punkres_state |
|
if {$punkres_state ne ""} { |
|
return $punkres_state |
|
} |
|
if {[punkboot::lib::platform_process_family $::punkboot::host_platform] eq "windows"} { |
|
set exe $repo_root/bin/punkres.exe |
|
} else { |
|
set exe $repo_root/bin/punkres |
|
} |
|
if {[file isfile $exe]} { |
|
set punkres_state [list 1 $exe] |
|
} else { |
|
set punkres_state [list 0 "portable stamper not present at $exe - 'tclsh src/make.tcl tool build punkres' builds it from vendored source, or fetch the prebuilt punkbin artifact (win32-x86_64/tools/punkres-*; route: src/tools/punkres/PROVENANCE.md) (G-128)"] |
|
} |
|
return $punkres_state |
|
} |
|
#G-128 punkres arm: exec the vendored portable stamper on the payload-free stub |
|
#copy. punkres itself deletes all icon/group entries, writes the images as ids |
|
#1..N under the first pre-existing group's name+lang (a non-empty |
|
#group_override renames the group via 'set-icon -group' - the seam's naming |
|
#policy; language and codepage adoption unchanged), and re-reads its own |
|
#output (resources AND any overlay) before reporting success - equivalent |
|
#resource content to the twapi arm from the same input (parity evidence in the |
|
#G-128 detail file). Returns the number of images embedded; raises an error |
|
#carrying punkres's output on any nonzero exit. |
|
proc ::punkboot::kit_icon_embed_punkres {punkres_exe exepath icopath {group_override {}}} { |
|
set f [open $icopath rb] |
|
set icondata [read $f] |
|
close $f |
|
binary scan $icondata ttt ico_reserved ico_type ico_count |
|
if {$ico_reserved != 0 || $ico_type != 1} { |
|
error "$icopath is not recognisable as a .ico file" |
|
} |
|
if {$ico_count == 0} { |
|
error "no images in $icopath" |
|
} |
|
set cmd [list exec [file nativename $punkres_exe] set-icon] |
|
if {$group_override ne ""} { |
|
lappend cmd -group $group_override |
|
} |
|
#-drop-opaque-overlay: the stub contract is a payload-free prefix, so any |
|
#non-zip trailing bytes are build detritus - concretely the COFF |
|
#symbol/debug tables mingw-built runtimes carry after their sections, |
|
#which ride into the extraction head. The twapi arm's EndUpdateResource |
|
#has always silently stripped exactly those bytes (measured 2026-07-29, |
|
#G-128 detail); punkres drops them deliberately and zeroes the dangling |
|
#symbol-table header pointer. A REAL zip payload on a stub is unaffected |
|
#(the flag is inert for zip-classified overlays, which punkres preserves). |
|
lappend cmd -drop-opaque-overlay |
|
lappend cmd [file nativename $exepath] [file nativename $icopath] 2>@1 |
|
if {[catch $cmd output]} { |
|
error "punkres set-icon failed: $output" |
|
} |
|
return $ico_count |
|
} |
|
#Replace RT_ICON (type 3) and RT_GROUP_ICON (type 14) in the PE at exepath with |
|
#the images of icopath. Follows sfe-0.2.tm ReplaceIconInStub generalized: all |
|
#existing icon/group entries (any name, any lang) are deleted and the new set |
|
#written as ids 1..N under the first pre-existing group's name+lang (fallback |
|
#name 1, lang 1033), in one resource-update transaction. A non-empty |
|
#group_override replaces the group NAME only (language adoption unchanged) - |
|
#the same override punkres's 'set-icon -group' applies, so the seam's naming |
|
#policy keeps the two arms in parity (G-128). Raises an error on failure |
|
#(after -discard); returns the number of images embedded. The file at exepath |
|
#must carry NO appended payload - a resource update rewrites the image. |
|
proc ::punkboot::kit_icon_embed_twapi {exepath icopath {group_override {}}} { |
|
set f [open $icopath rb] |
|
set icondata [read $f] |
|
close $f |
|
binary scan $icondata ttt ico_reserved ico_type ico_count |
|
if {$ico_reserved != 0 || $ico_type != 1} { |
|
error "$icopath is not recognisable as a .ico file" |
|
} |
|
if {$ico_count == 0} { |
|
error "no images in $icopath" |
|
} |
|
set old_icons [list] |
|
set old_groups [list] |
|
set libh [twapi::load_library $exepath -datafile] |
|
try { |
|
set resources [twapi::extract_resources $libh] |
|
foreach {restype var} {3 old_icons 14 old_groups} { |
|
if {[dict exists $resources $restype]} { |
|
foreach rname [dict keys [dict get $resources $restype]] { |
|
foreach rlang [dict keys [dict get $resources $restype $rname]] { |
|
lappend $var [list $rname $rlang] |
|
} |
|
} |
|
} |
|
} |
|
} trap {TWAPI_WIN32 1812} {} { |
|
#no resource section at all - nothing to enumerate |
|
} finally { |
|
twapi::free_library $libh |
|
} |
|
set group_name 1 |
|
set group_lang 1033 |
|
if {[llength $old_groups]} { |
|
lassign [lindex $old_groups 0] group_name group_lang |
|
} |
|
if {$group_override ne ""} { |
|
set group_name $group_override |
|
} |
|
set update_h [twapi::begin_resource_update $exepath] |
|
try { |
|
foreach entry $old_icons { |
|
lassign $entry rname rlang |
|
twapi::delete_resource $update_h 3 $rname $rlang |
|
} |
|
foreach entry $old_groups { |
|
lassign $entry rname rlang |
|
twapi::delete_resource $update_h 14 $rname $rlang |
|
} |
|
set grouphdr [binary format ttt 0 1 $ico_count] |
|
for {set i 0} {$i < $ico_count} {incr i} { |
|
#.ico ICONDIRENTRY is 16 bytes; GRPICONDIRENTRY is 14 - the trailing |
|
#4-byte image offset becomes a 2-byte icon resource id. Raw width and |
|
#height bytes are carried as-is (0 means 256 in both formats). |
|
set off [expr {6 + 16 * $i}] |
|
binary scan $icondata "@${off} cu cu cu cu tu tu nu nu" w h cc rsv planes bits bytesinres imgoff |
|
set iconid [expr {$i + 1}] |
|
append grouphdr [binary format "cu cu cu cu tu tu nu tu" $w $h $cc $rsv $planes $bits $bytesinres $iconid] |
|
twapi::update_resource $update_h 3 $iconid $group_lang [string range $icondata $imgoff [expr {$imgoff + $bytesinres - 1}]] |
|
} |
|
twapi::update_resource $update_h 14 $group_name $group_lang $grouphdr |
|
} on error {msg ropts} { |
|
catch {twapi::end_resource_update $update_h -discard} |
|
return -options $ropts $msg |
|
} |
|
twapi::end_resource_update $update_h |
|
return $ico_count |
|
} |
|
#G-057 single internal entry point. Decides the kit's icon (override: root |
|
#punkshell.ico in the kit's own custom .vfs folder, pre-merge; else the project |
|
#default src/runtime/punkshell.ico), writes/refreshes the kit's |
|
#<kitname>.resources.toml sidecar in the bake folder, and - when the target |
|
#has PE resources and this host can write them - stamps a per-kit copy of the |
|
#payload-free raw runtime prefix. Returns {wrap_runtime sidecarpath}: |
|
#wrap_runtime is the runtime prefix the assembly step must consume (the stamped |
|
#copy when embedding happened, the untouched raw prefix otherwise). |
|
proc ::punkboot::kit_icon_process {targetkit rt_target rtname kit_type sourcefolder vfstail raw_runtime bakefolder} { |
|
set repo_root [file dirname $sourcefolder] |
|
set override_icon $sourcefolder/vfs/$vfstail/punkshell.ico |
|
if {[file isfile $override_icon]} { |
|
set icon_origin override |
|
set icon_path $override_icon |
|
} else { |
|
set icon_origin default |
|
set icon_path $sourcefolder/runtime/punkshell.ico |
|
} |
|
set have_icon [file isfile $icon_path] |
|
#RT_GROUP_ICON name policy (G-128, user decision 2026-07-29): derived from |
|
#the icon FILE's rootname, uppercased per the RC convention - punkshell.ico |
|
#gives PUNKSHELL for the default icon and for per-kit overrides alike |
|
#(overrides are by convention also named punkshell.ico). Applied by |
|
#whichever mechanism embeds; language stays adopted from the replaced group. |
|
set icon_group "" |
|
if {$have_icon} { |
|
set icon_group [string toupper [file rootname [file tail $icon_path]]] |
|
} |
|
set embedding none |
|
set status "" |
|
set reason "" |
|
if {![string match "win32-*" $rt_target]} { |
|
set status not-applicable |
|
set reason "target $rt_target has no PE resources" |
|
} elseif {$rtname eq "-"} { |
|
set status not-applicable |
|
set reason "runtimeless .kit artifact has no PE container" |
|
} elseif {$kit_type in {cookit cookfs}} { |
|
set status unavailable |
|
set reason "kit type $kit_type edits the payload in place inside the mounted runtime - no payload-free stub moment to stamp" |
|
} elseif {!$have_icon} { |
|
set status unavailable |
|
set reason "icon file not found at $icon_path" |
|
} elseif {$raw_runtime in {{} -} || ![file isfile $raw_runtime]} { |
|
set status unavailable |
|
set reason "extraction produced no raw runtime prefix to stamp" |
|
} else { |
|
#mechanism selection (G-128): the portable stamper when built, else the |
|
#twapi arm; only when neither serves does the step skip - the combined |
|
#reason names both gaps and the punkres build remedy |
|
lassign [::punkboot::kiticon::punkres_available $repo_root] punkres_ok punkres_info |
|
if {!$punkres_ok} { |
|
lassign [::punkboot::kiticon::twapi_available] twapi_ok twapi_reason |
|
if {!$twapi_ok} { |
|
set status unavailable |
|
set reason "$twapi_reason; $punkres_info" |
|
} |
|
} |
|
} |
|
set wrap_runtime $raw_runtime |
|
if {$status eq ""} { |
|
set stamped $bakefolder/iconed_$targetkit |
|
file copy -force $raw_runtime $stamped |
|
catch {exec chmod +w $stamped} |
|
if {$punkres_ok} { |
|
set embedding punkres |
|
set embed_cmd [list ::punkboot::kit_icon_embed_punkres $punkres_info $stamped $icon_path $icon_group] |
|
} else { |
|
set embedding twapi |
|
set embed_cmd [list ::punkboot::kit_icon_embed_twapi $stamped $icon_path $icon_group] |
|
} |
|
if {[catch $embed_cmd embed_result]} { |
|
::punkboot::print_bake_warnings [list "kit icon embedding FAILED for $targetkit ($icon_origin icon $icon_path via $embedding): $embed_result - kit keeps its runtime's own icon"] |
|
set status failed |
|
set reason $embed_result |
|
catch {file delete $stamped} |
|
} else { |
|
set status embedded |
|
set wrap_runtime $stamped |
|
puts stdout " kit icon (G-057): embedded $icon_origin icon into $targetkit stub via $embedding ($embed_result images from [file tail $icon_path])" |
|
} |
|
} elseif {$status eq "not-applicable"} { |
|
puts stdout " kit icon (G-057): embedding NOT APPLICABLE for $targetkit - $reason (sidecar still written)" |
|
} else { |
|
puts stdout " kit icon (G-057): embedding UNAVAILABLE for $targetkit - $reason (sidecar still written)" |
|
} |
|
set esc ::punkboot::kiticon::toml_escape |
|
set lines [list] |
|
lappend lines "# kit resource record (schema 1) for the kit artifact named by this file" |
|
lappend lines "# with the .resources.toml suffix stripped. Emitted by the make.tcl bake" |
|
lappend lines "# icon step (G-057). Optional and advisory; format: bin/AGENTS.md." |
|
lappend lines "schema = 1" |
|
lappend lines "kit = \"[$esc $targetkit]\"" |
|
lappend lines "target = \"[$esc $rt_target]\"" |
|
lappend lines "kit_type = \"[$esc $kit_type]\"" |
|
lappend lines "icon_origin = \"$icon_origin\"" |
|
lappend lines "icon_source = \"[$esc [punkcheck::lib::path_relative $repo_root $icon_path]]\"" |
|
if {$have_icon} { |
|
lappend lines "icon_hash = \"sha256:[::punkboot::kiticon::sha256_file $icon_path]\"" |
|
set ao [::punkboot::kiticon::assetorigin_read $icon_path] |
|
if {[dict exists $ao source]} { |
|
lappend lines "icon_provenance_source = \"[$esc [dict get $ao source]]\"" |
|
} |
|
if {[dict exists $ao source_hash]} { |
|
lappend lines "icon_provenance_source_hash = \"[$esc [dict get $ao source_hash]]\"" |
|
} |
|
lappend lines "icon_group = \"[$esc $icon_group]\"" |
|
} |
|
lappend lines "embedding = \"$embedding\"" |
|
lappend lines "embedding_status = \"$status\"" |
|
lappend lines "embedding_reason = \"[$esc $reason]\"" |
|
set sidecar $bakefolder/$targetkit.resources.toml |
|
::punkboot::kiticon::writefile_ifchanged $sidecar "[join $lines \n]\n" |
|
return [list $wrap_runtime $sidecar] |
|
} |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
set startdir [pwd] |
|
puts stdout "Found [llength $vfs_tails] .vfs folders - checking each for executables that may need to be built" |
|
cd [file dirname $bakefolder] |
|
#root folder mtime is insufficient for change detection. Tree mtime of folders only is a barely passable mechanism for vfs change detection in some circumstances - e.g if files added/removed but never edited in place |
|
#a hash of full tree file & dir mtime may be more reasonable - but it remains to be seen if just tar & checksum is any/much slower. |
|
#Simply rebuilding all the time may be close the speed of detecting change anyway - and almost certainly much faster when there is a change. |
|
#Using first mtime encountered that is later than target is another option - but likely to be highly variable in speed. Last file in the tree could happen to be the latest, and this mechanism doesn't handle re-bake on reversion to older source. |
|
set exe_names_seen [list] |
|
set path_cksum_cache [dict create] |
|
dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/_vfscommon.vfs] |
|
|
|
# |
|
# loop over vfs_tails and for each one, loop over configured (or matching) runtimes - bake with sdx or zipfs if source .vfs or source runtime exe has changed. |
|
# we are using punkcheck to install result to bakefolder so we create a .punkcheck file at the target folder to store metadata. |
|
# punkcheck allows us to not rely purely on timestamps (which may be unreliable) |
|
# |
|
foreach vfstail $vfs_tails { |
|
|
|
set vfsname [file rootname $vfstail] |
|
puts stdout " ------------------------------------" |
|
puts stdout " checking vfs $sourcefolder/vfs/$vfstail for configured runtimes" |
|
set skipped_vfs_bake 0 |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
set basedir $bakefolder |
|
set config [dict create {*}{ |
|
-make-step bake_vfs |
|
}] |
|
|
|
|
|
#G-122: a runtime's filename and store tier come from ITS target platform. |
|
#The '-' pseudo-runtime (unwrapped .kit output) carries no file at all. |
|
set runtimes [list] |
|
if {[dict exists $vfs_runtime_map $vfstail]} { |
|
#set runtimes [dict get $vfs_runtime_map $vfstail] |
|
#runtimes in vfs_runtime_map_vfs dict are unsuffixed (.exe stripped or was not present) |
|
set applist [dict get $vfs_runtime_map $vfstail] |
|
foreach rt_app $applist { |
|
set rt [lindex $rt_app 0] |
|
if {$rt eq "-"} { |
|
#the '-' (runtime-less .kit) pseudo-runtime has never reached this |
|
#list - both historical branches filtered it out - so the loop |
|
#below's '-' handling is currently unreachable. Left as-is: |
|
#enabling it is a separate, untested change. |
|
continue |
|
} |
|
set rt_target [punkboot::lib::runtime_target_of $rt] |
|
set rt_file $rt[punkboot::lib::platform_exe_suffix $rt_target] |
|
if {$rt_file in $runtimes} { |
|
continue ;#several entries may share a runtime on one vfs (toml models) - |
|
#process each runtime once (its spec set enumerates all its kits) |
|
} |
|
if {[file exists $rtbase/[punkboot::lib::platform_store_tier $rt_target]/$rt_file]} { |
|
lappend runtimes $rt_file |
|
} |
|
} |
|
} else { |
|
#only match this vfs to a correspondingly named runtime if there was no explicit entry for that runtime |
|
#review - should this only be done if there are NO explicit entries? how does a user stop bakes of unneeded exes that match without renaming files/folders? |
|
#but conversely, adding an extra entry shouldn't stop default builds that used to run.. |
|
set matchrt [file rootname [file tail $vfstail]] ;#e.g project.vfs -> project |
|
if {![dict exists $runtime_vfs_map $matchrt]} { |
|
#unmapped: the default-target store is the only place a name-match is looked for |
|
if {[file exists $rtfolder/$matchrt$rt_exe_suffix]} { |
|
lappend runtimes $matchrt$rt_exe_suffix |
|
} |
|
} |
|
} |
|
#assert $runtimes is a list of runtime filenames as they exist in their target's store tier |
|
#(suffixed with .exe for windows-family targets, whether or not mapvfs.config spelled it that way) |
|
|
|
puts " vfs: $vfstail runtimes to process ([llength $runtimes]): $runtimes" |
|
set startup_collision 0 |
|
set startup_collision_report [dict create] |
|
if {[llength $runtimes]} { |
|
#only check startup script for .vfs folders that will actually be built against a runtime |
|
#(e.g _vfscommon.vfs is a merge overlay with no runtime mapping and legitimately has no main.tcl) |
|
set startup_warning [vfs_startup_script_warning $sourcefolder/vfs/$vfstail] |
|
if {$startup_warning ne ""} { |
|
::punkboot::print_bake_warnings [list $startup_warning] |
|
} |
|
#G-031 startup-script collision gate verdict for this SOURCE .vfs, consumed |
|
#per-kit below (every kit built from a colliding folder is refused; kits from |
|
#other folders proceed). merge_over's fauxlink branch overwrites without |
|
#warning, so a collision lets traversal order silently decide which boot |
|
#script the built kit carries. |
|
lassign [::punkboot::get_vfs_startup_script_report $sourcefolder/vfs/$vfstail] startup_check_available startup_collision_report |
|
if {!$startup_check_available} { |
|
puts stderr "NOTE: startup-script collision check unavailable (punkboot::utils vfs_startup_script_report not loadable from bootsupport) - continuing without it" |
|
} elseif {[dict get $startup_collision_report status] eq "unchecked"} { |
|
puts stderr "NOTE: startup-script collision check could not run ([dict get $startup_collision_report reason]) - continuing without it" |
|
} elseif {![dict get $startup_collision_report ok]} { |
|
set startup_collision 1 |
|
} |
|
} |
|
#todo - non kit based - zipkit? |
|
# $runtimes may now include a dash entry "-" (from mapvfs.config file) |
|
foreach runtime_fullname $runtimes { |
|
set rtname [punkboot::lib::runtime_mapkey $runtime_fullname] |
|
if {[llength $::punkboot::bake_selected_kitnames] && $rtname ni $::punkboot::bake_selected_runtimes} { |
|
continue ;#G-121 selective bake - no requested kit wraps this runtime |
|
} |
|
#G-122: everything this iteration emits is keyed by the runtime's TARGET |
|
set rt_target [punkboot::lib::runtime_target_of $rtname] |
|
set rt_tierdir $rtbase/[punkboot::lib::platform_store_tier $rt_target] |
|
set rt_suffix [punkboot::lib::platform_exe_suffix $rt_target] |
|
#rtname of "-" indicates build a kit without a runtime |
|
if {$runtime_fullname ne "-"} { |
|
::punkboot::runtime_materialization_warning $rt_tierdir $runtime_fullname |
|
} |
|
|
|
#first configured runtime will be the one to use the same name as .vfs folder for output executable. Additional runtimes on this .vfs will need to suffix the runtime name to disambiguate. |
|
#review: This mechanism may not be great for multiplatform builds ? We may be better off consistently combining vfsname and rtname and letting a later platform-specific step choose ones to install in bin with simpler names. |
|
|
|
set targetkits [list] |
|
|
|
if {[dict exists $runtime_vfs_map $rtname]} { |
|
set applist [dict get $runtime_vfs_map $rtname] |
|
foreach vfs_app $applist { |
|
#5th element = G-133 smoke-require package list ("" when undeclared) |
|
#6th element (toml models) = G-024 entry attrs (group/bake_default/scheme_role) |
|
lassign $vfs_app configured_vfs appname target_kit_type - kit_smokerequires |
|
set kit_attrs [punkboot::lib::mapvfs_spec_attrs $vfs_app] |
|
if {$configured_vfs ne $vfstail} { |
|
continue |
|
} |
|
if {$appname eq ""} { |
|
set appname $vfsname |
|
} |
|
if {$target_kit_type eq ""} { |
|
set target_kit_type "kit" ;#review - we should probably move determining target_kit_type from that of source runtime, and if none, defaulting to zip (zipkit?) |
|
} |
|
if {$rtname eq "-"} { |
|
set targetkit $appname.kit |
|
} else { |
|
set targetkit ${appname}$rt_suffix |
|
if {[list $rt_target $targetkit] in $exe_names_seen} { |
|
#duplicate appname configured for the SAME target? |
|
#(G-127: same-named kits for DIFFERENT targets coexist under |
|
#their own kits/<platform>/ output tiers - only a same-target |
|
#duplicate needs a disambiguating name) |
|
#todo - consider creating as ${appname}(2) etc? |
|
puts stderr "targetkit: $targetkit already seen for target $rt_target - using name ${appname}_$rtname" |
|
set targetkit ${appname}_$rtname |
|
} |
|
} |
|
lappend exe_names_seen [list $rt_target $targetkit] |
|
lappend targetkits [list $targetkit $target_kit_type $kit_smokerequires $kit_attrs] |
|
} |
|
} |
|
puts stdout " vfs: $vfstail runtime: $rtname targetkits: $targetkits" |
|
foreach targetkit_info $targetkits { |
|
if {[llength $::punkboot::bake_selected_kitnames] && [lindex $targetkit_info 0] ni $::punkboot::bake_selected_targetkits} { |
|
continue ;#G-121 selective bake - not a requested kit output |
|
} |
|
puts stdout " processing targetkit: $targetkit_info" |
|
lassign $targetkit_info targetkit target_kit_type kit_smokerequires kit_attrs |
|
#G-127: output locations are keyed by the kit's TARGET. Kits for this |
|
#host's own default target keep the flat locations every launcher, test |
|
#and habit expects (src/_bake/<kit>, bin/<kit>); any other target's kit |
|
#builds and deploys under a kits/<platform>/ tier so same-named kits for |
|
#different targets coexist instead of overwriting each other across |
|
#selective runs. bin/kits/ rather than bin/<platform>/ because |
|
#bin/runtime/<platform>/ already means build INPUTS. |
|
if {$rt_target eq $rt_default_target} { |
|
set kit_bakedir $bakefolder |
|
set kit_deploydir $binfolder |
|
set kit_relpath $targetkit ;#kit path relative to bin/ and src/_bake/ |
|
} else { |
|
set kit_bakedir $bakefolder/kits/$rt_target |
|
set kit_deploydir $binfolder/kits/$rt_target |
|
set kit_relpath kits/$rt_target/$targetkit |
|
} |
|
file mkdir $kit_bakedir |
|
#G-024: bake_default=false entries (declared per entry or via their group) |
|
#are excluded from full bakes - explicit name/@group selection builds them. |
|
if {![llength $::punkboot::bake_selected_kitnames] |
|
&& [dict exists $kit_attrs bake_default] && ![dict get $kit_attrs bake_default]} { |
|
puts stdout " skipping $targetkit (bake_default=false - bake by name or @group to build it)" |
|
lappend skipped_kits [list kit $targetkit reason "bake_default=false (not part of full bakes)"] |
|
continue |
|
} |
|
#G-023/G-024 release gating: a 'versioned' scheme's plain-name output is |
|
#created when absent, then replaced only by an explicit release step |
|
#(G-023 owns that step) - a normal bake never overwrites it. |
|
if {[dict exists $kit_attrs scheme_role] && [dict get $kit_attrs scheme_role] eq "release" |
|
&& [file exists $kit_deploydir/$targetkit]} { |
|
puts stdout " skipping $targetkit (release-gated scheme output: bin/$kit_relpath exists and a normal bake never overwrites it - the explicit release step is G-023; to force a rebuild now, delete bin/$kit_relpath first)" |
|
lappend skipped_kits [list kit $targetkit reason "release-gated (bin/$kit_relpath exists)"] |
|
continue |
|
} |
|
#Self-build guard: never process the kit whose deployed executable is running this |
|
#build - the process sweep below would kill this very process, and the deploy step |
|
#cannot replace a running image anyway. Informational/update subcommands are |
|
#unaffected (they exit before the kit machinery), so driving make.tcl from a built |
|
#punk executable remains supported for everything except rebuilding that executable. |
|
#(a HOST filesystem comparison - case rules follow the host, not the target) |
|
set self_exe [file normalize [info nameofexecutable]] |
|
set self_deploy_target [file normalize $kit_deploydir/$targetkit] |
|
if {$::punkboot::host_windows} { |
|
set is_self_bake [string equal -nocase $self_exe $self_deploy_target] |
|
} else { |
|
set is_self_bake [string equal $self_exe $self_deploy_target] |
|
} |
|
if {$is_self_bake} { |
|
puts stderr "SKIPPING kit $targetkit - its deployed executable is the one running this build ($self_exe)" |
|
puts stderr " Rerun 'make.tcl $::punkboot::command' under tclsh or a different built kit to rebuild $targetkit." |
|
lappend skipped_kits [list kit $targetkit reason "deployed executable is running this build"] |
|
continue |
|
} |
|
#G-031 startup-script collision gate: two root-level suppliers of the name |
|
#main.tcl in the source .vfs mean the baked boot script depends on merge |
|
#traversal order. Refuse the kit BEFORE any build product is written - as |
|
#with the G-125 gate, a previously deployed bin/<kit> must never be |
|
#replaced over an ambiguity; kits from other .vfs folders proceed. |
|
if {$startup_collision} { |
|
set failmsg "startup-script collision in src/vfs/$vfstail - [dict get $startup_collision_report reason]. NOT BUILT and NOT DEPLOYED: any previously deployed $targetkit is untouched" |
|
puts stderr "startup-script collision gate FAILED for kit $targetkit - refusing to bake an ambiguous boot script" |
|
puts stderr " [dict get $startup_collision_report reason]" |
|
lappend failed_kits [list kit $targetkit reason $failmsg] |
|
continue |
|
} |
|
# -- ---------- |
|
set vfs_installer [punkcheck::installtrack new $installername $basedir/.punkcheck] |
|
$vfs_installer set_source_target $sourcefolder $bakefolder |
|
set vfs_event [$vfs_installer start_event {-make-step bake_vfs}] |
|
$vfs_event targetset_init INSTALL $kit_bakedir/$targetkit |
|
set relvfs [punkcheck::lib::path_relative $basedir $sourcefolder/vfs/$vfstail] |
|
if {![dict exists $path_cksum_cache $relvfs]} { |
|
#e.g ../vfs/punk87.vfs {cksum xxxx cksum_all_opts {-cksum_content 1 ... -cksum_algorithm sha1}} |
|
dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/$vfstail] |
|
} |
|
$vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder |
|
$vfs_event targetset_addsource $sourcefolder/vfs/_config ;#some files linked via fauxlink - need to detect change |
|
$vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon.vfs |
|
$vfs_event targetset_addsource $sourcefolder/vfs/$vfstail |
|
if {[file isfile $sourcefolder/runtime/punkshell.ico]} { |
|
#G-057: the default kit icon is a build input - a changed icon rebuilds |
|
#kits (an override icon lives inside the .vfs folder, already a source) |
|
$vfs_event targetset_addsource $sourcefolder/runtime/punkshell.ico |
|
} |
|
if {$rtname ne "-"} { |
|
set baking_runtime $bakefolder/build_$runtime_fullname ;#working copy of runtime executable - (possibly with kit/zipfs/cookfs etc attached!) |
|
$vfs_event targetset_addsource $baking_runtime |
|
set raw_runtime "" ;#building runtime with vfs (zip,kit,cookfs etc stripped) |
|
} else { |
|
set baking_runtime "-" ;#REVIEW |
|
set raw_runtime "-" |
|
} |
|
# -- ---------- |
|
|
|
|
|
set changed_unchanged [$vfs_event targetset_source_changes] |
|
set vfs_or_runtime_changed [expr {[llength [dict get $changed_unchanged changed]] || [llength [$vfs_event get_targets_exist]] < [llength [$vfs_event get_targets]]}] |
|
|
|
if {$vfs_or_runtime_changed} { |
|
#source .vfs folder has changes |
|
$vfs_event targetset_started |
|
# -- --- --- --- --- --- |
|
|
|
if {[file exists $bakefolder/$vfsname.new]} { |
|
puts stderr "deleting existing $bakefolder/$vfsname.new" |
|
file delete $bakefolder/$vfsname.new |
|
} |
|
|
|
package require fileutil |
|
package require fileutil::traverse |
|
package require control |
|
|
|
#keep this a simple name - bin/punk script calls into src/_bake/exename.vfs/main.tcl |
|
#(G-127: non-default-target kits keep the simple name under their kits/<platform>/ tier) |
|
set targetvfs $kit_bakedir/$targetkit.vfs |
|
file delete -force $targetvfs |
|
|
|
set extraction_done 0 |
|
#we switch on the target_kit_type. we could switch on source_kit_type..allowing extraction from one type but writing to another? |
|
#it usually won't make sense to try to convert a runtime kit type to another - unless the runtime happens to support multiple types - |
|
# - but which location would main.tcl be run from? |
|
#todo - check runtime's 'kit_type' and warn/disallow. |
|
#to consider: - allow specifying runtime kits as if they are vfs folders in the normal xxx.vfs list - and autodetect and extract |
|
#would need to detect UPX, cookfs,zipfs,tclkit |
|
set rtmountpoint "" |
|
#Test the capability VALUE, not just its presence: a probe that ran |
|
#reports has_starkit/has_cookfs 0 for a plain zipfs runtime, and |
|
#trying to unwrap such a runtime as a kit ends in sdx mksplit |
|
#failing and REPLACING raw_runtime with the un-split original - |
|
#which silently yields a zip kit with two zips and no tcl_library. |
|
#(Latent until G-122 made the capability probe actually run on |
|
#windows: before that every probe reported find-fail, so this list |
|
#was always empty.) |
|
set caps [dict get $runtime_caps $rtname] |
|
set source_kit_caps [list] |
|
if {[dict exists $caps has_zipfs] && [dict get $caps has_zipfs]} { |
|
lappend source_kit_caps zip |
|
} |
|
if {[dict exists $caps has_starkit] && [dict get $caps has_starkit]} { |
|
lappend source_kit_caps kit |
|
} |
|
if {[dict exists $caps has_cookfs] && [dict get $caps has_cookfs]} { |
|
lappend source_kit_caps cookfs |
|
} |
|
|
|
#make our first try at extraction based on the kit type we are targeting |
|
switch -- $target_kit_type { |
|
zip - zipcat { |
|
set extraction_trylist zip |
|
} |
|
cookit - cookfs { |
|
set extraction_trylist cookfs |
|
} |
|
kit { |
|
set extraction_trylist kit |
|
} |
|
default { |
|
puts stderr "Unexpected target kit_type $kit_type - skipping $runtime_fullname" |
|
continue |
|
} |
|
} |
|
#also try extracting based on kit types the runtime seems to be capable of handling if the target_kit_type extraction doesn't work |
|
foreach ktype $source_kit_caps { |
|
if {$ktype ni $extraction_trylist} { |
|
lappend extraction_trylist $ktype |
|
} |
|
} |
|
|
|
#Assumption: a source runtime can/will only have 1 type of vfs attached |
|
#While a runtime may support mounting more than one type - it is highly unlikely to support booting based on the type of vfs attached! |
|
# e.g a tcl9 tclkit will be likely to have zipfs capability as well as starkit - but will only initialize from a starkit vfs |
|
|
|
#Unknown if it's possible for multiple vfs data segments of different types in the one executable - but such a monstrosity is probably undesirable(?). |
|
#It is quite possible to have more than one zip at the end of an exe - but as the capabilities of zip utilities in the wild to handle such a situation |
|
#vary as far as how they behave - this too is most likely best considered as something to avoid. |
|
|
|
set extract_kit_type "" |
|
while {!$extraction_done && [llength $extraction_trylist]} { |
|
set extract_kit_try [lpop extraction_trylist 0] |
|
switch -- $extract_kit_try { |
|
zip - zipcat { |
|
#for a zipkit - we need to extract the existing vfs from the runtime |
|
#zipfs mkimg replaces the entire zipped vfs in the runtime - so we need the original data to be part of our targetvfs. |
|
puts stdout "Attempting to extract zip vfs data from $runtime_fullname" |
|
file mkdir $targetvfs |
|
set raw_runtime $bakefolder/raw_$runtime_fullname |
|
|
|
if {[info commands ::tcl::zipfs::mount] ne ""} { |
|
#the driving tcl has zipfs |
|
set rtmountpoint //zipfs:/rtmounts/$runtime_fullname |
|
|
|
if {![file exists $rtmountpoint]} { |
|
if {[catch { |
|
tcl::zipfs::mount $baking_runtime rtmounts/$runtime_fullname |
|
} errM]} { |
|
puts stderr "Failed to mount $baking_runtime using standard api. Err:$errM\n trying reverse args on tcl::zipfs::mount..." |
|
if {[catch { |
|
tcl::zipfs::mount rtmounts/$runtime_fullname $baking_runtime |
|
} errM]} { |
|
puts stderr "ALSO Failed to mount $baking_runtime using reverse args to api. Err:$errM - no mountable zipfs on runtime?" |
|
} |
|
} |
|
} |
|
|
|
#strip any existing zipfs on the runtime.. |
|
#2024 - 'zipfs info //zipfs:/mountpoint' is supposed to give us the offset - but it doesn't if the exe has been 'adjusted' to use file offsets. |
|
#which unfortunately Tcl does by default after the 2021 'fix' :( |
|
#https://core.tcl-lang.org/tcl/tktview/aaa84fbbc5 |
|
|
|
if {[file exists $rtmountpoint]} { |
|
#merge_over source -> target |
|
merge_over $rtmountpoint $targetvfs |
|
set extraction_done 1 |
|
#see if we can extract the exe part |
|
set baseoffset [lindex [tcl::zipfs::info $rtmountpoint] 3] |
|
if {$baseoffset != 0} { |
|
#tcl was able to determine the compressed-data offset |
|
#either because runtime is a basic catted exe+zip, or Tcl fixed 'zipfs info' |
|
set fdrt [open $baking_runtime r] |
|
chan configure $fdrt -translation binary |
|
set exedata [read $fdrt $baseoffset] ;#may include stored password and ending header // REVIEW - strip it? |
|
close $fdrt |
|
set fdraw [open $raw_runtime w] |
|
chan configure $fdraw -translation binary |
|
puts -nonewline $fdraw $exedata |
|
close $fdraw |
|
} else { |
|
#presumably the supplied baking_runtime has had its offsets adjusted so that it all appears within offsets off the zip. (file relative offsets) |
|
#due to zipfs info bug - zipfs now can't tell us the offset of the compressed data. |
|
#we need to use a similarly assumptive method as tclZipfs.c uses to determine the start of the compressed contents |
|
package require punk::zip |
|
#we don't technically need to extract the raw exe for 'zip' - as zipfs mkimg can work on the combined file (ignores zip) |
|
# - but for consistency we want raw_runtime to be emitted in the filesystem. |
|
file delete $raw_runtime |
|
punk::zip::extract_preamble $baking_runtime $raw_runtime |
|
} |
|
} else { |
|
#the input baking_runtime wasn't mountable as a zip - so presumably a plain executable |
|
#runtime executable possibly with kit/cookfs etc attached? |
|
#If not - init.tcl probably won't be found? should we even proceed ?? |
|
puts stderr "[punkboot::sgr 31]WARNING the runtime was not mountable as a zip - which means tcl_library was not extracted - the executable may not work with zipfs attached![punkboot::sgr]" |
|
file copy -force $baking_runtime $raw_runtime |
|
} |
|
} else { |
|
#The driving tcl we are calling with doesn't have zipfs - can't mount. |
|
#punk::zip reads the attached archive with stock Tcl only (G-124), |
|
#so this path needs no zipfs, no vfs::zip and no tcllib. |
|
package require punk::zip |
|
puts stdout "tcl shell '[info nameofexecutable]' being used to build doesn't have zipfs - reading the runtime's attached archive with punk::zip" |
|
set extractedzipfolder $bakefolder/extracted_$runtime_fullname |
|
file delete $raw_runtime |
|
file delete -force $extractedzipfolder |
|
if {![catch { |
|
#Split off the executable prefix - the kit assembly needs it as a |
|
#file. The MEMBERS are then read from the ORIGINAL runtime at its |
|
#derived base offset: a runtime whose offsets are file-relative |
|
#splits into a .zip no plain zip reader accepts, and reading the |
|
#whole file sidesteps that intermediate entirely. |
|
punk::zip::extract_preamble $baking_runtime $raw_runtime |
|
punk::zip::unzip -return none -- $baking_runtime $extractedzipfolder |
|
} extracterr]} { |
|
set extraction_done 1 |
|
set extract_kit_type $extract_kit_try |
|
#todo - verify that init.tcl etc are present? |
|
merge_over $extractedzipfolder $targetvfs |
|
} else { |
|
#Do not swallow the reason: without the runtime's own |
|
#zip contents the built kit has no tcl_library. |
|
puts stderr "zipfs-less extraction of $runtime_fullname FAILED: $extracterr" |
|
} |
|
} |
|
|
|
} |
|
cookit - cookfs { |
|
#upx easy enough to deal with if we have/install a upx executable (avail on windows via scoop, freshports for freebsd and presumably various for linux) |
|
# ------------------------------------------------------ |
|
#we can't use cookfs with arbitrary tclsh/kits - needs cookit not just cookfs |
|
# ------------------------------------------------------ |
|
#cookfs seems to need compilation - we would need to be able to build for windows,linux,freebsd,macosx at a minimum. |
|
#preferably vi cross-compile using zig. |
|
#cookit also |
|
|
|
#If our calling executable is also a cookit, or has cookfs package available we can manipulate the cookit runtime here |
|
#(e.g we have it as a loadable module for tcl9 on windows in some runtimes - todo) |
|
if {[catch {package require cookfs} version]} { |
|
puts stderr "cookit/cookvfs unsupported - unable to load cookfs" |
|
puts stderr " - Try running make.tcl using a cookkit binary (e.g put it in <projectdir>/bin) or installing the cookfs binary module or tcl-cookfs module" |
|
} else { |
|
puts stdout "Attempting to extract existing cookfs data from $runtime_fullname" |
|
file mkdir $targetvfs |
|
#Mount it in the currently running executable |
|
#REVIEW - it seems to work to pick a pseudovol name like //cookfstemp:/ |
|
#unlike cookit's //cookit:/ it doesn't show up in file volumes |
|
#set rtmountpoint //cookfstemp:/rtmounts/$runtime_fullname ;#not writable with 'file mkdir' which doesn't seem to handle intermediate nonexistant path |
|
set rtmountpoint //cookfstemp:/$runtime_fullname |
|
cookfs::Mount $baking_runtime $rtmountpoint |
|
if {[file exists $rtmountpoint]} { |
|
#copy from mounted runtime's vfs to the filesystem vfs |
|
merge_over $rtmountpoint $targetvfs |
|
set extraction_done 1 |
|
set extract_kit_type $extract_kit_try |
|
} |
|
} |
|
} |
|
kit { |
|
if {!$have_sdx} { |
|
puts stderr "no sdx available to unwrap $targetkit" |
|
#don't add to failed_kits here |
|
#extraction fail for one type doesn't mean we have fully failed yet |
|
#lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"] |
|
#$vfs_event targetset_end FAILED |
|
#$vfs_event destroy |
|
#$vfs_installer destroy |
|
continue ;#to next extraction attempt |
|
|
|
} |
|
set raw_runtime $bakefolder/raw_$runtime_fullname |
|
#for a kit, we shouldn't need to extract the existing vfs from the runtime. |
|
# - the sdx merge process should be able to merge our .vfs folder with the existing contents. |
|
#2025 - in practice this doesn't always seem to be the case? Review - could have been cwd issue? |
|
puts stdout "Attempting to split kitfile using: $::sdxpath mksplit $baking_runtime" |
|
set prev_cwd [pwd] |
|
cd [file dirname $baking_runtime] ;#make sure SDX is called with the same working dir as the files we're working on. |
|
if {[catch {exec {*}$::sdxpath mksplit $baking_runtime} mksplitresult]} { |
|
#executable doesn't have kit vfs attached |
|
puts stderr "No kit data extracted from $baking_runtime" |
|
file copy -force $baking_runtime $raw_runtime |
|
} else { |
|
puts stdout "mksplitresult: $mksplitresult" |
|
if {![file exists [file rootname $baking_runtime].tail]} { |
|
error "mksplit didn't produce file at [file rootname $baking_runtime].tail" |
|
} |
|
file delete -force [file rootname $baking_runtime].vfs ;#ensure target for unwrap doesn't exist |
|
#set kit_bare_runtime [file rootname $baking_runtime].head |
|
set baking_runtime [file rootname $baking_runtime].head |
|
exec {*}$::sdxpath unwrap [file rootname $baking_runtime].tail ;#extracts to folder named [file rootname $baking_runtime].vfs e.g build_tclkit9.0.2-win64-dyn.vfs |
|
#file rename to existing target dir would copy folder into target dir |
|
if {![file exists $targetvfs]} { |
|
#delay |
|
after 1000 |
|
file rename [file rootname $baking_runtime].vfs $targetvfs |
|
} else { |
|
merge_over [file rootname $baking_runtime].vfs $targetvfs |
|
} |
|
set extraction_done 1 |
|
set extract_kit_type $extract_kit_try |
|
file copy -force $baking_runtime $raw_runtime |
|
} |
|
cd $prev_cwd |
|
|
|
} |
|
} |
|
} ;#end while !$extraction_done && [llength $extraction_trylist] |
|
|
|
set extraction_tried "$target_kit_type[expr {[llength $source_kit_caps] ? " + runtime caps $source_kit_caps" : ""}]" |
|
if {!$extraction_done} { |
|
#TODO: if not extracted - use a default tcl_library for patchlevel and platform? |
|
#Recapped BAKE-WARNING (not just an inline note): this line would |
|
#otherwise scroll away behind thousands of merge lines. It is a warning |
|
#rather than the failure itself because a .vfs that supplies its own tcl |
|
#library needs no extraction - the G-125 gate below decides, on the |
|
#merged tree, whether this kit can initialise. |
|
::punkboot::print_bake_warnings [list "No extraction done from runtime $runtime_fullname (tried: $extraction_tried) - kit $targetkit gets no tcl library from the runtime, so it will FAIL the boot-precondition gate unless src/vfs/$vfstail supplies one"] |
|
file mkdir $targetvfs |
|
} |
|
|
|
#set wrapvfs $sourcefolder/$vfs |
|
set kit_type_mismatch 0 |
|
switch -- $extract_kit_type { |
|
zip { |
|
if {$target_kit_type ni {zip zipcat}} { |
|
set kit_type_mismatch 1 |
|
} |
|
} |
|
kit { |
|
if {$target_kit_type ne "kit"} { |
|
set kit_type_mismatch 1 |
|
} |
|
} |
|
cookfs { |
|
if {$target_kit_type ni {cookfs cookit}} { |
|
set kit_type_mismatch 1 |
|
} |
|
} |
|
} |
|
if {$kit_type_mismatch} { |
|
puts stderr "--------------------------------------------" |
|
puts stderr "WARNING: mismatch between kit type of source runtime [punk::ansi::a brightyellow]$extract_kit_type[punk::ansi::a] and target kit type [punk::ansi::a brightyellow]$target_kit_type[punk::ansi::a]" |
|
puts stderr "The resulting kit is unlikely to initialise" |
|
puts stderr "--------------------------------------------" |
|
#G-030 prompt policy: only an interactive 'y' can force building a mismatched |
|
#kit - non-interactive runs (and -confirm 0) skip this kit and continue. |
|
set _bake_anyway 0 |
|
if {!$::punkboot::opt_confirm} { |
|
puts stderr "skipping kit $targetkit (source/target kit type mismatch; -confirm 0 policy is to skip)" |
|
} elseif {![::punkboot::lib::stdin_is_interactive]} { |
|
puts stderr "skipping kit $targetkit (source/target kit type mismatch and stdin is not interactive)" |
|
} else { |
|
puts stdout "Continue to try to build $targetkit from $rtname anyway? y|n" |
|
if {[string tolower [string trim [gets stdin]]] eq "y"} { |
|
set _bake_anyway 1 |
|
} |
|
} |
|
if {!$_bake_anyway} { |
|
#skip to next kit |
|
continue |
|
} |
|
puts proceeding... |
|
} |
|
|
|
if {[file exists $sourcefolder/vfs/_vfscommon.vfs]} { |
|
puts stdout "Merging _vfscommon.vfs over $targetvfs" |
|
#the original boot.tcl and icon etc can be overridden by entries in our common and custom vfs folders |
|
#merge_over will emit warnings on stderr for overwritten files |
|
merge_over $sourcefolder/vfs/_vfscommon.vfs $targetvfs |
|
} |
|
|
|
set sourcevfs [file join $sourcefolder vfs $vfstail] |
|
merge_over $sourcevfs $targetvfs |
|
|
|
#G-127 per-platform payload selection: the VFSPAYLOAD phase stages |
|
#%platform% payload entries under _targets/<platform>/ in the .vfs |
|
#folder (one subtree per consuming kit target), and the merge above |
|
#carried that staging tree into the image. Select THIS kit's target |
|
#subtree into the image root and drop the staging tree, so the |
|
#assembled kit carries only its own target's payload - upstream of |
|
#the arch scan and the G-125 gate, which must judge the final tree. |
|
if {[file isdirectory $targetvfs/_targets]} { |
|
set _pstaging ${targetvfs}._targets_staging |
|
file delete -force $_pstaging |
|
file rename $targetvfs/_targets $_pstaging |
|
if {[file isdirectory $_pstaging/$rt_target]} { |
|
puts stdout " per-platform payload (G-127): selecting _targets/$rt_target into the merged image for kit $targetkit" |
|
merge_over $_pstaging/$rt_target $targetvfs |
|
} else { |
|
::punkboot::print_bake_warnings [list "per-platform payload (G-127): kit $targetkit (target $rt_target) - the merged vfs has a _targets/ staging tree but no _targets/$rt_target subtree, so this kit gets NO per-platform payload (check the %platform% declarations in src/vfs/$vfstail.toml against the kit's mapvfs target)"] |
|
} |
|
file delete -force $_pstaging |
|
} |
|
|
|
#G-133 advisory payload/target binary-arch scan, at the same post-merge |
|
#seam as the G-125 gate below. Structural (header bytes only, nothing |
|
#executed), so it runs for every kit including cross-target ones. A |
|
#binary library under a platform-discriminated subdir (win32-ix86/, |
|
#win-x64/ etc) is exempt - multi-arch payloads are legitimate there. |
|
#ADVISORY by design: vendor layouts make false certainty unavoidable, |
|
#so mismatches warn (recapped) and the kit still builds - the G-125 |
|
#gate below stays the only refusal at this seam. |
|
lassign [::punkboot::get_vfs_binary_arch_report $targetvfs $rt_target] archscan_available archscan |
|
if {!$archscan_available} { |
|
puts stderr "NOTE: kit payload binary-arch scan unavailable (punkboot::utils vfs_binary_arch_report not loadable from bootsupport) - continuing without it" |
|
} elseif {[dict get $archscan reason] ne ""} { |
|
puts stdout " payload binary-arch scan not applicable for kit $targetkit: [dict get $archscan reason]" |
|
} elseif {[llength [dict get $archscan mismatches]]} { |
|
set archscan_mismatches [dict get $archscan mismatches] |
|
set archwarnings [list] |
|
set shown 0 |
|
foreach m $archscan_mismatches { |
|
if {$shown >= 8} {break} |
|
incr shown |
|
lappend archwarnings "payload/target arch mismatch in kit $targetkit (target $rt_target): [dict get $m file] is [dict get $m detail] outside any platform-discriminated subdir - a $rt_target runtime cannot load it" |
|
} |
|
if {[llength $archscan_mismatches] > $shown} { |
|
lappend archwarnings "payload/target arch mismatch in kit $targetkit (target $rt_target): [expr {[llength $archscan_mismatches] - $shown}] further mismatching binary libraries not listed above ([llength $archscan_mismatches] mismatches total, [dict get $archscan scanned] binary libraries scanned)" |
|
} |
|
::punkboot::print_bake_warnings $archwarnings |
|
unset archwarnings archscan_mismatches shown |
|
} else { |
|
puts stdout " payload binary-arch scan for kit $targetkit (target $rt_target): OK - [dict get $archscan scanned] binary libraries scanned ([dict get $archscan matched] match target, [dict get $archscan exempt] exempt under platform subdirs, [dict get $archscan unknown] unclassifiable)" |
|
} |
|
|
|
#G-125 boot-precondition gate. A kit with no tcl library cannot initialise |
|
#at all - 'Cannot find a usable init.tcl' - so refuse it HERE: before any |
|
#build product is written, and long before the deploy step deletes the |
|
#previously working bin/<kit> and copies the new one over it. The check is |
|
#on the MERGED tree rather than on whether extraction ran, because a .vfs |
|
#that supplies its own tcl library is legitimate and must keep building |
|
#(src/vfs/punk8_statictwapi.vfs and punk9test.vfs are such folders today). |
|
#Structural and non-executing, so it also covers cross-target kits, which |
|
#this host could never run. |
|
lassign [::punkboot::get_vfs_boot_library_report $targetvfs] bootcheck_available bootcheck |
|
if {!$bootcheck_available} { |
|
puts stderr "NOTE: kit boot-precondition check unavailable (punkboot::utils vfs_boot_library_report not loadable from bootsupport) - continuing without it" |
|
} elseif {![dict get $bootcheck ok]} { |
|
if {$extraction_done} { |
|
#extract_kit_type is only recorded by some of the extraction branches |
|
set extractedas [expr {$extract_kit_type ne "" ? " (as $extract_kit_type)" : ""}] |
|
set gatecause "extraction from runtime $runtime_fullname$extractedas ran but supplied no tcl library, and src/vfs/$vfstail does not supply one either" |
|
} else { |
|
set gatecause "nothing was extracted from runtime $runtime_fullname (tried: $extraction_tried) and src/vfs/$vfstail does not supply a tcl library" |
|
} |
|
set failmsg "kit cannot initialise - $gatecause. Checked [join [dict get $bootcheck checked] { and }] in the merged vfs; [dict get $bootcheck reason]. NOT BUILT and NOT DEPLOYED: any previously deployed $targetkit is untouched" |
|
puts stderr "boot-precondition gate FAILED for kit $targetkit - refusing to build an artifact that cannot initialise" |
|
puts stderr " $gatecause" |
|
lappend failed_kits [list kit $targetkit reason $failmsg] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} |
|
|
|
#G-025 kit stamp: build provenance embedded at the payload root so the |
|
#built executable answers for itself whatever it is later named. Read |
|
#by punk::buildinfo (kit 'buildinfo' subcommand / in-shell command); |
|
#a distinct namespaced file beside the runtime layer's own |
|
#punkbin-artifact.toml record (G-117), which is read alongside it. |
|
#Written AFTER the boot gate (assembled tree final) and BEFORE image |
|
#assembly; utc_bake only changes when the kit actually reassembles. |
|
apply {{targetvfs projectroot vfstail runtime_fullname targetkit rt_target} { |
|
set stamp_project_version "" |
|
catch { |
|
if {![catch {package require punkboot::utils}]} { |
|
set stamp_project_version [::punkboot::utils::read_punkproject_version [file join $projectroot punkproject.toml]] |
|
} |
|
} |
|
set core_ver "" |
|
set corefile [file join $targetvfs punkboot core.tcl] |
|
if {[file isfile $corefile]} { |
|
set fd [open $corefile r]; set coredata [read $fd]; close $fd |
|
regexp {variable\s+core_version\s+(\S+)} $coredata -> core_ver |
|
} |
|
set rr_name "" |
|
set rr_build_id "" |
|
set rrfile [file join $targetvfs punkbin-artifact.toml] |
|
if {[file isfile $rrfile]} { |
|
set fd [open $rrfile r]; set rrdata [read $fd]; close $fd |
|
set insection 0 |
|
foreach line [split $rrdata \n] { |
|
set trimmed [string trim $line] |
|
if {[string index $trimmed 0] eq "\["} { |
|
set insection [expr {$trimmed eq "\[artifact\]"}] |
|
continue |
|
} |
|
if {!$insection} {continue} |
|
regexp {^name\s*=\s*"([^"]*)"} $trimmed -> rr_name |
|
regexp {^build_id\s*=\s*"([^"]*)"} $trimmed -> rr_build_id |
|
} |
|
} |
|
set lines [list] |
|
lappend lines "#punkshell kit build stamp (G-025 schema 1) - written by 'make.tcl bake'." |
|
lappend lines "#Provenance of THIS kit assembly, read by punk::buildinfo; the input" |
|
lappend lines "#runtime layer's own record is the sibling punkbin-artifact.toml (G-117)." |
|
lappend lines "schema = 1" |
|
lappend lines "" |
|
lappend lines "\[punkkit\]" |
|
lappend lines "project_version = \"$stamp_project_version\"" |
|
lappend lines "vfs = \"$vfstail\"" |
|
lappend lines "runtime = \"$runtime_fullname\"" |
|
if {$rr_build_id ne ""} { |
|
lappend lines "runtime_build_id = \"$rr_build_id\"" |
|
} |
|
if {$rr_name ne ""} { |
|
lappend lines "runtime_artifact = \"$rr_name\"" |
|
} |
|
lappend lines "kit = \"$targetkit\"" |
|
lappend lines "target = \"$rt_target\"" |
|
lappend lines "boot_core_version = \"$core_ver\"" |
|
#NO time-of-bake field: the target tree is clean-slate reassembled |
|
#every bake, so a volatile field would make otherwise-identical |
|
#stamps (and kits) differ run to run. Same principle as the G-117 |
|
#embedded records, which keep sha1/size/built in the SIDECAR only - |
|
#time facts belong to punkcheck records and sidecars, not payloads. |
|
set fd [open [file join $targetvfs punkkit-stamp.toml] w] |
|
puts -nonewline $fd "[join $lines \n]\n" |
|
close $fd |
|
puts stdout " kit stamp (G-025): punkkit-stamp.toml (project_version=$stamp_project_version vfs=$vfstail runtime=$runtime_fullname boot_core=$core_ver)" |
|
}} $targetvfs $projectroot $vfstail $runtime_fullname $targetkit $rt_target |
|
|
|
#G-057 kit icon step: sidecar for every kit; PE icon embedding where |
|
#the target has PE resources and this host can write them. Stub-first: |
|
#the assemblers below consume wrap_runtime - the stamped per-kit copy |
|
#of the payload-free raw prefix when embedding happened, the untouched |
|
#raw prefix otherwise. Runtime store originals are never modified. |
|
lassign [::punkboot::kit_icon_process $targetkit $rt_target $rtname $target_kit_type $sourcefolder $vfstail $raw_runtime $kit_bakedir] wrap_runtime kiticon_sidecar |
|
|
|
set wrapvfs $targetvfs |
|
switch -- $target_kit_type { |
|
zip { |
|
#WARNING - 2024-10-08 - zipfs mkimg based exezips are not editable with 7z |
|
# (central directory offset has been 'adjusted' to be file relative) |
|
#This makes finding the split between prefixed exe and zip-data harder for Tcl scripts |
|
#- although zipfs mkimg does it in a somewhat wonky way. |
|
#tclZipfs.c as at 2024 assumes first file header in the CDR points to first local file header and assumes that is the top of the zipdata. |
|
#This is only *mostly* true. order of entries or completeness is not guaranteed. |
|
#e.g topmost file data in zip may not be pointed to if deleted by certain tools. |
|
#for files created by zipfs mkimg and not externally edited - it shouldn't be an issue though. |
|
|
|
if {$rtname eq "-"} { |
|
#todo - just make a zip? |
|
error "runtime name of - unsupported for zip - (todo)" |
|
} |
|
if {[catch { |
|
if {[dict exists $runtime_caps $rtname]} { |
|
if {[dict get $runtime_caps $rtname exitcode] == 0} { |
|
if {![dict get $runtime_caps $rtname has_zipfs]} { |
|
error "runtime $rtname doesn't have zipfs capability" |
|
} |
|
} else { |
|
#could be runtime for another platform |
|
puts stderr "RUNTIME capabilities unknown. Unsure if zip supported. trying anyway.." |
|
} |
|
} |
|
if {[info commands ::tcl::zipfs::mkimg] ne ""} { |
|
#note - as at 2024-08 - there is some discussion about the interface to mkimg - it is considered unstable (may change to -option value syntax) |
|
puts stderr "calling: tcl::zipfs::mkimg $bakefolder/$vfsname.new $wrapvfs $wrapvfs \"\" $wrap_runtime" |
|
tcl::zipfs::mkimg $bakefolder/$vfsname.new $wrapvfs $wrapvfs "" $wrap_runtime |
|
} else { |
|
#G-122: the driving tcl has no zipfs (8.6) - assemble the same |
|
#kind of image by concatenation. The result mounts on any |
|
#zipfs-capable runtime (archive-start-relative offsets). |
|
puts stderr "WARNING: tcl shell '[info nameofexecutable]' has no zipfs - assembling zip kit $targetkit by concatenation (raw runtime + mkzip)" |
|
::punkboot::assemble_zipcat_image $wrap_runtime $wrapvfs $bakefolder/$vfsname.new $bakefolder/$vfsname.zip |
|
} |
|
} result ]} { |
|
set failmsg "zipfs mkimg failed with msg: $result" |
|
puts stderr "tcl::zipfs::mkimg $targetkit failed" |
|
lappend failed_kits [list kit $targetkit reason $failmsg] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} else { |
|
puts stdout "ok - finished zip image assembly" |
|
set separator [string repeat = 40] |
|
puts stdout $separator |
|
puts stdout $result |
|
puts stdout $separator |
|
} |
|
} |
|
zipcat { |
|
#simple catenated runtime + zip - we need an exe runtime with no zipfs attached.. |
|
if {$rtname eq "-"} { |
|
#todo - just make a zip? |
|
error "runtime name of - unsupported for zip - (todo)" |
|
} |
|
if {[catch { |
|
if {[dict exists $runtime_caps $rtname]} { |
|
if {[dict get $runtime_caps $rtname exitcode] == 0} { |
|
if {![dict get $runtime_caps $rtname has_zipfs]} { |
|
error "runtime $rtname doesn't have zipfs capability" |
|
} |
|
} else { |
|
#could be runtime for another platform |
|
puts stderr "RUNTIME capabilities unknown. Unsure if zip supported. trying anyway.." |
|
} |
|
} |
|
|
|
#'archive' based zip offsets - editable in 7z,peazip |
|
::punkboot::assemble_zipcat_image $wrap_runtime $wrapvfs $bakefolder/$vfsname.new $bakefolder/$vfsname.zip |
|
} result ]} { |
|
set failmsg "creating zipcat image failed with msg: $result" |
|
puts stderr "creating image (zipcat) $targetkit failed" |
|
lappend failed_kits [list kit $targetkit reason $failmsg] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} else { |
|
puts stdout "ok - finished zipcat image" |
|
set separator [string repeat = 40] |
|
puts stdout $separator |
|
puts stdout $result |
|
puts stdout $separator |
|
} |
|
|
|
|
|
} |
|
cookit - cookfs { |
|
if {$rtmountpoint eq ""} { |
|
lappend failed_kits [list kit $targetkit reason mount_failed] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} else { |
|
if {[catch { |
|
#we still have the $baking_runtime mounted |
|
if {[catch { |
|
merge_over $targetvfs $rtmountpoint |
|
} errM]} { |
|
puts stderr "$target_kit_type 'merge_over $targetvfs $rtmountpoint' failed\n$errM" |
|
error $errM |
|
} |
|
if {[catch { |
|
cookfs::Unmount $rtmountpoint |
|
} errM]} { |
|
puts stderr "$target_kit_type 'cookfs::Unmount $rtmountpoint' failed\n$errM" |
|
error $errM |
|
} |
|
|
|
#copy the version that is mounted in this runtime to vfsname.new |
|
if {[catch { |
|
file copy -force $baking_runtime $bakefolder/$vfsname.new |
|
catch {exec chmod +w $bakefolder/$vfsname.new} |
|
} errM]} { |
|
puts stderr "$target_kit_type 'file copy -force $baking_runtime $bakefolder/$vfsname.new' failed\n$errM" |
|
error $errM |
|
} |
|
} result]} { |
|
puts stderr "Writing vfs data and opying cookfs file $baking_runtime to $bakefolder/$vfsname.new failed\n $result" |
|
lappend failed_kits [list kit $targetkit reason copy_failed] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} else { |
|
puts stdout "ok - finished for target kit type: $target_kit_type" |
|
set separator [string repeat = 40] |
|
puts stdout $separator |
|
puts stdout $result |
|
puts stdout $separator |
|
} |
|
} |
|
} |
|
kit { |
|
set verbose "" |
|
#set verbose "-verbose" |
|
#assert: baking_runtime has been replaced with $kit_bare_runtime |
|
|
|
set prev_cwd [pwd] |
|
cd [file dirname $baking_runtime] ;#make sure SDX is called with the same working dir as the files we're working on. |
|
if {[catch { |
|
if {$rtname ne "-"} { |
|
exec {*}$::sdxpath wrap $bakefolder/$vfsname.new -vfs $wrapvfs -runtime $wrap_runtime {*}$verbose |
|
} else { |
|
exec {*}$::sdxpath wrap $bakefolder/$vfsname.new -vfs $wrapvfs {*}$verbose |
|
} |
|
} result]} { |
|
if {$rtname ne "-"} { |
|
set sdxmsg "$::sdxpath wrap $bakefolder/$vfsname.new -vfs $wrapvfs -runtime $wrap_runtime {*}$verbose failed with msg: $result" |
|
} else { |
|
set sdxmsg "$::sdxpath wrap $bakefolder/$vfsname.new -vfs $wrapvfs {*}$verbose failed with msg: $result" |
|
} |
|
puts stderr "$::sdxpath wrap $targetkit failed" |
|
lappend failed_kits [list kit $targetkit reason $sdxmsg] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} else { |
|
puts stdout "ok - finished for target kit type: sdx" |
|
set separator [string repeat = 40] |
|
puts stdout $separator |
|
puts stdout $result |
|
puts stdout $separator |
|
} |
|
cd $prev_cwd |
|
} |
|
} |
|
|
|
|
|
if {![file exists $bakefolder/$vfsname.new]} { |
|
puts stderr "|err> make.tcl build didn't seem to produce output at $bakefolder/$vfsname.new" |
|
lappend failed_kits [list kit $targetkit reason "build failed to produce output at $bakefolder/$vfsname.new"] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} |
|
|
|
# -- --- --- |
|
#tasklist doesn't support getting full commandline of processname |
|
#This means we can't be sure we're shutting down the exact required process |
|
#to do this properly we should check the full path for both ps on unix and on windows. (TODO) |
|
#(same exename could be installed somewhere else on the system running a process that shouldn't be shut down here) |
|
#powershell 'get-process' can give us the full path. |
|
#Getting the process list on windows, whether with tasklist or powershell is very slow compared to unix ps. |
|
# e.g 100x slower - apparently that's just the nature of the OS differences (?) |
|
#still - seems to be under 1s on a 2018 era i9 running in 2025 - which is not a big problem in this context. |
|
#using a filter in tasklist or get-command can make things a little faster |
|
|
|
#G-122: the tooling follows the TARGET, not the driving tclsh. |
|
#A win32 kit is a windows process whatever baked it - and msys 'ps' |
|
#sees only msys-descendant processes, so an msys-hosted build using |
|
#'ps' would report a natively-launched kit as not running and then |
|
#fail to replace it. tasklist/taskkill exec fine from an msys tclsh. |
|
#When target and host process worlds differ (a cross-target bake) no |
|
#local process can be holding the artifact - skip the sweep rather |
|
#than run tooling that cannot see the target's processes anyway. |
|
set target_proc_family [punkboot::lib::platform_process_family $rt_target] |
|
set host_proc_family [punkboot::lib::platform_process_family $::punkboot::host_platform] |
|
if {$target_proc_family eq "windows"} { |
|
set pscmd "tasklist" |
|
set pid_field 1 |
|
} else { |
|
set pscmd "ps" |
|
set pid_field 0 |
|
} |
|
set sweep_applicable [expr {$target_proc_family eq $host_proc_family}] |
|
if {!$sweep_applicable} { |
|
puts stdout " (skipping running-process sweep for $targetkit - target $rt_target processes are not visible to this $::punkboot::host_platform host)" |
|
} |
|
|
|
#killing process doesn't apply to .kit build |
|
if {$rtname ne "-" && $sweep_applicable} { |
|
#exec $pscmd | grep $targetkit ;#wrong - fails on at least some OSes because grep itself is in the list |
|
#exec ps | grep $targetkit | grep -v grep ;#exclude grep process |
|
if {![catch { |
|
::punkboot::exec_nativeargs [list $pscmd] |
|
} ps_lines]} { |
|
#we will process without grep for for now - may not be avail on windows? |
|
set still_running_lines [list] |
|
foreach ln [split [string trim $ps_lines] \n] { |
|
if {[string match "* grep *" $ln]} {continue} |
|
if {[string match "*$targetkit*" $ln]} { |
|
#never target the process running this build. Name-only matching |
|
#cannot distinguish an unrelated same-named executable elsewhere on |
|
#the system (see TODO above) - but the build must at least not kill |
|
#itself (e.g a copy of the target executable driving this build from |
|
#a path other than the deploy target, which the self-build guard |
|
#above doesn't catch). |
|
set ln_pid [lindex $ln $pid_field] |
|
if {$ln_pid eq [pid]} {continue} |
|
lappend still_running_lines $ln |
|
} |
|
} |
|
|
|
#set still_running_lines [split [string trim $still_running] \n] |
|
puts stdout "found ([llength $still_running_lines]) $targetkit instances still running\n" |
|
set count_killed 0 |
|
set num_to_kill [llength $still_running_lines] |
|
foreach ln $still_running_lines { |
|
puts stdout " $ln" |
|
|
|
set pid [lindex $ln $pid_field] |
|
if {$target_proc_family eq "windows"} { |
|
if {$forcekill} { |
|
set killcmd [list taskkill /F /PID $pid] |
|
} else { |
|
set killcmd [list taskkill /PID $pid] |
|
} |
|
} else { |
|
#review! |
|
if {$forcekill} { |
|
set killcmd [list kill -9 $pid] |
|
} else { |
|
set killcmd [list kill $pid] |
|
} |
|
} |
|
puts stdout " pid: $pid (attempting to kill now using '$killcmd')" |
|
if {[catch { |
|
::punkboot::exec_nativeargs $killcmd |
|
} errMsg]} { |
|
puts stderr "$killcmd returned an error:" |
|
puts stderr $errMsg |
|
if {!$forcekill} { |
|
puts stderr "(try '[info script] -k' option to force kill)" |
|
} |
|
#avoid exiting if the kill failure was because the task has already exited |
|
#review - *no running instance* works with windows taskkill - "*No such process*" works with kill -9 on FreeBSD and linux - other platforms? |
|
if {![string match "*no running instance*" $errMsg] && ![string match "*No such process*" $errMsg]} { |
|
lappend failed_kits [list kit $targetkit reason "could not kill running process for $targetkit (using '$killcmd')"] |
|
continue |
|
} |
|
} else { |
|
puts stderr "$killcmd ran without error" |
|
incr count_killed |
|
} |
|
} |
|
if {$count_killed < $num_to_kill} { |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} |
|
|
|
puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" |
|
after 1000 |
|
} else { |
|
puts stderr "Ok.. no running '$targetkit' processes found" |
|
} |
|
} |
|
|
|
if {[file exists $kit_bakedir/$targetkit]} { |
|
puts stderr "deleting existing $kit_bakedir/$targetkit" |
|
if {[catch { |
|
file delete $kit_bakedir/$targetkit |
|
} msg]} { |
|
puts stderr "Failed to delete $kit_bakedir/$targetkit" |
|
lappend failed_kits [list kit $targetkit reason "could not delete bakefolder kit at $kit_bakedir/$targetkit"] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} |
|
} |
|
|
|
#WINDOWS filesystem 'tunnelling' (file replacement within 15secs) could cause targetkit to copy ctime & shortname metadata from previous file! |
|
#This is probably harmless - but worth being aware of. |
|
file rename $bakefolder/$vfsname.new $kit_bakedir/$targetkit |
|
# -- --- --- --- --- --- |
|
$vfs_event targetset_end OK |
|
|
|
#G-134 post-assembly offset-style pin: the pipeline emits |
|
#ARCHIVE-relative zip payloads by construction - this probe makes |
|
#that a checked contract. Advisory per the G-133 posture: a |
|
#file-relative image earns a recapped BAKE-WARNING (the G-128 |
|
#stamper would refuse it by default) and the kit still builds and |
|
#deploys; plain/none (no attached zip - the metakit kit shape) and |
|
#unreadable results are silence. One EOCD scan + CD walk per |
|
#REBUILT kit only. |
|
lassign [::punkboot::get_kit_offsetstyle_report $kit_bakedir/$targetkit] offprobe_available offprobe |
|
if {!$offprobe_available} { |
|
puts stderr "NOTE: kit offset-style pin unavailable (punkboot::utils kit_offsetstyle_report not loadable from bootsupport) - continuing without it" |
|
} elseif {[dict get $offprobe offsetstyle] eq "file"} { |
|
::punkboot::print_bake_warnings [list "kit $targetkit assembled with a FILE-relative zip payload (G-134 pin: the pipeline emits archive-relative by construction; the G-128 stamper refuses file-relative by default) - investigate this kit's assembly path"] |
|
} |
|
|
|
#G-133 post-build smoke-require probe. Only an actual 'package require' |
|
#inside the built artifact observes package RESOLUTION - the wrong-arch |
|
#version-shadowing class is invisible to every structural check because |
|
#the working file exists too. Runs only for kits that declare |
|
#smoke-require packages (mapvfs.config 5th entry element) and only when |
|
#this host can execute the artifact; undeclared kits run nothing new. |
|
if {[llength $kit_smokerequires]} { |
|
if {$rtname eq "-"} { |
|
puts stdout " smoke-require skipped for kit $targetkit: a runtimeless .kit artifact is not directly executable" |
|
} elseif {[punkboot::lib::platform_process_family $rt_target] ne [punkboot::lib::platform_process_family $::punkboot::host_platform]} { |
|
puts stdout " smoke-require skipped for kit $targetkit: cross-target ($rt_target) - the artifact is not executable on this $::punkboot::host_platform host" |
|
} else { |
|
puts stdout " smoke-require probe for kit $targetkit (packages: $kit_smokerequires) - executing freshly built artifact via its tclsh subcommand" |
|
::punkboot::kit_smoke_require_probe $kit_bakedir/$targetkit $targetkit $kit_smokerequires |
|
} |
|
} |
|
|
|
} else { |
|
set skipped_vfs_bake 1 |
|
puts stderr "." |
|
puts stdout "Skipping build for vfs $vfstail with runtime $rtname - no change detected" |
|
lappend skipped_kits [list kit $targetkit reason "no change detected"] |
|
$vfs_event targetset_end SKIPPED |
|
} |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
|
|
#Cross-platform kit outputs: RETIRED TODO (G-127 - see |
|
#goals/G-127-crosstarget-vfs-bake.md). Kits for this host's default |
|
#target deploy flat to <project>/bin exactly as always; any other |
|
#target's kit deploys under <project>/bin/kits/<platform>/ (the |
|
#mapping side gained platform names + toml format under G-122/G-024). |
|
after 200 |
|
set deployment_folder $kit_deploydir |
|
file mkdir $deployment_folder |
|
|
|
# -- ---------- |
|
set bin_installer [punkcheck::installtrack new "make.tcl" $deployment_folder/.punkcheck] |
|
$bin_installer set_source_target $bakefolder $deployment_folder |
|
set bin_event [$bin_installer start_event {-make-step final_kit_install}] |
|
$bin_event targetset_init INSTALL $deployment_folder/$targetkit |
|
#todo - move final deployment step outside of the bake vfs loop? (final deployment can fail and then isn't rerun even though _bake and deployed versions differ, unless .vfs modified again) |
|
#set last_completion [$bin_event targetset_last_complete] |
|
|
|
$bin_event targetset_addsource $deployment_folder/$targetkit ;#add target as a source of metadata for change detection |
|
$bin_event targetset_addsource $kit_bakedir/$targetkit |
|
$bin_event targetset_started |
|
# -- ---------- |
|
|
|
set changed_unchanged [$bin_event targetset_source_changes] |
|
set built_or_installed_kit_changed [expr {[llength [dict get $changed_unchanged changed]] || [llength [$bin_event get_targets_exist]] < [llength [$bin_event get_targets]]}] |
|
if {$built_or_installed_kit_changed} { |
|
|
|
if {[file exists $deployment_folder/$targetkit]} { |
|
puts stderr "built or deployed kit changed - deleting existing deployed at $deployment_folder/$targetkit" |
|
if {[catch { |
|
file delete $deployment_folder/$targetkit |
|
} errMsg]} { |
|
puts stderr "deletion of deployed version at $deployment_folder/$targetkit failed: $errMsg" |
|
lappend failed_kits [list kit $targetkit reason "could not delete target binary at $deployment_folder/$targetkit"] |
|
$bin_event targetset_end FAILED -note "could not delete" |
|
$bin_event destroy |
|
$bin_installer destroy |
|
continue |
|
} |
|
} |
|
|
|
puts stdout "copying.." |
|
puts stdout "$kit_bakedir/$targetkit" |
|
puts stdout "to:" |
|
puts stdout "$deployment_folder/$targetkit" |
|
after 300 |
|
file copy $kit_bakedir/$targetkit $deployment_folder/$targetkit |
|
#G-057: the kit resource sidecar ships with the kit |
|
if {[file isfile $kit_bakedir/$targetkit.resources.toml]} { |
|
file copy -force $kit_bakedir/$targetkit.resources.toml $deployment_folder/$targetkit.resources.toml |
|
} |
|
lappend installed_kits $kit_relpath |
|
# -- ---------- |
|
$bin_event targetset_end OK |
|
# -- ---------- |
|
} else { |
|
set skipped_kit_install 1 |
|
puts stderr "." |
|
puts stdout "Skipping kit install for $targetkit with vfs $vfstail runtime $rtname - no change detected" |
|
#G-057: keep the deployed resource sidecar current even when the kit |
|
#itself is unchanged (the record can be newer than the kit rebuild - |
|
#e.g the sidecar feature arriving, or a host-capability change) |
|
if {[::punkboot::kiticon::copy_ifchanged $kit_bakedir/$targetkit.resources.toml $deployment_folder/$targetkit.resources.toml] eq "copied"} { |
|
puts stdout " kit icon (G-057): refreshed deployed sidecar $deployment_folder/$targetkit.resources.toml" |
|
} |
|
lappend skipped_kit_installs [list kit $targetkit reason "no change detected"] |
|
$bin_event targetset_end SKIPPED |
|
} |
|
$bin_event destroy |
|
$bin_installer destroy |
|
|
|
|
|
|
|
} ;#end foreach targetkit |
|
} ;#end foreach rtname in runtimes |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
} |
|
|
|
cd $startdir |
|
if {[llength $installed_kits]} { |
|
puts stdout "INSTALLED KITS: ([llength $installed_kits])" |
|
punk::lib::showdict -channel stdout -roottype list $installed_kits |
|
} |
|
if {[llength $failed_kits]} { |
|
puts stderr "FAILED KITS:([llength $failed_kits])" |
|
punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@* |
|
#puts stderr [join $failed_kits \n] |
|
} |
|
set had_kits [expr {[llength $installed_kits] || [llength $failed_kits] || [llength $skipped_kits]}] |
|
if {$had_kits} { |
|
puts stdout " module mint and kit/zipkit bakes processed (kit mapping: src/runtime/mapvfs.toml)" |
|
puts stdout " - use 'make.tcl modules' to mint modules without baking the vfs folders into executable kits/zipkits" |
|
puts stdout " - use 'make.tcl vfscommonupdate' to promote minted modules into the base vfs folder <projectdir>/src/vfs/_vfscommon.vfs (promotion gate)" |
|
puts stdout " - Note that without the vfscommonupdate step, 'make.tcl bake' (the kit-assembly stage of 'make.tcl bakehouse') will bake vfs based executables" |
|
puts stdout " that include your current custom vfs folders in src/vfs, but with a _vfscommon.vfs that doesn't have the latest minted modules" |
|
puts stdout " calling 'builtexename(.exe) minted' will allow testing of minted modules before they are baked into the kits/zipkits via 'vfscommonupdate' then 'bake'" |
|
} else { |
|
puts stdout " module builds processed" |
|
puts stdout "" |
|
puts stdout " If kit/zipkit based executables required - create src/vfs/<somename>.vfs folders containing lib,modules,modules_tcl9 etc folders" |
|
puts stdout " Also ensure appropriate runtime executables exist in bin/runtime/<platform> along with the kit mapping src/runtime/mapvfs.toml" |
|
} |
|
puts stdout "-done-" |
|
exit 0 |
|
|
|
|
|
|