#main.tcl - we expect to be in the context of a zipkit or tclkit vfs attached to a tcl executable. # or 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' first arg which allows external paths to remain) apply { args { set tclmajorv [lindex [split [info tclversion] .] 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__]]] set normexe [file dirname [file normalize [file join [info nameofexecutable] __dummy__]]] 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*] foreach test_folder $possible_lib_vfs_folders { #e.g /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 } } if {[set starkitv [lindex [package versions starkit] end]] ne ""} { #run the ifneeded script for the latest found (assuming package versions ordering is correct) eval [package ifneeded starkit $starkitv] set found_starkit_tcl 1 } 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] 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 this context (vfs attached to tcl kit executable - we expect the launch mode to be 'starkit' set starkit_startmode [starkit::startup] 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] } # -- --- --- if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} { set kp $::tcl::kitpath 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] } } foreach l [list lib lib_tcl$tclmajorv] { if {[string tolower [file join $kp $l]] ni [string tolower $::auto_path]} { lappend ::auto_path [file join $kp $l] } } } 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] } } foreach l [list lib lib_tcl$tclmajorv] { if {[string tolower [file join $zipbase $l]] ni [string tolower $::auto_path]} { lappend ::auto_path [file join $zipbase $l] } } } } 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] } } foreach l [list lib lib_tcl$tclmajorv] { if {[string tolower [file join $cookbase $l]] ni [string tolower $::auto_path]} { lappend ::auto_path [file join $cookbase $l] } } } 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 } if {[info exists ::punkboot::internal_paths] && [llength $::punkboot::internal_paths]} { #somewhat ugly cooperation with external sourcing scripts lappend internal_paths {*}$::punkboot::internal_paths } if {[lindex $args 0] in {dev devquiet}} { set arglist [lassign $args devmode] set ::argv $arglist set ::argc [llength $arglist] if {$devmode ne "devquiet"} { puts stderr "DEV MODE - preferencing external libraries and modules" } #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 package support unloading a binary component #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, 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) #------------------------------------------------------------------------------ #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 front (probably from the kit looking at various env TCL* values) #we want to maintain the order of the internal paths. #we then want to add our external dev paths of the total list #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 { 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 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 [info nameofexecutable]] #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 {$devmode ne "devquiet" && ![llength $exe_module_folders]} { puts stderr "Warning - no 'modules' or 'modules_tcl$tclmajorv' folders found relative to executable (or it's symlink if any)" } #add lib and lib_tcl8 lib_tcl9 etc based on tclmajorv #libs are appended to end - so add higher priority libraries last (opposite to modules) #auto_path - add exe-relative after exe-relative path if {"windows" eq $::tcl_platform(platform)} { #case differences dont matter - but can stop us finding path in auto_path 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 {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} { lappend ::auto_path $libfolder } # ------------- if {[file tail $normexe_dir] eq "bin"} { set libfolder [file dirname $normexe_dir]/$libsub } else { set libfolder $normexe_dir/$libsub } if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} { lappend ::auto_path $libfolder } # ------------- set libfolder [pwd]/$libsub if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} { lappend ::auto_path $libfolder } } } else { #on other platforms, case differences could represent different paths 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 {$libfolder ni $::auto_path && [file isdirectory $libfolder]} { lappend ::auto_path $libfolder } # ------------- if {[file tail $normexe_dir] eq "bin"} { set libfolder [file dirname $normexe_dir]/$libsub } else { set libfolder $normexe_dir/$libsub } if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} { lappend ::auto_path $libfolder } # ------------- set libfolder [pwd]/$libsub if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} { lappend ::auto_path $libfolder } } } #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 currentdir_modules [glob -nocomplain -dir [pwd] -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) #catch {tcl::tm::add [pwd]} set external_tm_dirs [linsert $external_tm_dirs 0 $currentdir_modules] if {$devmode ne "devquiet" && ([file exists [pwd]/modules] || [file exists [pwd]/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 normalize [file join [pwd] modules]] 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 normalize [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 #add internals first 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]} { #the prior tm paths go to the head of the list. #They are processed first.. but an item of same version later in the list will override one at the head. (depending on when list was scanned) REVIEW - true statement??? #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" } } } 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" } } } #------------------------------------------------------------------------------ #REVIEW #package require a bogus package to ensure Tcl scans the whole auto_path/tm list - otherwise a lower-versioned module earlier in the path may be loaded #This seems to take not insignificant time depending on size of auto_path and tcl::tm::list (e.g 2023 i9 ssd 100ms) - but seems unavoidable for now #catch {package require flobrudder666_nonexistant} #------------------------------------------------------------------------------ } else { #not dev/devquiet #Tcl_Init will most likely have set up some external paths #As our app has been started without the 'dev' first arg - we will prune paths that are not zipfs or tclkit #(or set via punkboot::internal_paths) set new_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 new_auto_path $ap break } } } set ::auto_path $new_auto_path #puts stderr "internal_paths: $internal_paths" set new_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 new_tm_list $tm break } } } 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]]} { lappend ::auto_path [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 $::auto_path]} { lappend ::auto_path $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 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 # } #} } #force rescan #catch {package require flobrudder666_nonexistant} set arglist $args } #assert arglist has had 'dev' first arg removed if it was present. if {[llength $arglist] == 1 && [lindex $arglist 0] eq "tclsh"} { #called as dev tclsh or 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 } elseif {[llength $arglist]} { #pass through to shellspy commandline processor #puts stdout "main.tcl launching app-shellspy" package require app-shellspy } else { #punk shell #todo logger ? #puts stdout "main.tcl launching app-punk. pkg names count:[llength [package names]]" #puts ">> $::auto_path" #puts ">>> [tcl::tm::list]" package require app-punk #app-punk starts repl #repl::start stdin -title "main.tcl" } }} {*}$::argv