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.
2164 lines
110 KiB
2164 lines
110 KiB
|
|
#punkboot core - punkshell kit boot core (G-031) |
|
# |
|
#LAYOUT-OWNED, pull-updatable shared machinery - do not fork per project. |
|
#Master: src/vfs/_config/punkboot_core.tcl; delivered into every kit as |
|
#<vfsroot>/punkboot/core.tcl by 'make.tcl vfscommonupdate' (_vfscommon.vfs |
|
#regeneration) and sourced by the kit's thin project-owned main.tcl. |
|
# |
|
#What it does: runtime static-package capture (G-058), vfs mount detection |
|
#(zipfs incl the 8.6 backport family per G-129, metakit/starkit, cookfs), |
|
#package_mode parsing (minted|os|internal|src with the proj: scope prefix, |
|
#G-033), module-path and auto_path assembly, punk::libunknown, src-mode |
|
##modpod registration, then the default subcommand dispatch |
|
#(tclsh/shellspy/punk/shell/script/buildinfo/help) extended by the thin |
|
#main's declared project subcommands (G-031 registration model - see the |
|
#dispatch section near the end of this file). The launch surface documents |
|
#itself via punk::args (G-032): '<punkexe> help ?subcommand?', '-help' and |
|
#'<subcommand> -help' render tabled usage from the moduledoc::punkexe |
|
#definitions plus the live registrations, degrading to a plain subcommand |
|
#list when that stack is unavailable. |
|
# |
|
#The package_mode surface (documented in full by punk::args::moduledoc::punkexe): |
|
#an optional FIRST launch argument of the form minted|os|internal|src or any |
|
#dash-delimited combination such as minted-os, optionally scoped with the |
|
#'proj:' prefix. The default when omitted is 'internal', which limits the |
|
#auto_path and tcl::tm::path to packages provided from within the executable's |
|
#vfs (metakit, zipfs or cookfs based). |
|
# |
|
#SOURCING CONTRACT (what a thin main must do): |
|
# - source this file from inside a one-level frame (an 'apply {args {...}}' |
|
# invoked from the toplevel, as the thin-main skeleton does) - the dispatch |
|
# handlers use 'uplevel 1' to evaluate scripts at the global level. |
|
# - optionally publish in ::punkboot before sourcing: |
|
# launch_args the kit launch arguments (defaults to $::argv) |
|
# main_script normalized path of the kit's root main.tcl - the |
|
# vfs-root derivations key on its location (defaults |
|
# to this file's own path) |
|
# project_subcommands dict: subcommand name -> handler script (see the |
|
# dispatch section; built-ins cannot be shadowed) |
|
# project_subcommand_info dict: subcommand name -> info dict with |
|
# optional keys summary/argsid/package/parse feeding |
|
# the G-032 launcher help + declared-parse wiring |
|
# (see the launcher help section; a name without an |
|
# info entry keeps full passthrough semantics) |
|
# launch_defaults dict: noargs / unknownfirst (see dispatch section) |
|
|
|
# ------------------------------------------------------------------------------ |
|
#Contract preamble - defaults for anything the thin main did not publish, so the |
|
#core also boots a kit when sourced directly as its main.tcl. |
|
# ------------------------------------------------------------------------------ |
|
namespace eval ::punkboot { |
|
#boot-core identity (G-031; stamped into kits + reported by the G-025 |
|
#buildinfo surfaces) |
|
variable core_version 0.3.0 |
|
} |
|
if {![info exists ::punkboot::launch_args]} { |
|
namespace eval ::punkboot [list variable launch_args $::argv] |
|
} |
|
if {![info exists ::punkboot::main_script]} { |
|
namespace eval ::punkboot [list variable main_script [file dirname [file normalize [file join [info script] __dummy__]]]] |
|
} |
|
if {![info exists ::punkboot::project_subcommands]} { |
|
namespace eval ::punkboot {variable project_subcommands [dict create]} |
|
} |
|
if {![info exists ::punkboot::project_subcommand_info]} { |
|
namespace eval ::punkboot {variable project_subcommand_info [dict create]} |
|
} |
|
if {![info exists ::punkboot::launch_defaults]} { |
|
namespace eval ::punkboot {variable launch_defaults [dict create]} |
|
} |
|
#frame-local launch args: the body below (extracted from the monolithic |
|
#punk_main.tcl, which ran as 'apply {args {...}} {*}$::argv') reads $args |
|
set args $::punkboot::launch_args |
|
set ::punkargv $args |
|
set tclmajorv [lindex [split [info tclversion] .] 0] |
|
|
|
# -- runtime static/builtin package capture (G-058) -------------------------------------- |
|
#Runtimes may statically link packages (e.g tcl-sfe: Thread,twapi,sqlite3,tdbc). |
|
#Static registrations are process-global ('load {} <prefix>' works in any interp/thread) |
|
#but 'package require' needs a package-name -> load mapping in EACH interp. A kit's |
|
#appended vfs replaces the runtime's own //zipfs:/app mount, so any pkgIndex.tcl the |
|
#runtime shipped for its statics is gone - and the path setup below controls resolution |
|
#anyway. Capture the static prefixes now, discover the package names/versions each |
|
#provides by loading into a throwaway interp, and record the results in ::punkboot so |
|
#that (a) this interp and (b) every interp/thread punkshell fabricates can seed |
|
#'package ifneeded <name> <ver> {load {} <prefix>}' entries. |
|
#(see punk::lib::interp_sync_package_paths / snapshot_package_paths and the |
|
# punk::packagepreference static-vs-bundled policy) |
|
#Probe-loading is safe for self-contained extensions; static_probe_denylist excludes |
|
#prefixes whose init has side effects (tk* creates '.') or whose package is known to be |
|
#composite (C part + on-disk scripts: vfs, tdbc*, and kit machinery mk4tcl/vlerq) - |
|
#those keep their existing resolution behaviour. Composite statics are ALSO excluded |
|
#naturally: only packages a probe-load actually PROVIDES are recorded, so an init that |
|
#defers to script files which no longer exist (e.g static twapi whose script layer |
|
#lived in the runtime's replaced zip) is never seeded, and any bundled complete copy |
|
#resolves as before. |
|
namespace eval ::punkboot { |
|
variable static_prefixes [list] |
|
variable static_packages [dict create] ;#pkgname -> {version <v> prefix <p>} |
|
variable static_probe_denylist [list tk* vfs mk4tcl vlerq tdbc*] |
|
} |
|
apply {{} { |
|
foreach rec [info loaded] { |
|
lassign $rec fpath prefix |
|
if {$fpath eq "" && $prefix ne ""} { |
|
lappend ::punkboot::static_prefixes $prefix |
|
} |
|
} |
|
if {![llength $::punkboot::static_prefixes]} { |
|
return |
|
} |
|
set probeable [list] |
|
foreach prefix $::punkboot::static_prefixes { |
|
set denied 0 |
|
foreach dpat $::punkboot::static_probe_denylist { |
|
if {[string match -nocase $dpat $prefix]} { |
|
set denied 1 |
|
break |
|
} |
|
} |
|
if {!$denied} { |
|
lappend probeable $prefix |
|
} |
|
} |
|
set probe __punkboot_staticprobe |
|
catch {interp delete $probe} |
|
interp create $probe |
|
#diff on PROVIDED packages (not 'package names' - a probe load can trigger an index |
|
#scan that registers many names as ifneeded without providing them) |
|
set provided_in_probe {{probe} { |
|
set pdict [dict create] |
|
foreach n [interp eval $probe {package names}] { |
|
set pv [interp eval $probe [list package provide $n]] |
|
if {$pv ne ""} { |
|
dict set pdict $n $pv |
|
} |
|
} |
|
return $pdict |
|
}} |
|
#an init may depend on another static - retry failures once |
|
set attempts [list {*}$probeable {*}$probeable] |
|
set done [list] |
|
foreach prefix $attempts { |
|
if {$prefix in $done} { |
|
continue |
|
} |
|
set before_prov [apply $provided_in_probe $probe] |
|
if {[catch {load {} $prefix $probe}]} { |
|
continue |
|
} |
|
lappend done $prefix |
|
dict for {pkgname v} [apply $provided_in_probe $probe] { |
|
if {![dict exists $before_prov $pkgname]} { |
|
dict set ::punkboot::static_packages $pkgname [dict create version $v prefix $prefix] |
|
} |
|
} |
|
} |
|
interp delete $probe |
|
#seed this interp's package db so requires here can resolve to the runtime's own |
|
#copy. Coexisting ifneeded entries (static + any vfs/module copies registered by |
|
#index scans) resolve version-aware under the standard package machinery. |
|
dict for {pkgname pinfo} $::punkboot::static_packages { |
|
if {[package provide $pkgname] eq ""} { |
|
package ifneeded $pkgname [dict get $pinfo version] [list load {} [dict get $pinfo prefix]] |
|
} |
|
} |
|
}} |
|
# -- end runtime static/builtin package capture ------------------------------------------- |
|
|
|
namespace eval ::punkboot { |
|
#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}" |
|
} |
|
proc is_interactive {} { |
|
if {"windows" eq $::tcl_platform(platform) && [package vcompare [info patchlevel] 9.0] == -1} { |
|
#tcl 8.6 etc |
|
if {![catch {package require twapi}]} { |
|
set h_console [twapi::GetStdHandle -10] ;#STD_INPUT_HANDLE |
|
if {[catch {twapi::GetConsoleMode $h_console} result]} { |
|
return 0 |
|
} else { |
|
return 1 |
|
} |
|
} else { |
|
#TODO |
|
#REVIEW |
|
#we have no current way to detect if we are running in a console in tcl 8 on windows without twapi - so we'll assume not interactive for now. |
|
#This implies there is no mechanism for this in early Tcl versions. |
|
#https://stackoverflow.com/questions/43660612/how-to-check-if-stdin-stdout-are-connected-to-a-terminal-in-tcl |
|
#set tcl_interactive 0 |
|
puts stderr "WARNING: is_interactive cannot detect console on Windows Tcl [info patchlevel] without twapi package - probably not interactive" |
|
} |
|
} |
|
|
|
# ----------------------------------- |
|
set stdin_info [chan configure stdin] |
|
if {[dict exists $stdin_info -inputmode]} { |
|
#this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. |
|
# tcl_interactive used by repl to determine if stderr output prompt to be printed. |
|
# (that way, piping commands into stdin should not produce prompts for each command) |
|
#set tcl_interactive 1 |
|
return 1 |
|
} |
|
#however, the -mode option only seems to appear on linux when a terminal exists.. |
|
if {[dict exists $stdin_info -mode]} { |
|
return 1 |
|
} |
|
return 0 |
|
} |
|
proc path_within {path base} { |
|
#1 if $path equals $base or lies under it (path-segment aware; windows |
|
#compares case-insensitively). Both args pre-normalized, forward slashes. |
|
if {$base eq ""} {return 0} |
|
set p $path |
|
set b $base |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
set p [string tolower $p] |
|
set b [string tolower $b] |
|
} |
|
set b [string trimright $b /] |
|
if {$p eq $b} {return 1} |
|
return [string match "$b/*" $p] |
|
} |
|
proc zipfs_mount_pairs {} { |
|
#the zipfs mount table as a flat list of mountpoint,archivefile pairs. |
|
#'tcl::zipfs::mount' (no args) reports that pairing in every zipfs |
|
#generation supported as a kit runtime: the 8.7/9 core zipfs and the |
|
#androwish/undroidwish tcl 8.6 backport (G-129 measured both). |
|
#empty list when zipfs is absent, nothing is mounted, or the table is |
|
#not pairwise (unknown generation - callers treat that as 'cannot |
|
#attribute any mount to this executable'). |
|
if {[info commands ::tcl::zipfs::mount] eq ""} {return [list]} |
|
if {[catch {::tcl::zipfs::mount} mtable]} {return [list]} |
|
if {[llength $mtable] % 2 != 0} {return [list]} |
|
return $mtable |
|
} |
|
proc zipfs_kit_mountbase {} { |
|
#G-129: where is THIS executable's attached archive mounted? |
|
#Returns the mountpoint, or "" when no mount can be attributed to the |
|
#executable. The mount table pairs each mountpoint with the archive file |
|
#mounted there; the entry whose archive file is [info nameofexecutable] |
|
#is this kit's own payload wherever it landed - //zipfs:/app on modern |
|
#runtimes (the compiled-in ZIPFS_APP_MOUNT default), the executable's own |
|
#path on the 8.6 backport family. Measured backport quirk: its |
|
#archive-file column drops the windows drive prefix (/path/to/kit.exe |
|
#for C:/path/to/kit.exe), so that spelling is accepted too. |
|
#Fallback: a mountpoint containing [info script] is the payload this very |
|
#boot is running from, even when the archive-file column is unmatchable. |
|
set mpairs [zipfs_mount_pairs] |
|
if {![llength $mpairs]} {return ""} |
|
set normexe [file dirname [file normalize [file join [info nameofexecutable] __dummy__]]] |
|
set on_windows [expr {"windows" eq $::tcl_platform(platform)}] |
|
if {$on_windows} { |
|
set exe_forms [list [string tolower $normexe]] |
|
if {[string match {[a-zA-Z]:/*} $normexe]} { |
|
lappend exe_forms [string tolower [string range $normexe 2 end]] |
|
} |
|
} else { |
|
set exe_forms [list $normexe] |
|
} |
|
set matched [list] |
|
foreach {mountpoint archivefile} $mpairs { |
|
set f [string map [list \\ /] $archivefile] |
|
if {$on_windows} { |
|
set f [string tolower $f] |
|
} |
|
if {$f in $exe_forms} { |
|
lappend matched $mountpoint |
|
} |
|
} |
|
if {[llength $matched] == 1} { |
|
return [lindex $matched 0] |
|
} |
|
set normscript [file dirname [file normalize [file join [info script] __dummy__]]] |
|
if {[llength $matched] > 1} { |
|
#prefer the mount this very script is booting from |
|
foreach mountpoint $matched { |
|
if {[path_within $normscript $mountpoint]} { |
|
return $mountpoint |
|
} |
|
} |
|
return [lindex $matched 0] |
|
} |
|
foreach {mountpoint archivefile} $mpairs { |
|
if {[path_within $normscript $mountpoint]} { |
|
return $mountpoint |
|
} |
|
} |
|
return "" |
|
} |
|
proc proj_root_find {startdir} { |
|
#G-033: lean boot mirror of punk::repo::find_project (scanup on |
|
#is_project_root) using only Tcl builtins - punk::repo is not loadable at |
|
#the package-mode boot phase. Walks up from $startdir to the nearest VCS |
|
#repo root (git or fossil control markers; 'file exists' sees |
|
#windows-hidden items) that also passes a lean punk::repo::is_candidate_root |
|
#check: not an unwise location, has ./src, and one of ./src/modules, |
|
#./src/vfs, ./src/scriptapps or ./punkproject.toml. Keep the semantics |
|
#aligned with punk::repo so a project findable at boot is findable by the |
|
#runtime layer and vice versa (known divergence: .git is accepted as file |
|
#OR dir - git worktree/submodule checkouts are legitimate visit targets). |
|
#Returns the project root, or "" when no candidate is found. |
|
set unwise_paths [list "/" "/dev" "/bin" "/root" "/etc" "/opt" "/usr" "/usr/local" "/usr/local/bin" "/usr/local/lib" "c:/windows"] |
|
set dir [file normalize $startdir] |
|
while 1 { |
|
set is_repo_root 0 |
|
foreach marker [list .git _FOSSIL_ .fslckout .fos] { |
|
if {[file exists [file join $dir $marker]]} { |
|
set is_repo_root 1 |
|
break |
|
} |
|
} |
|
if {$is_repo_root && [string tolower $dir] ni $unwise_paths} { |
|
if {[file isdirectory [file join $dir src]]} { |
|
if {[file isdirectory [file join $dir src modules]]\ |
|
|| [file isdirectory [file join $dir src vfs]]\ |
|
|| [file isdirectory [file join $dir src scriptapps]]\ |
|
|| [file exists [file join $dir punkproject.toml]]} { |
|
return $dir |
|
} |
|
} |
|
} |
|
set parent [file dirname $dir] |
|
if {$parent eq $dir} { |
|
return "" |
|
} |
|
set dir $parent |
|
} |
|
} |
|
} |
|
|
|
#G-129: key zipfs presence on tcl::zipfs::mount - present in every supported zipfs |
|
#generation - not tcl::zipfs::root (8.7/9-era; absent from the androwish/undroidwish |
|
#8.6 backport, whose ::zipfs ensemble also lacks a root subcommand). |
|
set has_zipfs [expr {[info commands tcl::zipfs::mount] ne ""}] |
|
if {$has_zipfs} { |
|
set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}] |
|
} else { |
|
set has_zipfs_attached 0 |
|
} |
|
#where this executable's attached archive actually mounted ("" when there is no |
|
#attributable mount): //zipfs:/app on modern runtimes, the executable's own path |
|
#on the 8.6 backport family. Factored as its own question about the running kit |
|
#(G-131 grows a metakit arm beside it). |
|
set zipkit_mountbase "" |
|
if {$has_zipfs_attached} { |
|
set zipkit_mountbase [::punkboot::zipfs_kit_mountbase] |
|
if {$zipkit_mountbase eq ""} { |
|
puts stderr "main.tcl: a zipfs archive is mounted but none of the mounts could be attributed to this executable ([info nameofexecutable]) - kit-internal module/lib paths will NOT be configured. zipfs mount table: [tcl::zipfs::mount]" |
|
} |
|
} |
|
|
|
#REVIEW - cookit/cookfs can be compiled with a different name for it's mount-point |
|
# - we could examine the -handle from 'file attr' for each //something:/ volume (excluding //zipfs:/) |
|
# - but there are situations where handle is empty (? punk repl issue?) |
|
# - for now we only support the known name - REVIEW |
|
set has_cookfs [expr {"//cookit:/" in [file volumes]}] |
|
set cookbase //cookit:/ ;#always define it so we can test on it later.. |
|
if {$has_cookfs} { |
|
set has_cookfs_attached [file exists //cookit:/lib] ;# //cookit:/manifest.txt ? REVIEW |
|
} else { |
|
set has_cookfs_attached 0 |
|
} |
|
|
|
|
|
#here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'. |
|
#we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require. |
|
|
|
#the kit main script's normalized path as published by the thin main (preamble |
|
#fallback: this file). NOT [info script] - inside this sourced core that names |
|
#the core file under punkboot/, not the root main.tcl the vfs-root derivations |
|
#below key on. (standard __dummy__ join to avoid symlinking issues - review) |
|
set normscript $::punkboot::main_script |
|
|
|
#The normalize is important as capitalisation must be retained (on all platforms) |
|
set normexe [file dirname [file normalize [file join [info nameofexecutable] __dummy__]]] |
|
|
|
|
|
#puts stderr "STARKIT: [package provide starkit]" |
|
|
|
set topdir [file dirname $normscript] |
|
set found_starkit_tcl 0 |
|
set possible_lib_vfs_folders [glob -nocomplain -dir [file join $topdir lib] -type d vfs*] |
|
if {$zipkit_mountbase ne ""} { |
|
#G-129: the payload's own tcl_library at the derived mount base (was [zipfs root]/app, |
|
#which errors on the 8.6 backport - no root subcommand - and assumes the modern mount) |
|
set zipkit_tcl_library [file join $zipkit_mountbase tcl_library] |
|
if {[file exists $zipkit_tcl_library]} { |
|
lappend possible_lib_vfs_folders {*}[glob -nocomplain -dir $zipkit_tcl_library -type d vfs*] |
|
} |
|
} |
|
foreach test_folder $possible_lib_vfs_folders { |
|
#e.g <name_of_exe>/lib/vfs1.4.1 |
|
#we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders. |
|
#order of folder processing shouldn't matter (rely on order returned by 'package versions' - review) |
|
if {[file exists $test_folder/starkit.tcl] && [file exists $test_folder/pkgIndex.tcl]} { |
|
set dir $test_folder |
|
source $test_folder/pkgIndex.tcl |
|
} |
|
} |
|
#package versions does not always return versions in increasing order! |
|
if {[set starkitv [lindex [lsort -command {package vcompare} [package versions starkit]] end]] ne ""} { |
|
#run the ifneeded script for the latest found (assuming package versions ordering is correct) |
|
#puts "111 autopath: $::auto_path" |
|
eval [package ifneeded starkit $starkitv] |
|
set found_starkit_tcl 1 |
|
#puts "222 autopath: $::auto_path" |
|
} |
|
if {!$found_starkit_tcl} { |
|
#our internal 'quick' search for starkit failed. |
|
#either we are in a pure zipfs system, or cookfs - or the starkit package is somewhere more devious |
|
#for pure zipfs or cookfs - it's a little wasteful to perform exhaustive search for starkit |
|
#review - only keep searching if not 'minted' first arg? |
|
|
|
#Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit |
|
#retain it so we can 'forget' the difference after our first 'package require' forces a full scan which includes some paths we may not wish to include or at least include with different preferences |
|
#puts "main.tcl 1)--> package name count: [llength [package names]]" |
|
#puts stderr [join [package names] \n] |
|
set original_packages [package names] |
|
|
|
#This is what we were trying to avoid - a package require causing a scan of ::auto_path and tcl::tm::list |
|
if {![catch {package require starkit}]} { |
|
#known side-effects of starkit::startup |
|
#sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced} |
|
#set the ::starkit::topdir variable |
|
#if mode not starpack, then: |
|
# - adds $::starkit::topdir/lib to the auto_path if not already present |
|
# |
|
#In the context of a metakit vfs attached to tcl kit executable - we expect the launch mode to be 'starkit' |
|
set starkit_startmode [starkit::startup] |
|
#However - we may also get here for a zipfs enabled tcl with a zifps vfs attached - but which has vlerq, starkit and vfs libraries available, |
|
#in which case the mode seems to be reported as 'unwrapped' |
|
#puts stderr "STARKIT MODE: $starkit_startmode" |
|
} |
|
#puts "main.tcl 2)--> package name count: [llength [package names]]" |
|
foreach pkg [package names] { |
|
if {$pkg ni $original_packages} { |
|
package forget $pkg |
|
} |
|
} |
|
#puts "main.tcl 3)--> package name count: [llength [package names]]" |
|
} |
|
|
|
|
|
|
|
# -- --- --- |
|
#when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it. review - for what versions of Tcl does this apply? |
|
#known to occur in old 8.6.8 kits as well as 8.7 |
|
#review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok |
|
#we want to be able to launch a process from the interactive shell using the same name this one was launched with. |
|
set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe |
|
set thisexeroot [file rootname $thisexe] ;#e.g punk86 |
|
set ::auto_execs($thisexeroot) [info nameofexecutable] |
|
if {$thisexe ne $thisexeroot} { |
|
#on windows make the .exe point there too |
|
set ::auto_execs($thisexe) [info nameofexecutable] |
|
} |
|
# -- --- --- |
|
|
|
set tm_additions_internal [list] |
|
set tm_additions_dev [list] |
|
set tm_additions_src [list] |
|
set auto_path_additions_internal [list] |
|
set auto_path_additions_dev [list] |
|
set auto_path_additions_src [list] |
|
|
|
set lc_auto_path [string tolower $::auto_path] |
|
|
|
#inital auto_path setup by init.tcl |
|
#firstly it includes env(TCLLIBPATH) |
|
#then it adds the tcl_library folder and its parent |
|
#e.g //zipfs:/app/tcl_library and //zipfs:/app |
|
#when 'minted' or 'os' is not supplied - any non internal paths (usually those from env(TCLLIBPATH) will be stripped |
|
#so that everything is self-contained in the kit/zipkit |
|
|
|
#puts "\x1b\[1\;33m main.tcl original auto_path: $::auto_path" |
|
|
|
if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} { |
|
set kp $::tcl::kitpath |
|
set kp [file normalize $kp] ;#tcl::kitpath needs to be capitalised as per the actual path |
|
|
|
#set existing_module_paths [string tolower [tcl::tm::list]] |
|
foreach p [list modules modules_tcl$tclmajorv] { |
|
#if {[string tolower [file join $kp $p]] ni $existing_module_paths} { |
|
# tcl::tm::add [file join $kp $p] |
|
#} |
|
lappend tm_additions_internal [file join $kp $p] |
|
} |
|
foreach p [list lib lib_tcl$tclmajorv] { |
|
lappend auto_path_additions_internal [file join $kp $p] |
|
} |
|
} |
|
if {$zipkit_mountbase ne ""} { |
|
#G-129: the derived mount base replaces the compiled-in assumption. tclZipFs.c |
|
#ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app and modern runtimes mount the |
|
#attached archive there; the 8.6 backport family mounts it at the executable's |
|
#own path. The mount table is the ground truth either way. |
|
set zipbase $zipkit_mountbase |
|
foreach p [list modules modules_tcl$tclmajorv] { |
|
lappend tm_additions_internal [file join $zipbase $p] |
|
} |
|
foreach p [list lib lib_tcl$tclmajorv] { |
|
lappend auto_path_additions_internal [file join $zipbase $p] |
|
} |
|
} |
|
if {$has_cookfs_attached} { |
|
#set existing_module_paths [string tolower [tcl::tm::list]] |
|
foreach p [list modules modules_tcl$tclmajorv] { |
|
#if {[string tolower [file join $cookbase $p]] ni $existing_module_paths} { |
|
# tcl::tm::add [file join $cookbase $p] |
|
#} |
|
lappend tm_additions_internal [file join $cookbase $p] |
|
} |
|
foreach p [list lib lib_tcl$tclmajorv] { |
|
lappend auto_path_additions_internal [file join $cookbase $p] |
|
} |
|
} |
|
|
|
|
|
|
|
set internal_paths [list] |
|
if {$has_zipfs} { |
|
if {[info commands tcl::zipfs::root] ne ""} { |
|
set ziproot [tcl::zipfs::root] ;#the volume root covers every zipfs mount |
|
lappend internal_paths $ziproot |
|
} |
|
#8.6 backport family: no root command, and the attached archive mounts outside |
|
#any zipfs volume (at the executable's own path) - the derived mount base is the |
|
#internal prefix. On modern runtimes it is already covered by the volume root. |
|
if {$zipkit_mountbase ne ""} { |
|
set mountbase_covered 0 |
|
foreach okprefix $internal_paths { |
|
if {[string match "[string tolower $okprefix]*" [string tolower $zipkit_mountbase]]} { |
|
set mountbase_covered 1 |
|
break |
|
} |
|
} |
|
if {!$mountbase_covered} { |
|
lappend internal_paths $zipkit_mountbase |
|
} |
|
} |
|
} |
|
if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} { |
|
lappend internal_paths $::tcl::kitpath |
|
} |
|
if {$has_cookfs} { |
|
lappend internal_paths $cookbase |
|
} |
|
|
|
#REVIEW |
|
if {[info exists ::punkboot::internal_paths] && [llength $::punkboot::internal_paths]} { |
|
#somewhat ugly cooperation with external sourcing scripts |
|
lappend internal_paths {*}$::punkboot::internal_paths |
|
} |
|
|
|
|
|
# ----------------------------------------------------------------------------------------------------------- |
|
# minted - refers to module and library paths relative to the project (executable path) |
|
# os - refers to modules and library paths gleaned from ::env (TCLLIBPATH and TCL<MAJOR>_<MINOR>_TM_PATH) |
|
# internal - refers to modules and libraries supplied from the mounted filesystem of a kit or zipfs based executable |
|
# src - refers to unbuilt modules and libraries under the project's src/ tree (src/modules, src/lib, src/bootsupport, src/vendormodules) |
|
# ----------------------------------------------------------------------------------------------------------- |
|
# Note that unlike standard 'package unknown' punk::libunknown does not stop searching for packages when a .tm file is found that matches requirements, |
|
# The auto_path is still examined. (avoids quirks where higher versioned pkgIndex based package not always found) |
|
# ----------------------------------------------------------------------------------------------------------- |
|
set all_package_modes [list minted os internal src] |
|
#package_mode is specified as a dash-delimited ordered value e.g minted-os |
|
#"internal" is the default and if not present is always added to the list |
|
#i.e "minted-os" is equivalent to "minted-os-internal" |
|
#"os" is equivalent to "os-internal" |
|
#"internal-os" and "internal" are left as is. |
|
#The effective package_mode has 1 2 3 or 4 members. |
|
# The only case where it has 1 member is if just "internal" is specified. |
|
set test_package_mode [lindex $args 0] |
|
#puts stderr "main.tcl test_package_mode: '$test_package_mode'" |
|
|
|
#Token-by-token validation: instead of exhaustively listing all permutations, |
|
#split the first arg on dash and validate each token against the known mode set. |
|
#This scales to any number of modes without enumerating every permutation. |
|
#G-033: an optional 'proj:' prefix on the mode string (e.g proj:internal-src) |
|
#scopes WHICH project the minted/src blocks resolve against - the project containing |
|
#the cwd instead of the executable's own. The prefix sits outside the ordered |
|
#dash-list, whose block order remains the same-version tie-break dial. |
|
set proj_scope 0 |
|
set test_mode_string $test_package_mode |
|
if {[string match proj:* $test_package_mode]} { |
|
set proj_scope 1 |
|
set test_mode_string [string range $test_package_mode 5 end] |
|
} |
|
set package_modes "" |
|
set arglist "" |
|
if {$test_mode_string eq ""} { |
|
#empty first arg (or bare 'proj:') consumed as equivalent of 'internal' |
|
set package_modes internal |
|
set arglist [lrange $args 1 end] |
|
} else { |
|
set tokens [split $test_mode_string -] |
|
set valid 1 |
|
foreach t $tokens { |
|
if {$t ni $all_package_modes} { |
|
set valid 0 |
|
break |
|
} |
|
} |
|
if {$valid && [llength $tokens] >= 1} { |
|
set package_modes $tokens |
|
if {"internal" ni $package_modes} { |
|
lappend package_modes internal |
|
} |
|
set arglist [lrange $args 1 end] |
|
} else { |
|
#not a package_mode - treat as subcommand |
|
#(a 'proj:' prefix on a non-mode string is not consumed either - the |
|
#whole arg passes through, e.g as a script name) |
|
set proj_scope 0 |
|
set package_modes internal |
|
set arglist $args |
|
} |
|
} |
|
#assert: arglist has had any first arg that is a package_mode (including empty string) stripped. |
|
set ::argv $arglist |
|
set ::argc [llength $arglist] |
|
#assert: package_modes is now a list of at least length 1 (in which case the only possible value is: internal) |
|
|
|
#-------------------------------------------------------- |
|
#G-033 proj: scope - resolve minted/src against the project containing the cwd |
|
#(walk-up to the nearest VCS repo root, the punk::repo::is_project_root marker) |
|
#instead of the executable's own project. Explicit prefix = opt-in; discovery and |
|
#its outcome are always reported on stderr (a rebind must never be silent), and a |
|
#failed discovery never falls back to exe-relative roots (no false rebind). |
|
#-------------------------------------------------------- |
|
set proj_root "" |
|
if {$proj_scope} { |
|
if {!("minted" in $package_modes || "src" in $package_modes)} { |
|
puts stderr "proj: WARNING - 'proj:' has no effect: package mode list '[join $package_modes -]' contains no project-root-using block (minted or src)" |
|
} else { |
|
set proj_root [::punkboot::proj_root_find [pwd]] |
|
if {$proj_root eq ""} { |
|
puts stderr "proj: WARNING - no project root found walking up from [pwd] (nearest git/fossil repo root with a punkshell-style src tree) - minted/src blocks are not bound to any project (proceeding; internal/os paths unaffected)" |
|
} else { |
|
puts stderr "proj: project root detected (walk-up from [pwd]): $proj_root" |
|
puts stderr "proj: effective package mode precedence: [join $package_modes -] (earlier blocks win same-version ties)" |
|
} |
|
} |
|
} |
|
#Note regarding the use of package forget and binary packages |
|
#If the package has loaded a binary component - then a package forget and a subsequent package require can result in both binaries being present, as seen in 'info loaded' result - potentially resulting in anomalous behaviour |
|
#In general package forget after a package has already been required may need special handling and should be avoided where possible. |
|
#Only a limited set of packages support unloading a binary component anyway. |
|
#We limit the use of 'package forget' here to packages that have not been loaded (whether pure-tcl or not) |
|
#ie in this context it is used only for manipulating preferences of which packages are loaded in the first place |
|
|
|
#Unintuitive preferencing can occur if the same package version is for example present in a tclkit and in a module or lib folder external to the kit. |
|
#It may be desired for performance or testing reasons to preference the library outside of the kit - and raising the version number may not always be possible/practical. |
|
|
|
#If the executable is a kit - we don't know what packages it contains or whether it allows loading from env based external paths. |
|
#For app-punk projects - the lib/module paths based on the project being run should take preference if 'minted' is earlier in the list, even if the version number is the same. |
|
#(these are the 'info nameofexecutable' or 'info script' or 'pwd' relative paths that are added here) |
|
#Some kits will remove lib/module paths (from auto_path & tcl::tm::list) that have been added via TCLLIBPATH / TCLX_Y_TM_PATH environment variables |
|
#Some kits will remove those env-provided lib paths but fail to remove the env-provided module paths |
|
#(differences in boot.tcl in the kits) |
|
|
|
if {[llength $package_modes] > 1} { |
|
#puts stderr "main.tcl PACKAGE MODE is preferencing libraries and modules in the order: $package_modes" |
|
#puts stderr "main.tcl original auto_path: $::auto_path" |
|
|
|
|
|
#------------------------------------------------------------------------------ |
|
#Module loading |
|
#------------------------------------------------------------------------------ |
|
#If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them |
|
# - but first add our other known relative modules paths - as it won't make sense to use current directory as a modulepath if it's an ancestor of one of these.. |
|
|
|
#original tm list at this point consists of whatever the kit decided + some prepended internal kit paths that punk decided on. |
|
#we want to bring the existing external paths to the position specified by package_mode (probably from the kit looking at various env TCL* values) |
|
#we want to maintain the order of the internal paths. |
|
#we want to add our external minted paths to the position specified by package_mode |
|
|
|
#assert [llength [package names]] should be small at this point ~ <10 ? |
|
|
|
set original_tm_list [tcl::tm::list] |
|
tcl::tm::remove {*}$original_tm_list |
|
|
|
# -- --- --- --- --- --- --- --- |
|
#split existing paths into internal & external |
|
set internal_tm_dirs [list] ;# |
|
set external_tm_dirs [list] |
|
set lcase_internal_paths [string tolower $internal_paths] |
|
foreach tm $original_tm_list { |
|
#review - do we know original tm list was properly normalised? (need capitalisation consistent for path keys) |
|
set tmlower [string tolower $tm] |
|
set is_internal 0 |
|
foreach okprefix $lcase_internal_paths { |
|
if {[string match "$okprefix*" $tmlower]} { |
|
lappend internal_tm_dirs $tm |
|
set is_internal 1 |
|
break |
|
} |
|
} |
|
if {!$is_internal} { |
|
lappend external_tm_dirs $tm |
|
} |
|
} |
|
# -- --- --- --- --- --- --- --- |
|
set original_external_tm_dirs $external_tm_dirs ;#we check some of our additions and bring to front - so we refer to external list as provided by kit |
|
#assert internal_tm_dirs and external_tm_dirs have their case preserved.. |
|
|
|
set module_folders [list] |
|
|
|
#review - the below statement doesn't seem to be true. |
|
#tm list first added end up later in the list - and then override earlier ones if version the same - so add pwd-relative 1st to give higher priority |
|
#(only if Tcl has scanned all paths - see below bogus package load) |
|
#1 |
|
|
|
#2) |
|
# .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) |
|
#using normexe under assumption [info name] might be symlink - and more likely to be where the modules are located. |
|
#we will try both relative to symlink and relative to underlying exe - with those at symlink location earlier in the list |
|
#review - a user may have other expectations. |
|
|
|
#case differences could represent different paths on unix-like platforms. |
|
#It's perhaps a little unwise to configure matching paths with only case differences for a cross-platform tool .. but we should support it for those who use it and have no interest in windows - todo! review |
|
if {"minted" in $package_modes} { |
|
set exe_module_folders [list] |
|
if {$proj_scope} { |
|
#G-033: minted module paths resolve against the cwd-walk-up project root |
|
#only - no exe-relative fallback (a proj: launch must never silently |
|
#rebind to the executable's own project; a failed discovery was |
|
#already warned above and the minted block then contributes nothing). |
|
if {$proj_root ne ""} { |
|
lappend exe_module_folders $proj_root/modules |
|
lappend exe_module_folders $proj_root/modules_tcl$tclmajorv |
|
} |
|
} else { |
|
set normexe_dir [file dirname $normexe] |
|
if {[file tail $normexe_dir] eq "bin"} { |
|
#underlying exe in a bin dir - backtrack 1 |
|
lappend exe_module_folders [file dirname $normexe_dir]/modules |
|
lappend exe_module_folders [file dirname $normexe_dir]/modules_tcl$tclmajorv |
|
} else { |
|
lappend exe_module_folders $normexe_dir/modules |
|
lappend exe_module_folders $normexe_dir/modules_tcl$tclmajorv |
|
} |
|
set nameexe_dir [file dirname [file normalize [info nameofexecutable]]] ;#must be normalized for capitalisation consistency |
|
|
|
#possible symlink (may resolve to same path as above - we check below to not add in twice) |
|
if {[file tail $nameexe_dir] eq "bin"} { |
|
lappend exe_module_folders [file dirname $nameexe_dir]/modules |
|
lappend exe_module_folders [file dirname $nameexe_dir]/modules_tcl$tclmajorv |
|
} else { |
|
lappend exe_module_folders $nameexe_dir/modules |
|
lappend exe_module_folders $nameexe_dir/modules_tcl$tclmajorv |
|
} |
|
} |
|
|
|
#foreach modulefolder $exe_module_folders { |
|
# set lc_external_tm_dirs [string tolower $external_tm_dirs] |
|
# set lc_modulefolder [string tolower $modulefolder] |
|
# if {$lc_modulefolder in [string tolower $original_external_tm_dirs]} { |
|
# #perhaps we have an env var set pointing to one of our minted folders. We don't want to rely on how the kit ordered it. |
|
# #bring to front if not already there. |
|
# #assert it must be present in $lc_external_tm_dirs if it's in $original_external_tm_dirs |
|
# set posn [lsearch $lc_external_tm_dirs $lc_modulefolder] |
|
# if {$posn > 0} { |
|
# #don't rely on lremove here. Not all runtimes have it and we don't want to load our forward-compatibility packages yet. |
|
# #(still need to support tcl 8.6 - and this script used in multiple kits) |
|
# set external_tm_dirs [lreplace $external_tm_dirs $posn $posn] |
|
# #don't even add it back in if it doesn't exist in filesystem |
|
# if {[file isdirectory $modulefolder]} { |
|
# set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder] |
|
# } |
|
# } |
|
# } else { |
|
# if {$lc_modulefolder ni $lc_external_tm_dirs && [file isdirectory $modulefolder]} { |
|
# set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder] ;#linsert seems faster than 'concat [list $modulefolder] $external_tm_dirs' - review |
|
# } |
|
# } |
|
#} |
|
if {![llength $exe_module_folders]} { |
|
#proj_scope with no discovered root was already warned at proj: discovery |
|
if {!$proj_scope} { |
|
puts stderr "Warning - no 'modules' or 'modules_tcl$tclmajorv' folders found relative to executable (or it's symlink if any)" |
|
} |
|
} else { |
|
set tm_additions_dev $exe_module_folders |
|
} |
|
} |
|
|
|
#src mode: discover the project's src/ tree and add unbuilt module paths. |
|
#Unlike minted mode (which points at built output in <projectroot>/modules), |
|
#src mode points at the unbuilt source in <projectroot>/src/modules etc. |
|
if {"src" in $package_modes} { |
|
set src_project_root "" |
|
if {$proj_scope} { |
|
#G-033: src resolves against the cwd-walk-up project root; empty |
|
#(warned at discovery) means the src block contributes nothing - |
|
#never an exe-relative fallback rebind. |
|
set src_project_root $proj_root |
|
} else { |
|
#reuse the minted-mode project root discovery (exe in bin/ -> backtrack 1) |
|
set normexe_dir_for_src [file dirname $normexe] |
|
if {[file tail $normexe_dir_for_src] eq "bin"} { |
|
set src_project_root [file dirname $normexe_dir_for_src] |
|
} else { |
|
set src_project_root $normexe_dir_for_src |
|
} |
|
#also check symlink target |
|
if {$src_project_root eq ""} { |
|
set nameexe_dir_for_src [file dirname [file normalize [info nameofexecutable]]] |
|
if {[file tail $nameexe_dir_for_src] eq "bin"} { |
|
set src_project_root [file dirname $nameexe_dir_for_src] |
|
} else { |
|
set src_project_root $nameexe_dir_for_src |
|
} |
|
} |
|
} |
|
|
|
if {$src_project_root ne "" && [file isdirectory [file join $src_project_root src]]} { |
|
foreach p [list modules modules_tcl$tclmajorv] { |
|
set modpath [file join $src_project_root src $p] |
|
if {[file isdirectory $modpath] && $modpath ni $tm_additions_src} { |
|
lappend tm_additions_src $modpath |
|
} |
|
} |
|
#bootsupport modules (for boot-critical packages like punkcheck, punk::mix etc) |
|
foreach p [list modules modules_tcl$tclmajorv] { |
|
set modpath [file join $src_project_root src bootsupport $p] |
|
if {[file isdirectory $modpath] && $modpath ni $tm_additions_src} { |
|
lappend tm_additions_src $modpath |
|
} |
|
} |
|
#vendormodules (vendored dependencies like voo) |
|
foreach p [list vendormodules vendormodules_tcl$tclmajorv] { |
|
set modpath [file join $src_project_root src $p] |
|
if {[file isdirectory $modpath] && $modpath ni $tm_additions_src} { |
|
lappend tm_additions_src $modpath |
|
} |
|
} |
|
} else { |
|
if {$proj_scope} { |
|
#no discovered root was already warned at proj: discovery |
|
if {$src_project_root ne ""} { |
|
puts stderr "Warning - src mode (proj:): no src/ directory under detected project root ($src_project_root)" |
|
} |
|
} else { |
|
puts stderr "Warning - src mode: no src/ directory found relative to executable ($normexe_dir_for_src)" |
|
} |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
if {"os" in $package_modes} { |
|
#2) support developer running from a folder containing *.tm files they want to make available |
|
# could cause problems if user happens to be in a subdirectory of a tm folder structure as namespaced modules won't work if not at a tm path root. |
|
#The current dir could also be a subdirectory of an existing tm_dir which would fail during tcl::tm::add - we will need to wrap all additions in catch |
|
set launchdir [pwd] |
|
set currentdir_modules [glob -nocomplain -dir $launchdir -type f -tail *.tm] |
|
#we assume [pwd] will always return an external (not kit) path at this point - REVIEW |
|
if {[llength $currentdir_modules]} { |
|
#now add current dir (if no conflict with above) |
|
set external_tm_dirs [linsert $external_tm_dirs 0 $launchdir] |
|
if {[file exists $launchdir/modules] || [file exists $launchdir/modules_tcl$tclmajorv]} { |
|
puts stderr "WARNING: modules or modules_tcl$tclmajorv folders not added to tcl::tm::path due to modules found in current workding dir [pwd]" |
|
} |
|
} else { |
|
#modules or modules_tclX subdir relative to cwd cannot be added if [pwd] has been added |
|
set cwd_modules_folder [file join [pwd] modules] ;#pwd is already normalized to appropriate capitalisation |
|
if {[file isdirectory $cwd_modules_folder]} { |
|
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} { |
|
#prepend |
|
set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder] |
|
} |
|
} |
|
set cwd_modules_folder [file join [pwd] modules_tcl$tclmajorv] |
|
if {[file isdirectory $cwd_modules_folder]} { |
|
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} { |
|
#prepend |
|
set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder] |
|
} |
|
} |
|
} |
|
} |
|
|
|
#assert tcl::tm::list still empty here |
|
#restore module paths |
|
# -- --- --- --- --- --- --- --- |
|
set new_tm_path [list] |
|
foreach mode $package_modes { |
|
switch -exact -- $mode { |
|
internal { |
|
#review |
|
#even though the internal_tm_dirs came from either ::env or the executable's init - we don't treat them as 'os' paths |
|
#Add them before our own internal additions |
|
foreach n $internal_tm_dirs { |
|
if {$n ni $new_tm_path} { |
|
lappend new_tm_path $n |
|
} |
|
} |
|
foreach n $tm_additions_internal { |
|
if {$n ni $new_tm_path} { |
|
lappend new_tm_path $n |
|
} |
|
} |
|
} |
|
minted { |
|
foreach n $tm_additions_dev { |
|
if {$n ni $new_tm_path} { |
|
lappend new_tm_path $n |
|
} |
|
} |
|
} |
|
src { |
|
foreach n $tm_additions_src { |
|
if {$n ni $new_tm_path} { |
|
lappend new_tm_path $n |
|
} |
|
} |
|
} |
|
os { |
|
foreach n $external_tm_dirs { |
|
if {$n ni $new_tm_path} { |
|
lappend new_tm_path $n |
|
} |
|
} |
|
} |
|
} |
|
} |
|
foreach p [lreverse $new_tm_path] { |
|
if {[catch {tcl::tm::add $p} errM]} { |
|
puts stderr "Failed to add tm module dir '$p' to tcl::tm::list\n$errM" |
|
} |
|
} |
|
|
|
|
|
|
|
|
|
|
|
##tcl::tm::add internals first (so they end up at the end of the tmlist) as in 'minted' mode (minted as first argument on launch) we preference external modules |
|
##note use of lreverse to maintain same order |
|
#foreach p [lreverse $internal_tm_dirs] { |
|
# if {$p ni [tcl::tm::list]} { |
|
# #Items that end up at the beginning of the tm list are processed first.. but an item of same version later in the tm list will not override the ifneeded script of an already encountered .tm. |
|
# #addition can fail if one path is a prefix of another |
|
# if {[catch {tcl::tm::add $p} errM]} { |
|
# puts stderr "Failed to add internal module dir '$p' to tcl::tm::list\n$errM" |
|
# } |
|
# } |
|
#} |
|
##push externals to *head* of tcl::tm::list - as they have priority |
|
#foreach p [lreverse $external_tm_dirs] { |
|
# if {$p ni [tcl::tm::list]} { |
|
# if {[catch {tcl::tm::add $p} errM]} { |
|
# puts stderr "Failed to add external module dir '$p' to tcl::tm::list\n$errM" |
|
# } |
|
# } |
|
#} |
|
|
|
#AUTO_PATH |
|
|
|
|
|
#auto_path - add *external* exe-relative after exe-relative path |
|
#add lib and lib_tcl8 lib_tcl9 etc based on tclmajorv |
|
#libs appended to end of ::auto_path are processed first (reverse order processing in 'package unknown'), but ifneeded scripts are overridden by earlier ones |
|
#(ie for both tcl::tm::list and auto_path it is priority by 'order of appearance' in the resultant lists - not the order in which they are added to the lists) |
|
# |
|
|
|
#we can't rely on builtin ledit (tcl9+) or loadable version such as punk::lib::compat::ledit at this point |
|
#so we prepend to auto_path using a slightly inefficient method. Should be fine on relatively small list like this |
|
#eventually it should just be something like 'ledit ::auto_path -1 -1 $libfolder' |
|
if {"minted" in $package_modes} { |
|
set platform [::punkboot::platform_punk] |
|
#on windows - case differences dont matter - but can stop us finding path in auto_path |
|
#on other platforms, case differences could represent different paths |
|
#review |
|
set process_folders [list] |
|
if {$proj_scope} { |
|
#G-033: minted lib paths resolve against the cwd-walk-up project root |
|
#only (no exe-relative or cwd-relative candidates - see the minted |
|
#module-path block above for rationale). |
|
if {$proj_root ne ""} { |
|
foreach libsub [list lib_tcl$tclmajorv lib] { |
|
set libfolder $proj_root/$libsub |
|
if {[file isdirectory $libfolder] && $libfolder ni $process_folders} { |
|
lappend process_folders $libfolder |
|
} |
|
} |
|
} |
|
} else { |
|
foreach libsub [list lib_tcl$tclmajorv lib] { |
|
if {[file tail $nameexe_dir] eq "bin"} { |
|
set libfolder [file dirname $nameexe_dir]/$libsub |
|
} else { |
|
set libfolder $nameexe_dir/$libsub |
|
} |
|
if {[file isdirectory $libfolder]} { |
|
#lappend auto_path_additions_dev $libfolder |
|
lappend process_folders $libfolder |
|
} |
|
|
|
# ------------- |
|
if {[file tail $normexe_dir] eq "bin"} { |
|
set libfolder [file dirname $normexe_dir]/$libsub |
|
} else { |
|
set libfolder $normexe_dir/$libsub |
|
} |
|
if {[file isdirectory $libfolder]} { |
|
#lappend auto_path_additions_dev $libfolder |
|
if {$libfolder ni $process_folders} { |
|
lappend process_folders $libfolder |
|
} |
|
} |
|
# ------------- |
|
set libfolder [pwd]/$libsub |
|
if {[file isdirectory $libfolder]} { |
|
#lappend auto_path_additions_dev $libfolder |
|
if {$libfolder ni $process_folders} { |
|
lappend process_folders $libfolder |
|
} |
|
} |
|
} |
|
} |
|
foreach f $process_folders { |
|
if {[string match lib_tcl* [file tail $f]]} { |
|
if {[file exists $f/allplatforms]} { |
|
lappend auto_path_additions_dev $f/allplatforms |
|
} |
|
if {[file exists $f/$platform]} { |
|
lappend auto_path_additions_dev $f/$platform |
|
} |
|
} else { |
|
lappend auto_path_additions_dev $f |
|
} |
|
} |
|
|
|
} |
|
|
|
#src mode: add unbuilt source library paths from the project's src/ tree. |
|
if {"src" in $package_modes && [info exists src_project_root] && $src_project_root ne ""} { |
|
set platform [::punkboot::platform_punk] |
|
set src_lib_base [file join $src_project_root src] |
|
#src/lib and src/lib_tcl<tclmajor> (editable library source) |
|
foreach libsub [list lib_tcl$tclmajorv lib] { |
|
set libfolder [file join $src_lib_base $libsub] |
|
if {[file isdirectory $libfolder]} { |
|
if {[string match lib_tcl* [file tail $libfolder]]} { |
|
if {[file exists $libfolder/allplatforms]} { |
|
lappend auto_path_additions_src $libfolder/allplatforms |
|
} |
|
if {[file exists $libfolder/$platform]} { |
|
lappend auto_path_additions_src $libfolder/$platform |
|
} |
|
} else { |
|
lappend auto_path_additions_src $libfolder |
|
} |
|
} |
|
} |
|
#src/bootsupport/lib (bootstrap libraries) |
|
set src_bs_lib [file join $src_lib_base bootsupport lib] |
|
if {[file isdirectory $src_bs_lib]} { |
|
if {$src_bs_lib ni $auto_path_additions_src} { |
|
lappend auto_path_additions_src $src_bs_lib |
|
} |
|
} |
|
#src/bootsupport/lib/tcl<tclmajor>/<arch> (platform-specific bootstrap libraries) |
|
set src_bs_lib_arch [file join $src_lib_base bootsupport lib tcl$tclmajorv $platform] |
|
if {[file isdirectory $src_bs_lib_arch]} { |
|
if {$src_bs_lib_arch ni $auto_path_additions_src} { |
|
lappend auto_path_additions_src $src_bs_lib_arch |
|
} |
|
} |
|
} |
|
# -- --- --- --- --- --- --- --- |
|
#split existing ::auto_path entries into internal & external |
|
set internal_ap_dirs [list] ;# |
|
set external_ap_dirs [list] |
|
set lcase_internal_paths [string tolower $internal_paths] |
|
foreach pkgpath $::auto_path { |
|
set pkgpathlower [string tolower $pkgpath] |
|
set is_internal 0 |
|
foreach okprefix $lcase_internal_paths { |
|
if {[string match "$okprefix*" $pkgpathlower]} { |
|
lappend internal_ap_dirs $pkgpath |
|
set is_internal 1 |
|
break |
|
} |
|
} |
|
if {!$is_internal} { |
|
lappend external_ap_dirs $pkgpath |
|
} |
|
} |
|
# -- --- --- --- --- --- --- --- |
|
set new_auto_path [list] |
|
foreach mode $package_modes { |
|
switch -exact -- $mode { |
|
internal { |
|
#review |
|
#even though the internal_ap_dirs came from either ::env or the executable's init - we don't treat them as 'os' paths |
|
#Add them before our own internal additions |
|
foreach n $internal_ap_dirs { |
|
if {$n ni $new_auto_path} { |
|
lappend new_auto_path $n |
|
} |
|
} |
|
foreach n $auto_path_additions_internal { |
|
if {$n ni $new_auto_path} { |
|
lappend new_auto_path $n |
|
} |
|
} |
|
} |
|
minted { |
|
foreach n $auto_path_additions_dev { |
|
if {$n ni $new_auto_path} { |
|
lappend new_auto_path $n |
|
} |
|
} |
|
} |
|
src { |
|
foreach n $auto_path_additions_src { |
|
if {$n ni $new_auto_path} { |
|
lappend new_auto_path $n |
|
} |
|
} |
|
} |
|
os { |
|
foreach n $external_ap_dirs { |
|
if {$n ni $new_auto_path} { |
|
lappend new_auto_path $n |
|
} |
|
} |
|
} |
|
} |
|
} |
|
set ::auto_path $new_auto_path |
|
|
|
} else { |
|
#package_mode 'internal' only |
|
#Tcl_Init will most likely have set up some external paths |
|
#As our app has been started without first arg (package_mode) indicating anything other than 'internal' - we will prune paths that are not zipfs or tclkit |
|
#(or set via punkboot::internal_paths) |
|
set filtered_auto_path [list] |
|
#review - case insensitive ok for windows - but could cause issues on other platforms? |
|
foreach ap $::auto_path { |
|
set aplower [string tolower $ap] |
|
foreach okprefix $internal_paths { |
|
if {[string match "[string tolower $okprefix]*" $aplower]} { |
|
lappend filtered_auto_path $ap |
|
break |
|
} |
|
} |
|
} |
|
#puts stderr "main.tcl internal_paths: $internal_paths" |
|
#puts stderr "main.tcl filtered_auto_path: $filtered_auto_path" |
|
|
|
set filtered_tm_list [list] |
|
foreach tm [tcl::tm::list] { |
|
set tmlower [string tolower $tm] |
|
foreach okprefix $internal_paths { |
|
if {[string match "[string tolower $okprefix]*" $tmlower]} { |
|
lappend filtered_tm_list $tm |
|
break |
|
} |
|
} |
|
} |
|
set new_tm_list [list] |
|
foreach p $filtered_tm_list { |
|
if {$p ni $new_tm_list && [file exists $p]} { |
|
lappend new_tm_list $p |
|
} |
|
} |
|
foreach p $tm_additions_internal { |
|
if {$p ni $new_tm_list && [file exists $p]} { |
|
lappend new_tm_list $p |
|
} |
|
} |
|
tcl::tm::remove {*}[tcl::tm::list] |
|
tcl::tm::add {*}[lreverse $new_tm_list] |
|
|
|
|
|
#If it looks like we are running the vfs/_bake/exename.vfs/main.tcl from an external tclsh - try to use vfs folders to simulate kit state |
|
#set script_relative_lib [file normalize [file join [file dirname [info script]] lib]] |
|
#set scriptdir [file dirname [info script]] |
|
set scriptdir [file dirname $normscript] |
|
#G-129: a script under the derived zipfs mount base is kit-internal even though |
|
#no //zipfs:/ prefix test can recognise it (8.6 backport mounts at the exe path) |
|
set script_in_attached_vfs 0 |
|
if {[string match //zipfs:/* $scriptdir] || [string match "${cookbase}*" $scriptdir] || [info exists ::tcl::kitpath]} { |
|
set script_in_attached_vfs 1 |
|
} elseif {$zipkit_mountbase ne "" && [::punkboot::path_within $scriptdir $zipkit_mountbase]} { |
|
set script_in_attached_vfs 1 |
|
} |
|
if {!$script_in_attached_vfs} { |
|
#presumably running the vfs/xxx.vfs/main.tcl script using a non-kit tclsh that doesn't have starkit lib or mounted zipfs/cookfs available.. lets see if we can move forward anyway |
|
set vfscontainer [file normalize [file dirname $scriptdir]] |
|
#set vfscommon [file join $vfscontainer _vfscommon] |
|
#we shouldn't be targetting the src/vfs folders - use src/_bake/exename.vfs instead |
|
set vfsdir [file normalize $scriptdir] |
|
set projectroot [file dirname [file dirname $vfscontainer]] ;#back below src/_bake/exename.vfs/main.tcl |
|
puts stdout "no starkit. projectroot?: $projectroot executable:[info nameofexecutable]" |
|
puts stdout "info lib: [info library]" |
|
|
|
#add back the info lib reported by the executable.. as we can't access the one built into a kit |
|
if {[file exists [info library]]} { |
|
if {[string tolower [info library]] ni [string tolower [list {*}$filtered_auto_path {*}$auto_path_additions_internal]]} { |
|
lappend auto_path_additions_internal [info library] |
|
} |
|
} |
|
|
|
set lib_types [list lib lib_tcl$tclmajorv] |
|
foreach l $lib_types { |
|
set lib [file join $vfsdir $l] |
|
if {[file exists $lib] && [string tolower $lib] ni [string tolower [list {*}$filtered_auto_path {*}$auto_path_additions_internal]]} { |
|
lappend auto_path_additions_internal $lib |
|
} |
|
} |
|
#foreach l $lib_types { |
|
# set lib [file join $vfscommon $l] |
|
# if {[file exists $lib] && [string tolower $lib] ni [string tolower $::auto_path]} { |
|
# lappend ::auto_path $lib |
|
# } |
|
#} |
|
set ::auto_path [list {*}$filtered_auto_path {*}$auto_path_additions_internal] |
|
puts stderr "main.tcl final auto_path: $::auto_path" |
|
|
|
|
|
|
|
set mod_types [list modules modules_tcl$tclmajorv] |
|
foreach m $mod_types { |
|
set modpath [file join $vfsdir $m] |
|
if {[file exists $modpath] && [string tolower $modpath] ni [string tolower [tcl::tm::list]]} { |
|
tcl::tm::add $modpath |
|
} |
|
} |
|
#foreach m $mod_types { |
|
# set modpath [file join $vfscommon $m] |
|
# if {[file exists $modpath] && [string tolower $modpath] ni [string tolower [tcl::tm::list]]} { |
|
# tcl::tm::add $modpath |
|
# } |
|
#} |
|
} else { |
|
#normal case main.tcl from vfs |
|
set ::auto_path [list {*}$filtered_auto_path {*}$auto_path_additions_internal] |
|
} |
|
#force rescan |
|
#catch {package require flobrudder666_nonexistant} |
|
#puts stderr "main.tcl auto_path :$::auto_path" |
|
#puts stderr "main.tcl tcl::tm::list:[tcl::tm::list]" |
|
} |
|
|
|
|
|
|
|
#-------------------------------------------------------- |
|
#load libunknown without triggering the existing package unknown |
|
#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 ""} { |
|
source $libunknown |
|
if {[catch {punk::libunknown::init -caller main.tcl} errM]} { |
|
puts "error initialising punk::libunknown\n$errM" |
|
} |
|
} |
|
#-------------------------------------------------------- |
|
#Now that new 'package unknown' mechanism is in place - we can use package require |
|
|
|
#assert arglist has had 'minted|os|os-minted etc' first arg removed if it was present. |
|
|
|
|
|
#-------------------------------------------------------- |
|
#src mode: register #modpod modules from src/modules via package ifneeded |
|
#and set package prefer latest so 999999.0a1.0 dev modules are preferred |
|
#over stable bootsupport/vendored copies on unversioned package require. |
|
#Uses only Tcl builtins (glob, file, string) since no punk modules are loaded yet. |
|
#-------------------------------------------------------- |
|
if {"src" in $package_modes && [info exists src_project_root] && $src_project_root ne ""} { |
|
#package prefer latest is set here so 999999.0a1.0 dev modules are preferred |
|
#over stable bootsupport/vendored copies on unversioned package require. |
|
#This must be set after libunknown::init (which may reset the preference to stable) |
|
#and before any package require calls in the subcommand handler below. |
|
#We set it again just before subcommand dispatch to ensure it isn't overridden. |
|
|
|
#inline #modpod scanner — equivalent to punk::tcltestrun::tm_path_additional_ifneeded |
|
#but using only Tcl builtins since punk::path isn't loaded at boot time. |
|
set src_modules_dir [file join $src_project_root src modules] |
|
set modpod_count 0 |
|
if {[file isdirectory $src_modules_dir]} { |
|
#recursive glob for #modpod-* directories (Tcl 8.6+ supports ** in glob) |
|
set modpod_dirs [list] |
|
foreach found [glob -nocomplain -type d -directory $src_modules_dir ** #modpod-*] { |
|
#skip staging subdirectories (_mint; legacy _build; _bake defensively) |
|
if {[string match "*_build*" $found] || [string match "*_mint*" $found] || [string match "*_bake*" $found]} { continue } |
|
lappend modpod_dirs $found |
|
} |
|
foreach modpod_dir $modpod_dirs { |
|
set tail [file tail $modpod_dir] |
|
#directory name format: #modpod-<modname>-<version> |
|
#strip leading "#modpod-" (8 chars), then split on last "-" to separate modname from version |
|
set rest [string range $tail 8 end] |
|
set last_dash [string last "-" $rest] |
|
if {$last_dash < 0} { continue } |
|
set modname [string range $rest 0 [expr {$last_dash - 1}]] |
|
set modver [string range $rest [expr {$last_dash + 1}] end] |
|
set modpath [file join $modpod_dir "$modname-$modver.tm"] |
|
#compute fully qualified module name from path relative to src/modules |
|
#file relative isn't available in all Tcl builds at boot time, so compute manually |
|
set reldir "" |
|
set checkdir $modpod_dir |
|
set base $src_modules_dir |
|
#walk up from modpod_dir until we reach src/modules, collecting path components |
|
while {$checkdir ne $base && $checkdir ne ""} { |
|
set reldir [linsert $reldir 0 [file tail $checkdir]] |
|
set checkdir [file dirname $checkdir] |
|
} |
|
if {$reldir eq ""} { |
|
set fullmodname $modname |
|
} else { |
|
set fullmodname [join $reldir ::]::$modname |
|
} |
|
if {[file exists $modpath]} { |
|
eval [list package ifneeded $fullmodname $modver [list source $modpath]] |
|
incr modpod_count |
|
} |
|
} |
|
if {$modpod_count > 0} { |
|
puts stderr "src mode: registered $modpod_count #modpod module[expr {$modpod_count == 1 ? "" : "s"}] from $src_modules_dir" |
|
} |
|
} |
|
} |
|
#-------------------------------------------------------- |
|
|
|
|
|
#src mode: set package prefer latest as late as possible (after libunknown::init |
|
#which may reset it to stable) so 999999.0a1.0 dev modules are preferred over |
|
#stable bootsupport/vendored copies on unversioned package require. |
|
if {"src" in $package_modes} { |
|
package prefer latest |
|
# Force a scan of all tcl::tm::list paths by triggering package unknown. |
|
# The VFS-bundled stable versions (e.g punk 0.1.1) are already registered |
|
# from Tcl's init, so package require for those packages would never call |
|
# package unknown — meaning 999999.0a1.0 dev versions in src/modules would |
|
# never be discovered. This dummy require forces package unknown to scan |
|
# all tm paths and register all ifneeded scripts, including the dev versions. |
|
# After this, package prefer latest will select 999999.0a1.0 over 0.1.1. |
|
catch {package require __src_mode_tm_scan__} |
|
} |
|
|
|
#--------------------------------------------------------------- |
|
#Boot running-state surface (G-031 registration model - the single boot |
|
#"running state" surface G-089 anticipated). Post-boot consumers (e.g |
|
#punk::buildinfo, scriptlib resolution) read facts the boot derived |
|
#instead of re-deriving or guessing. Dict keys: core_version, main_script, |
|
#package_modes, proj_scope, proj_root, kit_payload_base, and (src mode |
|
#only) src_project_root. |
|
#--------------------------------------------------------------- |
|
set boot_payload_base "" |
|
if {$zipkit_mountbase ne ""} { |
|
set boot_payload_base $zipkit_mountbase |
|
} elseif {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} { |
|
set boot_payload_base $::tcl::kitpath |
|
} elseif {$has_cookfs_attached} { |
|
set boot_payload_base $cookbase |
|
} |
|
set boot_state_dict [dict create \ |
|
core_version $::punkboot::core_version \ |
|
main_script $::punkboot::main_script \ |
|
package_modes $package_modes \ |
|
proj_scope $proj_scope \ |
|
proj_root $proj_root \ |
|
kit_payload_base $boot_payload_base \ |
|
] |
|
if {[info exists src_project_root]} { |
|
dict set boot_state_dict src_project_root $src_project_root |
|
} |
|
namespace eval ::punkboot [list variable boot_state $boot_state_dict] |
|
|
|
#--------------------------------------------------------------- |
|
#Launcher help + declared-parse machinery (G-032) |
|
#The launch surface documents itself through punk::args (definition ids |
|
#from the punk::args::moduledoc::punkexe family): |
|
# <punkexe> help ?subcommand? tabled usage; the top-level table lists |
|
# built-ins AND project-registered |
|
# subcommands with summaries |
|
# <punkexe> -help same as bare 'help' - only on kits whose |
|
# unknownfirst default is 'script' (a |
|
# tool-style kit routes flags to its own |
|
# processor; its surface stays reachable |
|
# via the 'help' word) |
|
# <punkexe> <subcommand> -help the subcommand's tabled usage when -help |
|
# is its FIRST argument (tclsh: only when |
|
# -help is the SOLE argument - stock |
|
# parity keeps every other dash form in |
|
# ::argv; project subcommands: only when |
|
# the registration declares an argsid) |
|
#Everything is guarded and lazy (the G-030 degradation doctrine): nothing |
|
#here loads punk::args on a normal boot/dispatch path. When punk::args or |
|
#the moduledoc definitions are unavailable (or PUNKBOOT_PLAIN=1 - same |
|
#env hook as make.tcl), help degrades to a plain subcommand list, parse |
|
#gates degrade to the historic switch semantics, and boot never fails. |
|
#The tabled rendering additionally depends on the punk::ansi/textblock |
|
#stack - rendering degrades (minimal errorstyle) independently of parsing. |
|
#The per-kit top-level usage id (script)::punkexe.launcher is cloned from |
|
#the static (script)::punkexe definition at first render, with the |
|
#subcommand choices/choicelabels replaced by this kit's LIVE surface; |
|
#(script)::punkexe.launcherhelp is the same clone of |
|
#(script)::punkexe::help for subject validation. |
|
#--------------------------------------------------------------- |
|
namespace eval ::punkboot { |
|
variable help_flags [list -help --help -h /?] |
|
variable launch_builtin_subcommands [list] |
|
variable launch_subcommands [list] |
|
variable launcher_punkargs_state "" ;#"" unprobed | ok | plain |
|
variable launcher_builtin_summaries [dict create \ |
|
tclsh "Run as a (near) stock tclsh - no punk modules loaded." \ |
|
script "Run a script non-interactively in the punk script environment; honest exit codes." \ |
|
shell "Interactive punk shell (repl)." \ |
|
punk "punk shell launch; piped-stdin friendly." \ |
|
shellspy "Experimental shellspy command-line processor." \ |
|
buildinfo "Print the kit's build/identity stamp report and exit (G-025)." \ |
|
help "Show usage for the launch surface or one of its subcommands (G-032)." \ |
|
] |
|
proc launcher_punkargs_ready {} { |
|
#lazy guarded capability probe, one verdict per process. ok requires |
|
#punk::args AND the moduledoc launch definitions to load and resolve |
|
#with the snapshot actually available in this kit/context. |
|
variable launcher_punkargs_state |
|
if {$launcher_punkargs_state ne ""} { |
|
return [expr {$launcher_punkargs_state eq "ok"}] |
|
} |
|
set launcher_punkargs_state plain |
|
if {[info exists ::env(PUNKBOOT_PLAIN)] && [string is true -strict $::env(PUNKBOOT_PLAIN)]} { |
|
return 0 |
|
} |
|
if {[catch { |
|
package require punk::args |
|
#punk::args (and the punk::ansi/textblock render stack) call |
|
#punk::lib without requiring it (known module-web gap): on |
|
#Tcl 8.6 the choices-grid render path needs punk::lib's |
|
#forward-compat builtins (lpop etc). Guarded - require order |
|
#matters (punk::lib itself hard-requires punk::args, so this |
|
#call-time direction breaks no cycle); a kit without punk::lib |
|
#still probes ok and rendering degrades where it must. |
|
catch {package require punk::lib} |
|
package require punk::args::moduledoc::punkexe |
|
if {[punk::args::get_spec (script)::punkexe] eq ""} { |
|
error "definition (script)::punkexe did not resolve" |
|
} |
|
punk::args::get_spec (script)::punkexe::buildinfo |
|
punk::args::get_spec (script)::punkexe::help |
|
}]} { |
|
return 0 |
|
} |
|
set launcher_punkargs_state ok |
|
return 1 |
|
} |
|
proc launcher_errstyle {} { |
|
#tabled (standard) parse errors when the rendering stack is |
|
#loadable; minimal otherwise - rendering degrades independently of |
|
#parsing (the G-030 split) |
|
catch {package require punk::ansi} |
|
catch {package require textblock} |
|
if {[package provide punk::ansi] ne "" && [package provide textblock] ne ""} { |
|
return standard |
|
} |
|
return minimal |
|
} |
|
proc launcher_subcommand_summary {name} { |
|
#plain-text one-line summary for a known subcommand (built-in table |
|
#or the project registration's declared summary) |
|
variable launcher_builtin_summaries |
|
variable project_subcommand_info |
|
if {[dict exists $launcher_builtin_summaries $name]} { |
|
return [dict get $launcher_builtin_summaries $name] |
|
} |
|
if {[dict exists $project_subcommand_info $name summary]} { |
|
return [dict get $project_subcommand_info $name summary] |
|
} |
|
return "Project-declared subcommand (no summary registered)." |
|
} |
|
proc launcher_live_choices {} { |
|
#this kit's subcommand set in display order: the static definition's |
|
#choice order first (the documented built-in family), then 'help', |
|
#then project registrations in declaration order |
|
variable launch_subcommands |
|
set ordered [list] |
|
catch { |
|
set spec [punk::args::get_spec (script)::punkexe] |
|
foreach c [dict get $spec FORMS _default ARG_INFO subcommand -choices] { |
|
if {$c in $launch_subcommands && $c ni $ordered} { |
|
lappend ordered $c |
|
} |
|
} |
|
} |
|
foreach c $launch_subcommands { |
|
if {$c ni $ordered} { |
|
lappend ordered $c |
|
} |
|
} |
|
return $ordered |
|
} |
|
proc launcher_overview_id {} { |
|
#define (script)::punkexe.launcher: the per-kit top-level usage - |
|
#the moduledoc (script)::punkexe definition with the subcommand |
|
#choices/choicelabels replaced by this kit's live surface. |
|
#Returns the id, or "" when the clone cannot be built. |
|
variable launch_builtin_subcommands |
|
set id (script)::punkexe.launcher |
|
set existing "" |
|
catch {set existing [punk::args::raw_def $id]} |
|
if {$existing ne ""} { |
|
return $id |
|
} |
|
if {[catch { |
|
set spec [punk::args::get_spec (script)::punkexe] |
|
set labels [dict get $spec FORMS _default ARG_INFO subcommand -choicelabels] |
|
set choices [launcher_live_choices] |
|
foreach c $choices { |
|
if {$c eq "help" || $c ni $launch_builtin_subcommands || ![dict exists $labels $c]} { |
|
dict set labels $c " [launcher_subcommand_summary $c]" |
|
} |
|
} |
|
set ov [dict create \ |
|
@id [list -id $id] \ |
|
subcommand [list -choices $choices -choicelabels $labels] \ |
|
] |
|
punk::args::define [punk::args::resolved_def -override $ov (script)::punkexe] |
|
}]} { |
|
return "" |
|
} |
|
return $id |
|
} |
|
proc launcher_helpdef_id {} { |
|
#define (script)::punkexe.launcherhelp: the moduledoc |
|
#(script)::punkexe::help definition with the subject choices |
|
#replaced by the live subcommand set, so 'help <name>' validates |
|
#(and prefix-resolves) against what this kit actually offers. |
|
set id (script)::punkexe.launcherhelp |
|
set existing "" |
|
catch {set existing [punk::args::raw_def $id]} |
|
if {$existing ne ""} { |
|
return $id |
|
} |
|
if {[catch { |
|
set ov [dict create \ |
|
@id [list -id $id] \ |
|
subject [list -choices [launcher_live_choices]] \ |
|
] |
|
punk::args::define [punk::args::resolved_def -override $ov (script)::punkexe::help] |
|
}]} { |
|
return "" |
|
} |
|
return $id |
|
} |
|
proc launcher_plain_help {} { |
|
#degraded help: plain subcommand list built without punk::args |
|
set exebase [file rootname [file tail [info nameofexecutable]]] |
|
set lines [list] |
|
lappend lines "Usage: $exebase ?packagemode? ?subcommand? ?arg ...?" |
|
lappend lines " packagemode: ordered dash-separated list of internal|minted|os|src (default internal)," |
|
lappend lines " optionally scoped with the 'proj:' prefix (e.g proj:internal-src)" |
|
lappend lines " subcommands:" |
|
foreach sub [launcher_plain_choices] { |
|
lappend lines [format " %-12s %s" $sub [launcher_subcommand_summary $sub]] |
|
} |
|
lappend lines " ('$exebase help ?subcommand?' shows detail; plain list because the punk::args" |
|
lappend lines " tabled help stack is unavailable in this context, or PUNKBOOT_PLAIN is set)" |
|
return [join $lines \n] |
|
} |
|
proc launcher_plain_choices {} { |
|
#display order without punk::args: documented built-in order, then |
|
#project registrations in declaration order |
|
variable launch_subcommands |
|
set ordered [list] |
|
foreach c [list tclsh script shell punk shellspy buildinfo help] { |
|
if {$c in $launch_subcommands} { |
|
lappend ordered $c |
|
} |
|
} |
|
foreach c $launch_subcommands { |
|
if {$c ni $ordered} { |
|
lappend ordered $c |
|
} |
|
} |
|
return $ordered |
|
} |
|
proc launcher_show_help {{subject ""}} { |
|
#render help to stdout: the top-level launch surface (empty |
|
#subject) or one subcommand's usage. Tabled via punk::args when |
|
#available; degrades to the plain list/summary. Never errors. |
|
variable launch_builtin_subcommands |
|
variable project_subcommand_info |
|
if {[launcher_punkargs_ready]} { |
|
set id "" |
|
if {$subject eq ""} { |
|
set id [launcher_overview_id] |
|
} elseif {$subject eq "help"} { |
|
set id [launcher_helpdef_id] |
|
} elseif {$subject in $launch_builtin_subcommands} { |
|
set id (script)::punkexe::$subject |
|
} else { |
|
#project-registered: guarded require of the declared |
|
#package (if any), then the declared definition id (if any) |
|
if {[dict exists $project_subcommand_info $subject package]} { |
|
catch {package require [dict get $project_subcommand_info $subject package]} |
|
} |
|
if {[dict exists $project_subcommand_info $subject argsid]} { |
|
set id [dict get $project_subcommand_info $subject argsid] |
|
} else { |
|
#help by registration alone: the summary line |
|
puts stdout "$subject - [launcher_subcommand_summary $subject]" |
|
puts stdout "(no punk::args definition registered for this subcommand - if it is an application entry point it may provide its own -help handling)" |
|
return |
|
} |
|
} |
|
if {$id ne "" && ![catch {punk::args::usage $id} out]} { |
|
puts stdout $out |
|
return |
|
} |
|
#fall through to the plain forms on any render failure |
|
} |
|
if {$subject eq ""} { |
|
puts stdout [launcher_plain_help] |
|
} else { |
|
puts stdout "$subject - [launcher_subcommand_summary $subject]" |
|
puts stdout "(plain help: the punk::args tabled help stack is unavailable in this context, or PUNKBOOT_PLAIN is set)" |
|
} |
|
return |
|
} |
|
proc launcher_unknown_first_error {word} { |
|
#G-032 reclassification rule: an unknown first argument that names |
|
#no existing file (and is no lib:* scriptlib reference) is an |
|
#obvious mistake - refuse it with usage on stderr instead of |
|
#silently attempting it as a script. Returns 1 when the refusal |
|
#was emitted (caller exits 1); 0 when punk::args is unavailable |
|
#(caller falls back to the historic script reclassification). |
|
variable launch_subcommands |
|
if {![launcher_punkargs_ready]} { |
|
return 0 |
|
} |
|
set exebase [file rootname [file tail [info nameofexecutable]]] |
|
puts stderr "$exebase: unknown subcommand '$word' (no such subcommand, and no such script file exists)" |
|
set id [launcher_overview_id] |
|
if {$id ne "" && ![catch {punk::args::usage $id} out]} { |
|
puts stderr $out |
|
} else { |
|
puts stderr "known subcommands: [join [launcher_plain_choices] {, }]" |
|
} |
|
puts stderr "use '$exebase help' for the launch surface, or '$exebase script $word ?arg ...?' to force script interpretation" |
|
return 1 |
|
} |
|
} |
|
|
|
#--------------------------------------------------------------- |
|
#Subcommand selection (G-031 registration model) |
|
#Built-ins (tclsh/shellspy/punk/shell/script/buildinfo/help) ship with |
|
#this core; a thin main may extend the set via |
|
#::punkboot::project_subcommands (dict: name -> handler script, evaluated |
|
#in the dispatch below with ::argv/::argc holding the subcommand's |
|
#arguments). Built-in names cannot be shadowed - a colliding declaration |
|
#is reported and ignored. ::punkboot::project_subcommand_info optionally |
|
#carries per-name help/parse metadata (summary/argsid/package/parse - see |
|
#the launcher help section above, G-032). |
|
#::punkboot::launch_defaults keys (both optional): |
|
# noargs subcommand assumed for a bare launch (default: shell) |
|
# unknownfirst 'script' treats a non-subcommand first argument as a |
|
# script invocation (default), or the name of a known |
|
# subcommand to receive the whole arglist as its arguments |
|
#--------------------------------------------------------------- |
|
set builtin_subcommands [list tclsh shellspy punk shell script buildinfo help] |
|
set known_subcommands $builtin_subcommands |
|
foreach k [dict keys $::punkboot::project_subcommands] { |
|
if {$k in $builtin_subcommands} { |
|
puts stderr "main.tcl: project_subcommands entry '$k' shadows a built-in subcommand - ignored (built-ins cannot be overridden)" |
|
} elseif {$k ni $known_subcommands} { |
|
lappend known_subcommands $k |
|
} |
|
} |
|
#publish for the launcher help machinery (and post-boot probes) |
|
set ::punkboot::launch_builtin_subcommands $builtin_subcommands |
|
set ::punkboot::launch_subcommands $known_subcommands |
|
if {[dict exists $::punkboot::launch_defaults noargs]} { |
|
set default_noargs [dict get $::punkboot::launch_defaults noargs] |
|
} else { |
|
set default_noargs shell |
|
} |
|
if {[dict exists $::punkboot::launch_defaults unknownfirst]} { |
|
set default_unknownfirst [dict get $::punkboot::launch_defaults unknownfirst] |
|
} else { |
|
set default_unknownfirst script |
|
} |
|
set subcommand [lindex $arglist 0] |
|
if {$subcommand in $known_subcommands} { |
|
set subcommand_arglist [lrange $arglist 1 end] |
|
#G-032: a help flag as the subcommand's FIRST argument renders that |
|
#subcommand's usage. tclsh: only when it is the SOLE argument (stock |
|
#parity keeps every other leading-dash form - including '-help' with |
|
#further arguments - in ::argv); project subcommands: only when the |
|
#registration declares an argsid (a handler-only registration keeps |
|
#full passthrough - the application may do its own -help handling). |
|
if {[lindex $subcommand_arglist 0] in $::punkboot::help_flags} { |
|
set do_subhelp 0 |
|
if {$subcommand eq "tclsh"} { |
|
if {[llength $subcommand_arglist] == 1} { |
|
set do_subhelp 1 |
|
} |
|
} elseif {$subcommand in $builtin_subcommands} { |
|
set do_subhelp 1 |
|
} elseif {[dict exists $::punkboot::project_subcommand_info $subcommand argsid]} { |
|
set do_subhelp 1 |
|
} |
|
if {$do_subhelp} { |
|
::punkboot::launcher_show_help $subcommand |
|
exit 0 |
|
} |
|
} |
|
} else { |
|
set subcommand_arglist $arglist |
|
if {[llength $subcommand_arglist]} { |
|
#G-032: a help flag in first position is a launch-surface help |
|
#request on kits whose unknown-first default is 'script'. |
|
#Tool-style kits (unknownfirst names a project subcommand) keep |
|
#routing flags to their processor - their surface stays |
|
#discoverable via the 'help' subcommand word. |
|
if {$subcommand in $::punkboot::help_flags && $default_unknownfirst eq "script"} { |
|
::punkboot::launcher_show_help |
|
exit 0 |
|
} |
|
set subcommand $default_unknownfirst |
|
if {$subcommand eq "script"} { |
|
#G-032 unknown-first-arg reclassification rule (recorded in |
|
#goals/G-032-launcher-punkargs.md): reclassify to 'script' |
|
#only when the argument plausibly names a script - an |
|
#existing file path, or a lib:* scriptlib reference. Anything |
|
#else is refused with usage on stderr (exit 1); when |
|
#punk::args is unavailable the refusal degrades to the |
|
#historic always-reclassify behaviour. |
|
set unknown_word [lindex $subcommand_arglist 0] |
|
if {!([file exists $unknown_word] || [string match -nocase lib:* $unknown_word])} { |
|
if {[::punkboot::launcher_unknown_first_error $unknown_word]} { |
|
exit 1 |
|
} |
|
} |
|
} |
|
} else { |
|
set subcommand $default_noargs |
|
} |
|
} |
|
set ::argv $subcommand_arglist |
|
set ::argc [llength $subcommand_arglist] |
|
|
|
switch -- $subcommand { |
|
tclsh { |
|
#called as <executable> minted tclsh or <executable> tclsh |
|
#we would like to drop through to standard tclsh repl without launching another process |
|
#tclMain.c doesn't allow it unless patched. |
|
if {![info exists ::env(TCLSH_PIPEREPL)]} { |
|
set is_tclsh_piperepl_env_true 1 |
|
} else { |
|
if {[string is boolean -strict $::env(TCLSH_PIPEREPL)]} { |
|
set is_tclsh_piperepl_env_true $::env(TCLSH_PIPEREPL) |
|
} else { |
|
set is_tclsh_piperepl_env_true 1 |
|
} |
|
} |
|
if {$is_tclsh_piperepl_env_true && ![info exists ::tclsh(istty)]} { |
|
#runtime lacks the piperepl patch (a patched runtime with the gate open |
|
#publishes ::tclsh(istty) before this script runs). Informational only: |
|
#script-arg and piped forms work regardless; the interactive repl form |
|
#fails fast below. A deliberate TCLSH_PIPEREPL=0 opt-out stays quiet. |
|
puts stderr "note: the runtime doesn't appear to have been compiled with the piperepl patch" |
|
} |
|
#stock tclsh argument forms (tclMain.c): the only recognised leading option is |
|
#'-encoding name fileName' (and only when fileName does not begin with '-'); |
|
#any other leading '-' argument means NO script file - all arguments stay in |
|
#::argv (already set above) and tclsh proceeds to the repl (tty) or stdin |
|
#evaluation (piped). |
|
set tclsh_have_script 0 |
|
set tclsh_encoding "" |
|
if {[llength $subcommand_arglist] >= 3 && [lindex $subcommand_arglist 0] eq "-encoding" && ![string match -* [lindex $subcommand_arglist 2]]} { |
|
set tclsh_encoding [lindex $subcommand_arglist 1] |
|
set tclsh_script [lindex $subcommand_arglist 2] |
|
set tclsh_scriptargs [lrange $subcommand_arglist 3 end] |
|
set tclsh_have_script 1 |
|
} elseif {[llength $subcommand_arglist] && ![string match -* [lindex $subcommand_arglist 0]]} { |
|
set tclsh_script [lindex $subcommand_arglist 0] |
|
set tclsh_scriptargs [lrange $subcommand_arglist 1 end] |
|
set tclsh_have_script 1 |
|
} |
|
if {$tclsh_have_script} { |
|
if {[string match -nocase lib:* $tclsh_script]} { |
|
#scriptlib resolution is a punk facility - the tclsh subcommand keeps plain |
|
#tclsh semantics (no punk modules loaded), so point at the 'script' subcommand |
|
#instead of failing on a literal 'lib:...' path (illegal on windows filesystems |
|
#anyway; reachable via ./lib:... or an absolute path on other platforms). |
|
set exebase [file rootname [file tail [info nameofexecutable]]] |
|
puts stderr "punk tclsh: 'lib:' scriptlib resolution is not supported by the tclsh subcommand (plain tclsh semantics)" |
|
puts stderr " use: $exebase script $tclsh_script ?args...?" |
|
exit 1 |
|
} |
|
set normscript [file normalize $tclsh_script] |
|
if {![file exists $normscript]} { |
|
#not-found gets a clean message ('script' subcommand coherence); errors |
|
#from an existing script keep their full trace |
|
puts stderr "punk tclsh: script file not found: '$normscript'" |
|
exit 1 |
|
} |
|
info script $normscript |
|
set ::argv0 $normscript |
|
set ::argv $tclsh_scriptargs |
|
set ::argc [llength $::argv] |
|
#we are in an apply context here - so we need to uplevel to get the source to work as expected |
|
if {$tclsh_encoding ne ""} { |
|
uplevel 1 [list source -encoding $tclsh_encoding $tclsh_script] |
|
} else { |
|
uplevel 1 [list source $tclsh_script] |
|
} |
|
|
|
#default tclsh behaviour is to run the script and exit |
|
#the script can set ::tclsh(dorepl) 1 to force the tclsh repl after the script has run |
|
} else { |
|
#no script file: all arguments (if any) are already in ::argv, matching |
|
#stock tclsh; argv0 is the executable itself, not the kit boot script |
|
set ::argv0 [info nameofexecutable] |
|
if {[info exists ::tclsh(istty)]} { |
|
if {$::tclsh(istty)} { |
|
#tclsh piperepl patch applied - stdin is a tty - we can run the tclsh repl |
|
set ::tclsh(dorepl) 1 |
|
set ::tcl_interactive 1 |
|
} else { |
|
#stdin is not a tty - piped input is evaluated as a script, then exit |
|
set ::tclsh(dorepl) 0 |
|
set ::tcl_interactive 0 |
|
#script on stdin could set ::tclsh(dorepl) 1 to force the tclsh repl after the script has run |
|
set data [read stdin] |
|
uplevel 1 [list eval $data] |
|
} |
|
} else { |
|
#no piperepl machinery (unpatched runtime, or TCLSH_PIPEREPL=0): the |
|
#interactive repl is unavailable. Fail fast on terminal stdin instead of |
|
#blocking in a raw console read (app-punkscript terminal-probe precedent); |
|
#piped/redirected stdin keeps the evaluate-and-exit behaviour. |
|
set conf "" |
|
catch {set conf [chan configure stdin]} |
|
if {[dict exists $conf -inputmode] || [dict exists $conf -mode]} { |
|
set exebase [file rootname [file tail [info nameofexecutable]]] |
|
puts stderr "punk tclsh: the interactive tclsh repl requires a piperepl-capable runtime (this runtime lacks the patch, or TCLSH_PIPEREPL=0)" |
|
puts stderr "usage: <commands> | $exebase tclsh" |
|
puts stderr " or: $exebase tclsh <scriptfile> ?args...?" |
|
exit 1 |
|
} |
|
set ::tcl_interactive 0 |
|
set data [read stdin] |
|
uplevel 1 [list eval $data] |
|
} |
|
} |
|
} |
|
shellspy { |
|
#pass through to shellspy commandline processor |
|
#graceful when a derived kit does not carry the app package (0.2.1) |
|
if {[catch {package require app-shellspy} errM]} { |
|
puts stderr "shellspy: this kit does not carry the app-shellspy package ($errM)" |
|
exit 1 |
|
} |
|
} |
|
punk { |
|
#The punk executable must also support running commands piped into stdin. |
|
#e.g echo "puts hello" | punk |
|
#e.g from another tclsh-based shell: |
|
# exec punk << {puts hello} |
|
#Note that if the punk executable outputs anything to stderr - exec by default will treat the command as having failed and will throw an error. |
|
#So the punk executable should avoid outputting to stderr unless it is an actual error condition. |
|
#You can work around this by passing -ignorestderr to exec, but for tools like 'bench::locate' we need clean output. |
|
#(e.g bench::locate uses: |
|
# if {[catch {exec $ip << "exit"} result]} {...} |
|
#) |
|
|
|
if {[llength $subcommand_arglist]} { |
|
#puts stdout "main.tcl launching app-punkshell with args: $subcommand_arglist" |
|
if {[catch {package require app-punkshell} errM]} { |
|
puts stderr "punk: this kit does not carry the app-punkshell package ($errM)" |
|
exit 1 |
|
} |
|
} else { |
|
#punk interactive shell |
|
if {[catch {package require app-repl} errM]} { |
|
puts stderr "punk: this kit does not carry the app-repl package ($errM)" |
|
exit 1 |
|
} |
|
} |
|
} |
|
script { |
|
#run a script (file argument, or piped stdin when no argument) and exit - goal G-015 |
|
#lean dedicated app package: default punk shell module/alias environment, |
|
#no shellfilter stacks/transforms, no interactive fallback, honest exit codes. |
|
#The launch plumbing must emit nothing on stdout/stderr (exec-style callers). |
|
set ::tcl_interactive 0 |
|
if {[catch {package require app-punkscript} errM]} { |
|
puts stderr "script: this kit does not carry the app-punkscript package ($errM)" |
|
exit 1 |
|
} |
|
} |
|
shell { |
|
#app-punkshell supports running a script and maintaining an interactive shell afterwards |
|
# or just launching an interactive shell if no script is specified |
|
if {[catch {package require app-punkshell} errM]} { |
|
puts stderr "shell: this kit does not carry the app-punkshell package ($errM)" |
|
exit 1 |
|
} |
|
#if {[llength $subcommand_arglist]} { |
|
# #run script and maintain interactive shell. |
|
# package require app-punkshell |
|
#} else { |
|
# #punk interactive shell |
|
# package require app-repl |
|
#} |
|
} |
|
buildinfo { |
|
#G-025: machine-parseable build/identity report. The single |
|
#implementation is punk::buildinfo - this arm is the thin |
|
#exe-subcommand wrapper. Stdout carries only the report; honest |
|
#exit code; no repl fallthrough (G-015-compatible). |
|
#G-032: the argument contract ((script)::punkexe::buildinfo, |
|
#@values -min 0 -max 0) is enforced through punk::args when |
|
#available: any argument earns the historic one-line refusal PLUS |
|
#the tabled usage error on stderr, exit 2 (buildinfo.test pins the |
|
#one-liner and the exit code). The empty-argument fast path never |
|
#touches punk::args; a '-help' first argument was already |
|
#intercepted at selection. |
|
if {[llength $subcommand_arglist]} { |
|
puts stderr "buildinfo: takes no arguments" |
|
if {[::punkboot::launcher_punkargs_ready]} { |
|
if {[catch {punk::args::parse $subcommand_arglist -errorstyle [::punkboot::launcher_errstyle] withid (script)::punkexe::buildinfo} parse_msg]} { |
|
puts stderr $parse_msg |
|
} |
|
} |
|
exit 2 |
|
} |
|
if {[catch {package require punk::buildinfo} errM]} { |
|
puts stderr "buildinfo: the punk::buildinfo module is not available in this kit/context ($errM)" |
|
exit 1 |
|
} |
|
exit [punk::buildinfo::main] |
|
} |
|
help { |
|
#G-032: launcher help surface. Bare 'help' renders the top-level |
|
#tabled usage (built-ins + project-registered subcommands with |
|
#summaries); 'help <subcommand>' renders that subcommand's usage. |
|
#Subject validation parses through the launcherhelp clone when |
|
#punk::args is available (tabled choice errors on stderr exit 1, |
|
#unambiguous prefixes resolve); degraded mode accepts exact names |
|
#only and renders the plain forms. Help goes to stdout, exit 0 |
|
#(G-015 output-cleanliness/exit-code doctrine). |
|
if {![llength $subcommand_arglist]} { |
|
::punkboot::launcher_show_help |
|
exit 0 |
|
} |
|
if {[::punkboot::launcher_punkargs_ready]} { |
|
set helpdef_id [::punkboot::launcher_helpdef_id] |
|
if {$helpdef_id ne ""} { |
|
if {[catch {punk::args::parse $subcommand_arglist -errorstyle [::punkboot::launcher_errstyle] withid $helpdef_id} argd]} { |
|
puts stderr $argd |
|
exit 1 |
|
} |
|
set help_subject "" |
|
catch {set help_subject [dict get $argd values subject]} |
|
::punkboot::launcher_show_help $help_subject |
|
exit 0 |
|
} |
|
} |
|
#degraded: exact-name subject only |
|
set help_subject [lindex $subcommand_arglist 0] |
|
if {[llength $subcommand_arglist] > 1 || $help_subject ni $::punkboot::launch_subcommands} { |
|
puts stderr "help: expected 'help ?subcommand?' with subcommand one of: [join [::punkboot::launcher_plain_choices] {, }]" |
|
exit 1 |
|
} |
|
::punkboot::launcher_show_help $help_subject |
|
exit 0 |
|
} |
|
default { |
|
#a project-declared subcommand (thin-main customization point): the |
|
#handler script runs in this frame, ::argv/::argc already hold the |
|
#subcommand's arguments. The error branch is reachable only via a |
|
#misdeclared launch_defaults value - the selection above maps every |
|
#launch form to a known subcommand. |
|
if {[dict exists $::punkboot::project_subcommands $subcommand]} { |
|
#G-032 declared-parse gate: a registration may opt its |
|
#arguments into punk::args validation via |
|
#project_subcommand_info keys parse=1 + argsid (optional |
|
#package requirement). A parse failure is a tabled usage |
|
#error on stderr, exit 1, and the handler is not invoked. |
|
#Degrades to the historic no-validation passthrough when |
|
#punk::args (or the declared id) is unavailable. |
|
if {[dict exists $::punkboot::project_subcommand_info $subcommand parse] |
|
&& [string is true -strict [dict get $::punkboot::project_subcommand_info $subcommand parse]] |
|
&& [dict exists $::punkboot::project_subcommand_info $subcommand argsid] |
|
&& [::punkboot::launcher_punkargs_ready]} { |
|
if {[dict exists $::punkboot::project_subcommand_info $subcommand package]} { |
|
catch {package require [dict get $::punkboot::project_subcommand_info $subcommand package]} |
|
} |
|
set project_argsid [dict get $::punkboot::project_subcommand_info $subcommand argsid] |
|
set project_argsid_ok 0 |
|
catch {set project_argsid_ok [expr {[punk::args::raw_def $project_argsid] ne ""}]} |
|
if {$project_argsid_ok} { |
|
if {[catch {punk::args::parse $subcommand_arglist -errorstyle [::punkboot::launcher_errstyle] withid $project_argsid} parse_msg]} { |
|
puts stderr $parse_msg |
|
exit 1 |
|
} |
|
} |
|
} |
|
eval [dict get $::punkboot::project_subcommands $subcommand] |
|
} else { |
|
puts stderr "main.tcl: no handler for subcommand '$subcommand' (check launch_defaults in the kit's main.tcl) - known subcommands: $known_subcommands" |
|
exit 1 |
|
} |
|
} |
|
} |
|
#end of punkboot core (sourced by the kit's thin main.tcl - G-031)
|
|
|