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.
1302 lines
62 KiB
1302 lines
62 KiB
|
|
#source is at src/vfs/_config/punk_main.tcl |
|
|
|
#This main script will consume a first argument of the form dev|os|internal |
|
# or any dash-delimited combination such as dev-os |
|
# |
|
#The default when omitted is 'internal' which limits the auto_path and tcl::tm::path to packages |
|
#provided from within the executable's vfs (either metakit or zipkit based) |
|
|
|
#By providing the facility to specify an ordered list of preferred package locations, |
|
#finer control over what package paths are searched can be made. |
|
|
|
#It is recommended that that this facility is left in place unless it conflicts with specific needs of the application. |
|
|
|
|
|
#main.tcl - we expect to be in the context of a zipkit or tclkit vfs attached to a tcl executable. |
|
# (or possibly cookfs) |
|
#review - what happens if multiple are somehow attached and for example both vfs and zipfs are available? |
|
# - if that's even possible - we have no control here over which main.tcl was selected as we're already here |
|
# a metakit data portion seems to need to be add the end of the file (from looking at sdx.kit code) |
|
# - todo - investigate if zipfs can be inserted between starkit head executable and metakit tail data |
|
#The logic below will add appropriate package paths from starkit and zipfs vfs paths |
|
# - and restrict package paths to those coming from a vfs (if not launched with 'dev' or 'os' first arg which allows external paths to remain) |
|
|
|
apply { 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_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. |
|
set parts [split [platform_generic] -] |
|
set cpu [lindex $parts end] |
|
set os [join [lrange $parts 0 end-1] -] |
|
if {$os eq "macos"} {set os macosx} |
|
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 |
|
} |
|
} |
|
|
|
set has_zipfs [expr {[info commands tcl::zipfs::root] ne ""}] |
|
if {$has_zipfs} { |
|
set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}] |
|
} else { |
|
set has_zipfs_attached 0 |
|
} |
|
|
|
#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. |
|
|
|
#standard way to avoid symlinking issues - review! |
|
set normscript [file dirname [file normalize [file join [info script] __dummy__]]] |
|
|
|
#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 {$has_zipfs_attached} { |
|
if {[file exists [zipfs root]/app/tcl_library]} { |
|
lappend possible_lib_vfs_folders {*}[glob -nocomplain -dir [zipfs root]/app/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 'dev' 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 'dev' 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 {$has_zipfs_attached} { |
|
#review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. (why?) |
|
#default 'zipfs root' has trailing slash (//zipfs:/) - but file join does the right thing |
|
set zipbase [file join [tcl::zipfs::root] app] |
|
if {"$zipbase" in [tcl::zipfs::mount]} { |
|
#set existing_module_paths [string tolower [tcl::tm::list]] |
|
foreach p [list modules modules_tcl$tclmajorv] { |
|
#if {[string tolower [file join $zipbase $p]] ni $existing_module_paths} { |
|
# tcl::tm::add [file join $zipbase $p] |
|
#} |
|
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} { |
|
set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path |
|
lappend internal_paths $ziproot |
|
} |
|
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 |
|
} |
|
|
|
|
|
# ----------------------------------------------------------------------------------------------------------- |
|
# dev - 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 dev os internal src] |
|
#package_mode is specified as a dash-delimited ordered value e.g dev-os |
|
#"internal" is the default and if not present is always added to the list |
|
#i.e "dev-os" is equivalent to "dev-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. |
|
set package_modes "" |
|
set arglist "" |
|
if {$test_package_mode eq ""} { |
|
#empty first arg consumed as equivalent of 'internal' |
|
set package_modes internal |
|
set arglist [lrange $args 1 end] |
|
} else { |
|
set tokens [split $test_package_mode -] |
|
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 |
|
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) |
|
#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 'dev' 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 dev 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 {"dev" in $package_modes} { |
|
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 dev foldersl. 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]} { |
|
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 dev 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} { |
|
#reuse the dev-mode project root discovery (exe in bin/ -> backtrack 1) |
|
set src_project_root "" |
|
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 { |
|
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 |
|
} |
|
} |
|
} |
|
dev { |
|
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 'dev' mode (dev 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 {"dev" 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] |
|
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 |
|
} |
|
} |
|
} |
|
dev { |
|
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/_build/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] |
|
if {![string match //zipfs:/* $scriptdir] && ![string match "${cookbase}*" $scriptdir] && ![info exists ::tcl::kitpath]} { |
|
#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/_build/exename.vfs instead |
|
set vfsdir [file normalize $scriptdir] |
|
set projectroot [file dirname [file dirname $vfscontainer]] ;#back below src/_build/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 'dev|os|os-dev 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 _build subdirectories |
|
if {[string match "*_build*" $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__} |
|
} |
|
|
|
#tclsh,shellspy,punk,script,shell |
|
set subcommand [lindex $arglist 0] |
|
switch -- $subcommand { |
|
tclsh - shellspy - punk - shell - script { |
|
set subcommand_arglist [lrange $arglist 1 end] |
|
} |
|
default { |
|
set subcommand_arglist $arglist |
|
if {[llength $subcommand_arglist]} { |
|
set subcommand script |
|
} else { |
|
set subcommand shell |
|
} |
|
} |
|
} |
|
set ::argv $subcommand_arglist |
|
set ::argc [llength $subcommand_arglist] |
|
|
|
switch -- $subcommand { |
|
tclsh { |
|
#called as <executable> dev 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 0 |
|
} 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 0 |
|
} |
|
} |
|
if {!$is_tclsh_piperepl_env_true} { |
|
puts stderr "tcl_interactive: $::tcl_interactive" |
|
puts stderr "stdin: [chan configure stdin]" |
|
puts stderr "Environment variable TCLSH_PIPEREPL is not set or is false or is not a boolean" |
|
} else { |
|
#according to env TCLSH_PIPEREPL and our commandline argument - tclsh repl is desired |
|
#check if tclsh/punk has had the piperepl patch applied - in which case tclsh(istty) should exist |
|
if {![info exists ::tclsh(istty)]} { |
|
puts stderr "error: the runtime doesn't appear to have been compiled with the piperepl patch" |
|
} |
|
} |
|
set ::tcl_interactive 1 |
|
set ::tclsh(dorepl) 1 |
|
if {[llength $subcommand_arglist]} { |
|
set normscript [file normalize [lindex $subcommand_arglist 0]] |
|
info script $normscript |
|
set ::argv0 $normscript |
|
set ::argv [lrange $subcommand_arglist 1 end] |
|
set ::argc [llength $::argv] |
|
#we are in an apply context here - so we need to uplevel to get the source to work as expected |
|
uplevel 1 [list source [lindex $subcommand_arglist 0]] |
|
} |
|
} |
|
shellspy { |
|
#pass through to shellspy commandline processor |
|
package require app-shellspy |
|
} |
|
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" |
|
package require app-punkshell |
|
} else { |
|
#punk interactive shell |
|
package require app-repl |
|
} |
|
} |
|
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 |
|
package require app-punkscript |
|
} |
|
shell { |
|
#app-punkshell supports running a script and maintaining an interactive shell afterwards |
|
# or just launching an interactive shell if no script is specified |
|
package require app-punkshell |
|
#if {[llength $subcommand_arglist]} { |
|
# #run script and maintain interactive shell. |
|
# package require app-punkshell |
|
#} else { |
|
# #punk interactive shell |
|
# package require app-repl |
|
#} |
|
} |
|
} |
|
|
|
|
|
#if {[llength $arglist] == 1 && [lindex $arglist 0] eq "tclsh"} { |
|
#} elseif {[lindex $arglist 0] eq "shellspy"} { |
|
#} elseif {[llength $arglist]} { |
|
#} else { |
|
#} |
|
}} {*}$::argv
|
|
|