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.
2953 lines
149 KiB
2953 lines
149 KiB
# tcl |
|
# |
|
# punkboot - make any tclkits and modules in <projectdir>/src folders and place them and associated data files/scripts in the parent folder of src. |
|
#e.g in 'bin' and 'modules' folders at same level as 'src' folder. |
|
if {[info exists ::env(NO_COLOR)]} { |
|
namespace eval ::punk::console {variable colour_disabled 1} |
|
} |
|
set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" |
|
puts $hashline |
|
puts " Punk Boot" |
|
puts $hashline\n |
|
|
|
package prefer latest |
|
lassign [split [info tclversion] .] tclmajorv tclminorv |
|
|
|
global A ;#UI Ansi code array |
|
array set A {} |
|
|
|
namespace eval ::punkboot { |
|
variable scriptfolder [file normalize [file dirname [info script]]] |
|
variable foldername [file tail $scriptfolder] |
|
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] |
|
variable non_help_flags [list -k] |
|
variable help_flags [list -help --help /? -h] |
|
variable known_commands [list project modules vfs info check shell vendorupdate bootsupport vfscommonupdate] |
|
} |
|
|
|
|
|
|
|
namespace eval ::punkboot::lib { |
|
proc tm_version_isvalid {versionpart} { |
|
#Needs to be suitable for use with Tcl's 'package vcompare' |
|
if {![catch [list package vcompare $versionpart $versionpart]]} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
proc tm_version_major {version} { |
|
if {![tm_version_isvalid $version]} { |
|
error "Invalid version '$version' is not a proper Tcl module version number" |
|
} |
|
set firstpart [lindex [split $version .] 0] |
|
#check for a/b in first segment |
|
if {[string is integer -strict $firstpart]} { |
|
return $firstpart |
|
} |
|
if {[string first a $firstpart] > 0} { |
|
return [lindex [split $firstpart a] 0] |
|
} |
|
if {[string first b $firstpart] > 0} { |
|
return [lindex [split $firstpart b] 0] |
|
} |
|
error "tm_version_major unable to determine major version from version number '$version'" |
|
} |
|
proc tm_version_canonical {ver} { |
|
#accepts a single valid version only - not a bounded or unbounded spec |
|
if {![tm_version_isvalid $ver]} { |
|
error "tm_version_canonical version '$ver' is not valid for a package version" |
|
} |
|
set parts [split $ver .] |
|
set newparts [list] |
|
foreach o $parts { |
|
set trimmed [string trimleft $o 0] |
|
set firstnonzero [string index $trimmed 0] |
|
switch -exact -- $firstnonzero { |
|
"" { |
|
lappend newparts 0 |
|
} |
|
a - b { |
|
#e.g 000bnnnn -> bnnnnn |
|
set tailtrimmed [string trimleft [string range $trimmed 1 end] 0] |
|
if {$tailtrimmed eq ""} { |
|
set tailtrimmed 0 |
|
} |
|
lappend newparts 0$firstnonzero$tailtrimmed |
|
} |
|
default { |
|
#digit |
|
if {[string is integer -strict $trimmed]} { |
|
#e.g 0100 -> 100 |
|
lappend newparts $trimmed |
|
} else { |
|
#e.g 0100b003 -> 100b003 (still need to process tail) |
|
if {[set apos [string first a $trimmed]] > 0} { |
|
set lhs [string range $trimmed 0 $apos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch |
|
set rhs [string range $trimmed $apos+1 end] ;#assert rhs non-empty and only digits |
|
set rhs [string trimleft $rhs 0] |
|
if {$rhs eq ""} { |
|
set rhs 0 |
|
} |
|
lappend newparts ${lhs}a${rhs} |
|
} elseif {[set bpos [string first b $trimmed]] > 0} { |
|
set lhs [string range $trimmed 0 $bpos-1] ;#assert lhs non-empty and only digits or wouldn't be in this branch |
|
set rhs [string range $trimmed $bpos+1 end] ;#assert rhs non-empty and only digits |
|
set rhs [string trimleft $rhs 0] |
|
if {$rhs eq ""} { |
|
set rhs 0 |
|
} |
|
lappend newparts ${lhs}b${rhs} |
|
} else { |
|
#assert - shouldn't get here trimmed val should have been empty, an int or contained an a or b |
|
error "tm_version_canonical error - trimfail - unexpected" |
|
} |
|
} |
|
} |
|
} |
|
} |
|
return [join $newparts .] |
|
} |
|
proc tm_version_required_canonical {versionspec} { |
|
#also trim leading zero from any dottedpart? |
|
#Tcl *allows* leading zeros in any of the dotted parts - but they are not significant. |
|
#e.g 1.01 is equivalent to 1.1 and 01.001 |
|
#also 1b3 == 1b0003 |
|
|
|
if {[string trim $versionspec] eq ""} {return ""} ;#unspecified = any version |
|
set errmsg "punkboot::lib::tm_version_required_canonical - invalid version specification" |
|
if {[string first - $versionspec] < 0} { |
|
#no dash |
|
#looks like a minbounded version (ie a single version with no dash) convert to min-max form |
|
set from $versionspec |
|
if {![::punkboot::lib::tm_version_isvalid $from]} { |
|
error "$errmsg '$versionpec'" |
|
} |
|
if {![catch {::punkboot::lib::tm_version_major $from} majorv]} { |
|
set from [tm_version_canonical $from] |
|
return "${from}-[expr {$majorv +1}]" |
|
} else { |
|
error "$errmsg '$versionspec'" |
|
} |
|
} else { |
|
# min- or min-max |
|
#validation and canonicalisation (strip leading zeroes from each segment, including either side of a or b) |
|
set parts [split $versionspec -] ;#we expect only 2 parts |
|
lassign $parts from to |
|
if {![::punkboot::lib::tm_version_isvalid $from]} { |
|
error "$errmsg '$versionspec'" |
|
} |
|
set from [tm_version_canonical $from] |
|
if {[llength $parts] == 2} { |
|
if {$to ne ""} { |
|
if {![::punkboot::lib::tm_version_isvalid $to]} { |
|
error "$errmsg '$versionspec'" |
|
} |
|
set to [tm_version_canonical $to] |
|
return $from-$to |
|
} else { |
|
return $from- |
|
} |
|
} else { |
|
error "$errmsg '$versionspec'" |
|
} |
|
error "tm_version_required_canonical should have already returned a canonicalised versionspec - or produced an error with reason before this point" |
|
} |
|
} |
|
|
|
} |
|
|
|
if {"::try" ni [info commands ::try]} { |
|
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" |
|
exit 1 |
|
} |
|
|
|
#------------------------------------------------------------------------------ |
|
#Module loading from src/bootsupport or [pwd]/modules if pwd is a 'src' folder |
|
#------------------------------------------------------------------------------ |
|
#If there is a folder under the current directory, in the subpath src/bootsupport/modules which contains .tm files |
|
# - then it will attempt to preference these modules |
|
# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the boot script |
|
# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables |
|
set startdir [pwd] |
|
#we are focussed on pure-tcl libs/modules in bootsupport for now. |
|
#There may be cases where we want to use compiled packages from src/bootsupport/modules_tcl9 etc |
|
#REVIEW - punkboot can really speed up with appropriate accelerators and/or external binaries |
|
# - we need to support that without binary downloads from repos unless the user explicitly asks for that. |
|
# - They may already be available in the vfs (or pointed to package paths) of the running executable. |
|
# - todo: some user prompting regarding installs with platform-appropriate package managers |
|
# - todo: some user prompting regarding building accelerators from source. |
|
|
|
# ------------------------------------------------------------------------------------- |
|
set bootsupport_module_paths [list] |
|
set bootsupport_library_paths [list] |
|
if {[file exists [file join $startdir src bootsupport]]} { |
|
lappend bootsupport_module_paths [file join $startdir src bootsupport modules] |
|
lappend bootsupport_module_paths [file join $startdir src bootsupport modules_tcl$::tclmajorv] |
|
lappend bootsupport_library_paths [file join $startdir src bootsupport lib] |
|
lappend bootsupport_library_paths [file join $startdir src bootsupport lib_tcl$::tclmajorv] |
|
} else { |
|
lappend bootsupport_module_paths [file join $startdir bootsupport modules] |
|
lappend bootsupport_module_paths [file join $startdir bootsupport modules_tcl$::tclmajorv] |
|
lappend bootsupport_library_paths [file join $startdir bootsupport lib] |
|
lappend bootsupport_library_paths [file join $startdir bootsupport lib_tcl$::tclmajorv] |
|
} |
|
set bootsupport_paths_exist 0 |
|
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] { |
|
if {[file exists $p]} { |
|
set bootsupport_paths_exist 1 ;#at least one exists |
|
break |
|
} |
|
} |
|
# ------------------------------------------------------------------------------------- |
|
# ------------------------------------------------------------------------------------- |
|
set sourcesupport_module_paths [list] |
|
set sourcesupport_library_paths [list] |
|
set sourcesupport_paths_exist 0 |
|
#we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir. |
|
#The <projectdir>/modules are the very modules we are building - and may be in a broken state, which punkboot then can't fix. |
|
#The 'building' is generally just assigning a version instead of 999999.0a1 (and some doc string substitution?) |
|
#(most?) Modules in src/modules etc should still be runnable directly in certain cases like this where we point to them. |
|
if {[file tail $startdir] eq "src"} { |
|
#todo - other src 'module' dirs.. |
|
foreach p [list $startdir/modules $startdir/modules_tcl$::tclmajorv $startdir/vendormodules $startdir/vendormodules_tcl$::tclmajorv] { |
|
if {[file exists $p]} { |
|
lappend sourcesupport_module_paths $p |
|
} |
|
} |
|
# -- -- -- |
|
foreach p [list $startdir/lib $startdir/lib_tcl$::tclmajorv $startdir/vendorlib $startdir/vendorlib_tcl$::tclmajorv] { |
|
if {[file exists $p]} { |
|
lappend sourcesupport_library_paths $p |
|
} |
|
} |
|
# -- -- -- |
|
|
|
foreach p [list {*}$sourcesupport_module_paths {*}$sourcesupport_library_paths] { |
|
if {[file exists $p]} { |
|
set sourcesupport_paths_exist 1 |
|
break |
|
} |
|
} |
|
|
|
if {$sourcesupport_paths_exist} { |
|
#launch from <projectdir/src is also likely to be common |
|
# but we need to be loud about what's going on. |
|
puts stderr "------------------------------------------------------------------" |
|
puts stderr "Launched from within a folder ending in 'src'" |
|
puts stderr " - modules in $startdir/modules $startdir/lib (etc) may override bootsupport modules" |
|
puts stderr "------------------------------------------------------------------" |
|
} |
|
} |
|
# ------------------------------------------------------------------------------------- |
|
|
|
set package_paths_modified 0 |
|
if {$bootsupport_paths_exist || $sourcesupport_paths_exist} { |
|
set original_tm_list [tcl::tm::list] |
|
tcl::tm::remove {*}$original_tm_list |
|
set original_auto_path $::auto_path |
|
|
|
#very basic test there is something there.. |
|
set support_contents_exist 0 |
|
foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths {*}$sourcesupport_module_paths {*}$sourcesupport_library_paths] { |
|
set contents [glob -nocomplain -dir $p -tail *] |
|
if {[llength $contents]} { |
|
set support_contents_exist 1 |
|
break |
|
} |
|
} |
|
|
|
set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk] |
|
if {$support_contents_exist} { |
|
#only forget all *unloaded* package names |
|
foreach pkg [package names] { |
|
if {$pkg in $tcl_core_packages} { |
|
continue |
|
} |
|
if {![llength [package versions $pkg]]} { |
|
#puts stderr "Got no versions for pkg $pkg" |
|
continue |
|
} |
|
if {![string length [package provide $pkg]]} { |
|
#no returned version indicates it wasn't loaded - so we can forget its index |
|
package forget $pkg |
|
} |
|
} |
|
#tcl::tm::add {*}$original_tm_list {*}$bootsupport_module_paths {*}$sourcesupport_module_paths |
|
#set ::auto_path [list {*}$original_auto_path {*}$bootsupport_library_paths {*}$sourcesupport_library_paths] |
|
tcl::tm::add {*}$bootsupport_module_paths {*}$sourcesupport_module_paths |
|
set ::auto_path [list {*}$bootsupport_library_paths {*}$sourcesupport_library_paths] |
|
} |
|
puts "----> auto_path $::auto_path" |
|
|
|
|
|
|
|
#package require Thread |
|
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly. |
|
|
|
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list |
|
#These are strong dependencies |
|
package forget punk::mix |
|
package forget punk::repo |
|
package forget punkcheck |
|
|
|
package require punk::repo ;#todo - push our requirements to a smaller punk::repo::xxx package with minimal dependencies |
|
package require punk::mix |
|
package require punkcheck |
|
package require punk::lib |
|
package require punk::args |
|
package require punk::ansi |
|
|
|
set package_paths_modified 1 |
|
|
|
#------------------------------------------------------------------------------ |
|
} |
|
|
|
set ::punkboot::pkg_requirements_found [list] |
|
|
|
#we will treat 'package require <mver>.<etc>' (minbounded) as <mver>.<etc>-<mver+1> ie explicitly convert to corresponding bounded form |
|
#put some with leading zeros to test normalisation |
|
set ::punkboot::bootsupport_requirements [dict create\ |
|
punk::repo [list version "00.01.01-"]\ |
|
punk::mix [list version ""]\ |
|
punk::ansi [list]\ |
|
punk::args [list]\ |
|
overtype [list version "1.6.5-"]\ |
|
punkcheck [list]\ |
|
fauxlink [list version "0.1.1-"]\ |
|
textblock [list version 0.1.1-]\ |
|
fileutil::traverse [list]\ |
|
md5 [list version 2-]\ |
|
] |
|
|
|
#while we are converting plain version numbers to explicit bounded form - we'll also do some validation of the entries |
|
dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { |
|
if {[dict exists $pkginfo version]} { |
|
set ver [string trim [dict get $pkginfo version]] |
|
if {![catch {::punkboot::lib::tm_version_required_canonical $ver} canonical]} { |
|
if {$canonical ne $ver} { |
|
dict set pkginfo version $canonical ;# plain ver mapped to min-max. min- and min-max and empty left as is |
|
dict set ::punkboot::bootsupport_requirements $pkg $pkginfo |
|
} |
|
} else { |
|
puts stderr "punkboot::bootsupport_requirements - package $pkg has invalid version specification '$ver'" |
|
exit 1 |
|
} |
|
} else { |
|
#make sure each has a blank version entry if nothing was there. |
|
dict set pkginfo version "" |
|
dict set ::punkboot::bootsupport_requirements $pkg $pkginfo |
|
} |
|
} |
|
#Assert - our bootsupport_requirement version numbers should now be either empty or of the form min- or min-max |
|
#dict for {k v} $::punkboot::bootsupport_requirements { |
|
# puts "- $k $v" |
|
#} |
|
|
|
#some of our toplevel package specified in bootsupport_requirements may trigger 'package require' for dependencies that we know are optional/not required. |
|
#By listing them here we can produce better warnings |
|
set ::punkboot::bootsupport_optional [dict create\ |
|
tcllibc [list -note {improves performance significantley}]\ |
|
twapi [list]\ |
|
patternpunk [list]\ |
|
cryptkit [list -note {accelerates some packages}]\ |
|
Trf [list -note {accelerates some packages}]\ |
|
] |
|
set ::punkboot::bootsupport_recommended [dict create\ |
|
tcllibc [list -note {improves performance significantley}]\ |
|
] |
|
|
|
# ** *** *** *** *** *** *** *** *** *** *** *** |
|
# create an interp in which we hijack package command |
|
# This allows us to auto-gather some dependencies (not necessarily all and not necessarily strictly required) |
|
# Note: even in a separate interp we could still possibly get side-effects if a package has compiled components - REVIEW |
|
# Hopefully the only side-effect is that a subsequent load of the package will be faster... |
|
# (punk boot is intended to operate without compiled components - but some could be pulled in by tcl modules if they're found) |
|
# (tcllibc is also highly desirable as the performance impact when not available can be dramatic.) |
|
# ... but if the binary is loaded with a different path name when we come to actually use it - there could be issues. |
|
# A truly safe way to do this might be to call out to a separate process, or to relaunch after checks. (todo?) |
|
# A truly accurate way to do this is to have dependencies properly recorded for every package - |
|
# something the package developer would have to provide - or an analyst would have to determine by looking at the code. |
|
# (to check for 'package require' statements that are actually optional, one-or-more-of-n, mutually-exclusive, anti-requirements etc) |
|
# Such information may also vary depending on what features of the package are to be used here - so it's a tricky problem. |
|
# |
|
# Nevertheless - the auto-determination can be a useful warning to the punk boot developer that something may be missing in the bootsupport. |
|
# |
|
# A further auto-determination for optionality could potentially be done in yet another interp by causing package require to fake-error on a dependency - |
|
# and see if the parent still loads. This would still be more time and complexity for a still uncertain result. |
|
# e.g a package may be a strong requirement for the package being examined iff another optional package is present (which doesn't itself require that dependency) |
|
# - it's unclear that reasonable determinations always can be made. |
|
# There are also packages that aren't required during one package's load - but are required during certain operations. |
|
# ** *** *** *** *** *** *** *** *** *** *** *** |
|
proc ::punkboot::check_package_availability {args} { |
|
#best effort at auto-determinining packages required (dependencies) based on top-level packages in the list. |
|
#Without fully parsing the package-loading Tcl scripts and examining all side-effects (an unlikely capability), |
|
# this is not going to be as accurate as the package developer providing a definitive list of which packages are required and which are optional. |
|
# 'optionality' is a contextual concept anyway depending on how the package is intended to be used. |
|
# The package developer may consider a feature optional - but it may not be optional in a particular usecase. |
|
|
|
set bootsupport_requirements [lindex $args end] |
|
set usage "punkboot::check_package_availability ?-quiet 0|1? package_list" |
|
if {![llength $bootsupport_requirements]} { |
|
error "usage: $usage" |
|
} |
|
set opts [lrange $args 0 end-1] |
|
if {[llength $opts] % 2 != 0} { |
|
error "incorrect number of arguments. usage: $usage" |
|
} |
|
set defaults [dict create\ |
|
-quiet 1\ |
|
] |
|
set opts [dict merge $defaults $opts] |
|
set opt_quiet [dict get $opts -quiet] |
|
|
|
interp create testpkgs |
|
interp eval testpkgs [list package prefer [package prefer]] |
|
interp eval testpkgs { |
|
namespace eval ::test {} |
|
set ::test::pkg_requested [list] ;#list of pairs (pkgname version_requested) version_requested is 'normalised' (min- /min-max only) or empty |
|
set ::test::pkg_loaded [list] |
|
set ::test::pkg_missing [list] |
|
set ::test::pkg_broken [list] |
|
set ::test::pkg_info [dict create] |
|
tcl::tm::remove {*}[tcl::tm::list] |
|
set ::auto_path [list] |
|
} |
|
#sync interp package paths with current state of package/library paths |
|
interp eval testpkgs [list ::tcl::tm::add {*}[tcl::tm::list]] |
|
interp eval testpkgs [list set ::auto_path $::auto_path] |
|
interp eval testpkgs [list set ::test::bootsupport_requirements $bootsupport_requirements] |
|
interp eval testpkgs [list set ::argv0 $::argv0] |
|
interp eval testpkgs [list set ::opt_quiet $opt_quiet] |
|
|
|
|
|
interp eval testpkgs { |
|
#try { |
|
rename ::package ::package_orig |
|
variable ns_scanned [list] |
|
# |
|
proc ::tm_version_major {version} { |
|
#if {![tm_version_isvalid $version]} { |
|
# error "Invalid version '$version' is not a proper Tcl module version number" |
|
#} |
|
set firstpart [lindex [split $version .] 0] |
|
#check for a/b in first segment |
|
if {[string is integer -strict $firstpart]} { |
|
return $firstpart |
|
} |
|
if {[string first a $firstpart] > 0} { |
|
return [lindex [split $firstpart a] 0] |
|
} |
|
if {[string first b $firstpart] > 0} { |
|
return [lindex [split $firstpart b] 0] |
|
} |
|
error "tm_version_major unable to determine major version from version number '$version'" |
|
} |
|
proc ::package {args} { |
|
variable ns_scanned |
|
if {[lindex $args 0] eq "require"} { |
|
#review - difference between errors due to bad requirements format vs package missing/failed |
|
#we should probably still put syntax errors into the datastructure to be ultimately shown to the user |
|
if {[lindex $args 1] eq "-exact"} { |
|
set pkgname [lindex $args 2] |
|
set raw_requirements_list [lrange $args 3 end] |
|
#review - what to do with invalid extra args? Normally it would raise an error |
|
set version_requested [lindex $raw_requirements_list 0] ;#for now treat as exactly one requirement when -exact |
|
#normalise! |
|
set version_requested "$version_requested-$version_requested" |
|
lappend requirements_list $version_requested |
|
} else { |
|
set pkgname [lindex $args 1] |
|
#usually only a single requirement - but we must handle multiple |
|
set raw_requirements_list [lrange $args 2 end] ;#may be also be pattern like ver- (min-unbounded) or ver1-ver2 (bounded) (which will match >=ver1 but strictly < ver2) (or like -exact if ver1=ver2) |
|
set requirements_list [list] |
|
foreach requirement $raw_requirements_list { |
|
#set requirement [::punkboot::lib::tm_version_required_canonical $requirement] |
|
#todo - work out how to get normalisation code in interp |
|
if {[string trim $requirement] ne ""} { |
|
if {[string first - $requirement] < 0} { |
|
#plain ver - normalise to ver-nextmajor |
|
#todo - we should fully normalise as we do in main script! (e.g leading zeroes - even though these should be rare) |
|
set m [::tm_version_major $requirement] |
|
set nextm [expr {$m +1}] |
|
lappend requirements_list $requirement-$nextm |
|
} else { |
|
#has dash - we should normalize so keys match even if leading zeros! |
|
lappend requirements_list $requirement |
|
} |
|
} else { |
|
#empty or whitespace spec not allowed - should be syntax error |
|
#add it to list anyway so that the underlying package call later can fail it appropriately |
|
lappend requirements_list $requirement |
|
} |
|
} |
|
#assert - added an entry for every raw requirement - even if doesn't appear to be valid |
|
|
|
#$requirements_list may be empty = any version satisfies. |
|
} |
|
|
|
#should still distinguish: {pkgname {}} -valid vs {pkgname {{}}} due to empty string supplied in call - invalid - but leave for underlying package command to error on |
|
set pkgrequest [list $pkgname $requirements_list] |
|
if {$pkgrequest ni $::test::pkg_requested} { |
|
lappend ::test::pkg_requested $pkgrequest |
|
} |
|
|
|
# -- -- --- --- --- --- --- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
# Must ensure a scan has been done in the relevant subpath before attempting to gether package vervsion |
|
set nsquals [namespace qualifiers $pkgname] |
|
if {$nsquals ne "" && $nsquals ni $ns_scanned} { |
|
catch {::package_orig require ${nsquals}::zzz-nonexistant} ;#scan every ns encountered once - or we will get no result from 'package versions' for sub namespaces. |
|
lappend ns_scanned $nsquals |
|
} |
|
set versions [::package_orig versions $pkgname] |
|
#An empty result from versions doesn't always indicate we can't load the package! |
|
#REVIEW - known to happen with 'package versions Tcl' - what other circumstances? |
|
# -- -- --- --- --- --- --- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
#fill in a blank pinfo dict to get some consistent ordering |
|
if {[dict exists $::test::pkg_info $pkgrequest]} { |
|
set pinfo [dict get $::test::pkg_info $pkgrequest] |
|
} else { |
|
set pinfo [dict create version "" versions $versions version_requested $requirements_list required_by [list]] |
|
} |
|
if {[llength $::test::pkg_stack]} { |
|
set caller [lindex $::test::pkg_stack end] |
|
set required_by [dict get $pinfo required_by] |
|
if {$caller ni $required_by} { |
|
lappend required_by $caller |
|
} |
|
dict set pinfo required_by $required_by |
|
} |
|
lappend ::test::pkg_stack $pkgname |
|
|
|
#At this point we could short circuit if we've already classified this package/requirements combo as missing/broken from a previous require |
|
#review - there is some chance the exact pkg/requirements combo may succeed after an earlier failure if some package adjusted search paths.. |
|
#however - the pkg should maintain a failure record - treating it as successful is likely to hide relevant info |
|
if {$pkgrequest in [list {*}$::test::pkg_missing {*}$::test::pkg_broken]} { |
|
set ::test::pkg_stack [lrange $::test::pkg_stack 0 end-1] |
|
dict set ::test::pkg_info $pkgrequest $pinfo |
|
return |
|
} |
|
|
|
#use our normalised requirements instead of original args |
|
#if {[catch [list ::package_orig {*}$args] result]} {} |
|
if {[catch [list ::package_orig require $pkgname {*}$requirements_list] result]} { |
|
dict set pinfo testerror $result |
|
#package missing - or exists - but failing to initialise |
|
if {!$::opt_quiet} { |
|
set parent_path [lrange $::test::pkg_stack 0 end-1] |
|
puts stderr "\x1b\[32m $pkgname versions: $versions error: $result\x1b\[m" |
|
set parent_path [join $parent_path " -> "] |
|
puts stderr "pkg requirements: $parent_path" |
|
puts stderr "error during : '$args'" |
|
puts stderr " \x1b\[93m$result\x1b\[m" |
|
} |
|
|
|
#the failed package may still exist - so we could check 'package files' and 'package ifneeded' here too - REVIEW |
|
#to determine the version that we attempted to load, |
|
#- we need to look at 'pkg versions' vs -exact / ver / ver-ver (using package vsatisfies) |
|
if {![llength $versions]} { |
|
#no versions *and* we had an error - missing is our best guess. review. |
|
#'package versions Tcl' never shows any results |
|
#so requests for old versions will show as missing not broken. |
|
#This is probably better anyway. |
|
if {$pkgrequest ni $::test::pkg_missing} { |
|
lappend ::test::pkg_missing $pkgrequest |
|
} |
|
} else { |
|
if {$pkgrequest ni $::test_pkg_broken} { |
|
lappend ::test::pkg_broken $pkgrequest |
|
} |
|
|
|
#all we know about failed pkg is in the error $result |
|
#we can't reliably determine which version of possibly many it was trying to load just based on error msgs. |
|
#(we often could - but not always) |
|
#Instead - use the properly ordered versions and knowledge of which pkg 'package require' would have picked. |
|
|
|
#'package versions' does not always return ordered earliest to latest! (e.g 'package versions http' -> 2.10b1 2.9.8) |
|
set ordered_versions [lsort -command {::package_orig vcompare} [::package_orig versions $pkgname]] |
|
if {[::package_orig prefer] eq "stable"} { |
|
#to support 'package prefer' = stable we have to strip alpha/beta versions |
|
set selectable_versions [list] |
|
foreach v $ordered_versions { |
|
if {[string match *a* $v] || [string match *b* $v]} { |
|
#presence of an a or b indicates 'unstable' |
|
continue |
|
} |
|
lappend selectable_versions $v |
|
} |
|
} else { |
|
#we are operating under 'package prefer' = latest |
|
set selectable_versions $ordered_versions |
|
} |
|
|
|
if {[llength $requirements_list]} { |
|
#add one or no entry for each requirement. |
|
#pick highest at end |
|
set satisfiers [list] |
|
foreach requirement $requirements_list { |
|
foreach ver [lreverse $selectable_versions] { |
|
if {[package vsatisfies $ver $requirement]} { |
|
lappend satisfiers $ver |
|
break |
|
} |
|
} |
|
} |
|
if {[llength $satisfiers]} { |
|
set satisfiers [lsort -command {::package_orig vcompare} $satisfiers] |
|
dict set pinfo version [lindex $satisfiers end] |
|
} |
|
} else { |
|
#package require will have picked highest/latest |
|
dict set pinfo version [lindex $selectable_versions end] |
|
} |
|
} |
|
|
|
|
|
#Note that we must return without error in order to gather 'probable' dependencies. |
|
#This is not completely accurate - as a lib/module may have wrapped a 'package require' in a catch |
|
#In such a case the 'dependency' might be optional - but we currently have no way of determining this. |
|
#By not returning an error - the loaded package may not behave correctly (e.g package state variables set differently?) |
|
#- hence this is all done in a separate interp to be discarded. |
|
#Note that pkgIndex.tcl scripts may commonly just 'return' and fail to do a 'package provide' |
|
# - presumably the standard package require still raises an error in that case though - so it is different? |
|
# - e.g at least some versions of struct::list did this. resulting in "can't find package struct::list" for tcl versions not supported. |
|
# - even thoug it did find a package for struct::list. |
|
set ::test::pkg_stack [lrange $::test::pkg_stack 0 end-1] |
|
dict set ::test::pkg_info $pkgrequest $pinfo |
|
return |
|
} else { |
|
#package loaded ok |
|
lappend ::test::pkg_loaded $pkgrequest |
|
set ifneeded_script [list uplevel 1 [list ::package_orig ifneeded $pkgname]] ;#not guaranteed to be a tcl list? |
|
set pinfo [dict merge $pinfo [dict create version $result raw_ifneeded $ifneeded_script]] |
|
|
|
set ::test::pkg_stack [lrange $::test::pkg_stack 0 end-1] |
|
set relevant_files [list] |
|
if {![catch {::package_orig files Tcl} ]} { |
|
#tcl9 (also some 8.6/8.7) has 'package files' subcommand. |
|
#unfortunately, in some cases (e.g md5 when no accelerators available) this can be a huge list (1000+) showing all scanned pkgIndex.tcl files from unrelated packages. |
|
#We expect this to be fixed - but early Tcl9 (and some 8.6/8.7) versions may persist and have this behaviour |
|
#see: https://core.tcl-lang.org/tcl/tktview/209fd9adce |
|
set all_files [::package_orig files $pkgname] |
|
#some arbitrary threshold? REVIEW |
|
if {[llength $all_files] > 10} { |
|
dict set pinfo warning "files_sourced_during_load=[llength $all_files]" |
|
} else { |
|
set relevant_files $all_files |
|
dict set pinfo packagefiles $relevant_files |
|
} |
|
} |
|
if {![llength $relevant_files]} { |
|
dict set pinfo packagefiles {} ;#default |
|
#there are all sorts of scripts, so this is not predictably structured |
|
#e.g using things like apply |
|
#we will attempt to get a trailing source .. <file> |
|
set parts [split [string trim $ifneeded_script] {;}] |
|
set trimparts [list] |
|
foreach p $parts { |
|
lappend trimparts [string trimright $p] |
|
} |
|
set last_with_text [lsearch -inline -not [lreverse $trimparts] ""] ;#could return empty if all blank |
|
#we still don't assume any line is a valid tcl list.. |
|
if {$last_with_text ne "" && [regexp -- {\S+$} $last_with_text lastword]} { |
|
#if it's a file or dir - close enough (?) |
|
#e.g tcllibc uses apply and the last entry is actuall a folder used to find the file.. |
|
#we aren't brave enough to try to work out the actual file(s) |
|
if {[file exists $lastword]} { |
|
dict set pinfo packagefiles $lastword |
|
} |
|
} |
|
} |
|
dict set ::test::pkg_info $pkgrequest $pinfo |
|
return $result |
|
} |
|
} else { |
|
#puts stderr "package $args" |
|
return [uplevel 1 [list ::package_orig {*}$args]] |
|
} |
|
} |
|
|
|
set ::test::pkg_stack [list] |
|
catch {::package_orig require zzz-non-existant} ;#scan so we get 'package versions' results |
|
dict for {pkg pkgdict} $::test::bootsupport_requirements { |
|
#set nsquals [namespace qualifiers $pkg] |
|
#if {$nsquals ne ""} { |
|
# catch {::package_orig require ${nsquals}::zzz-non-existant} ;#force scan of every level encountered |
|
#} |
|
set ::test::pkg_stack [list] |
|
#run the instrumented 'package require' on the toplevel requirements |
|
# dict key version always exists in pkgdict - version is empty or normalised to min- or min-max |
|
set wanted [dict get $pkgdict version] |
|
catch {package require $pkg {*}$wanted} |
|
} |
|
#} finally { |
|
# #not strictly necessary as we'll tear down the interp |
|
# catch {rename ::package ""} |
|
# catch {rename ::package_orig ::package} |
|
#} |
|
# ** *** *** *** *** *** *** *** *** *** *** *** |
|
|
|
#note we will have entries for each different way package was requested |
|
set ::test::pkg_requested [lsort -unique $::test::pkg_requested] |
|
|
|
#foreach pkg $::test::pkg_requested { |
|
# set ver [package provide $pkg] |
|
# if {$ver eq ""} { |
|
# #puts stderr "missing pkg: $pkg" |
|
# lappend ::test::pkg_missing $pkg |
|
# } else { |
|
# if {[string tolower $pkg] eq "tcl"} { |
|
# #ignore |
|
# #continue |
|
# } |
|
# lappend ::test::pkg_loaded $pkg |
|
# } |
|
#} |
|
} |
|
#extract results from testpkgs interp |
|
set requested [interp eval testpkgs {set ::test::pkg_requested}] |
|
set loaded [interp eval testpkgs {set ::test::pkg_loaded}] |
|
set missing [interp eval testpkgs {set ::test::pkg_missing}] |
|
set broken [interp eval testpkgs {set ::test::pkg_broken}] |
|
set pkginfo [interp eval testpkgs {set ::test::pkg_info}] |
|
interp delete testpkgs |
|
|
|
#now run the normal package require on every pkg to see if our 'broken' assignments are correct? |
|
#by returning without error in our fake package require - we have potentially miscategorised some in both the 'broken' and 'loaded' categories. |
|
#a) - packages that are broken due to missing dependency but we haven't reported as such (the common case) |
|
#b) - packages that we reported as broken because they tried to use a function from an optional dependency we didn't error on |
|
#c) - other cases |
|
# |
|
#Note also by not erroring on a package require the package may have not attempted to load another package that would do the job. |
|
#This is a case where we may completely fail to report a one-of-n dependency for example |
|
# - hard to test without repeated runs :/ |
|
#todo - another interp? |
|
#a 'normal' run now may at least mark/unmark some 'broken' packages and give at least some better feedback. |
|
#we will test all discovered packages from the above process except those already marked as 'missing' |
|
#both 'broken' and 'loaded' are still suspect at this point. |
|
#we will attempt to load the -exact version that the previous test either appeared to load or fail in loading. |
|
#Presumably that is the one that would be loaded in the normal course anyway - REVIEW. |
|
#(as well as 'requestd' not guaranteed to be complete - but we will live with that for the purposes here) |
|
interp create normaltest |
|
interp eval normaltest [list package prefer [package prefer]] |
|
interp eval normaltest { |
|
set ::pkg_broken [list] |
|
set ::pkg_loaded [list] |
|
set ::pkg_errors [dict create] |
|
tcl::tm::remove {*}[tcl::tm::list] |
|
set ::auto_path [list] |
|
} |
|
|
|
set test_packages [list] |
|
foreach pkgrequest $requested { |
|
lassign $pkgrequest pkgname requirements_list |
|
if {$pkgrequest ni $missing} { |
|
if {[dict exists $pkginfo $pkgrequest version]} { |
|
set tried_version [dict get $pkginfo $pkgrequest version] |
|
} else { |
|
set tried_version "" |
|
} |
|
lappend test_packages [list $pkgname $tried_version $requirements_list] |
|
} |
|
} |
|
|
|
#sync interp package paths with current state of package/library paths |
|
interp eval normaltest [list ::tcl::tm::add {*}[tcl::tm::list]] |
|
interp eval normaltest [list set ::auto_path $::auto_path] |
|
interp eval normaltest [list set ::test_packages $test_packages] |
|
interp eval normaltest [list set ::argv0 $::argv0] |
|
interp eval normaltest [list set ::opt_quiet $opt_quiet] |
|
|
|
interp eval normaltest { |
|
foreach testinfo $::test_packages { |
|
lassign $testinfo pkgname ver requirements_list |
|
|
|
#if {$ver eq ""} { |
|
# set require_script [list package require $pkgname] |
|
#} else { |
|
# set require_script [list package require $pkgname $ver-$ver] ;#bounded same version - equivalent to -exact |
|
#} |
|
set require_script [list package require $pkgname {*}$requirements_list] |
|
|
|
#puts "finaltest $pkgname requested:$requirements_list" |
|
if {[catch $require_script result]} { |
|
lappend ::pkg_broken [list $pkgname $requirements_list] |
|
dict set ::pkg_errors [list $pkgname $requirements_list] $result |
|
} else { |
|
#result is version we actually got - without the previous interp's fudgery |
|
if {![llength $requirements_list] || [package vsatisfies $result {*}$requirements_list]} { |
|
lappend ::pkg_loaded [list $pkgname $requirements_list] |
|
} else { |
|
lappend ::pkg_broken [list $pkgname $requirements_list] |
|
dict set ::pkg_errors [list $pkgname $requirements_list] "Version conflict for package \"$pkgname\": have $result, need $requirements_list" |
|
#standard err msg but capital V to differentiate |
|
#Differs from standard in that we have normalised exacts to ver-ver - so will report in that form instead of e.g 0-1 -exact 1.0 1b3-2 |
|
} |
|
} |
|
} |
|
} |
|
set actually_failed [interp eval normaltest [list set ::pkg_broken]] |
|
set pkg_errors [interp eval normaltest [list set ::pkg_errors]] ;#dict |
|
set actually_loaded [list] |
|
set actually_loaded_names [list] |
|
set actually_broken [list] |
|
foreach pkgrequest $requested { |
|
if {$pkgrequest in $missing} { |
|
continue |
|
} |
|
if {$pkgrequest in $actually_failed} { |
|
lappend actually_broken $pkgrequest |
|
} else { |
|
lappend actually_loaded $pkgrequest |
|
if {[lindex $pkgrequest 0] ni $actually_loaded_names} { |
|
lappend actually_loaded_names [lindex $pkgrequest 0] |
|
} |
|
} |
|
} |
|
|
|
dict for {pkg_req err} $pkg_errors { |
|
dict set pkginfo $pkg_req error $err |
|
} |
|
|
|
interp delete normaltest |
|
set pkgstate [dict create requested $requested loaded $actually_loaded loadednames $actually_loaded_names missing $missing broken $actually_broken info $pkginfo] |
|
|
|
#debug |
|
#dict for {k v} $pkgstate { |
|
# puts stderr " - $k $v" |
|
#} |
|
return $pkgstate |
|
} |
|
|
|
|
|
#called when only-bootsupport or bootsupport+external module/lib paths active. |
|
#flags for ui-feature relevant packages |
|
proc ::punkboot::package_bools {pkg_availability} { |
|
set pkgbools [dict create] |
|
set requirements [dict create\ |
|
overtype 1.6.5-\ |
|
textblock 0.1.1-\ |
|
punk::ansi 0.1.1-\ |
|
] |
|
#'dict get $pkg_availability loaded] is a list of {pkgname requrement} pairs |
|
#set loaded_names [lmap i [lsearch -all -index 0 -subindices [dict get $pkg_availability loaded] *] {lindex $loaded $i}] ;#return list of first elements in each tuple |
|
set loaded_names [dict get $pkg_availability loadednames] ;#prebuilt list of names |
|
dict for {pkgname req} $requirements { |
|
#each req could in theory be a list |
|
if {$pkgname in $loaded_names} { |
|
#get first loaded match - use version from it (all info records for {pkgname *} should have same version that was actually loaded) |
|
set first_loaded [lsearch -inline -index 0 [dict get $pkg_availability loaded] $pkgname] |
|
set loaded_version [dict get $pkg_availability info $first_loaded version] |
|
if {![llength $req] || [package vsatisfies $loaded_version {*}$req]} { |
|
dict set pkgbools $pkgname 1 |
|
} else { |
|
dict set pkgbools $pkgname 0 |
|
} |
|
} else { |
|
dict set pkgbools $pkgname 0 |
|
} |
|
} |
|
return $pkgbools |
|
} |
|
proc ::punkboot::get_display_missing_packages {pkg_availability} { |
|
array set haspkg [punkboot::package_bools $pkg_availability] ;#convenience e.g if {$haspkg(textblock)} ... |
|
global A |
|
if {![array size A]} { |
|
punkboot::define_global_ansi $pkg_availability |
|
} |
|
set missing_rows [list] |
|
set fields_blank_missing [dict create\ |
|
status ""\ |
|
package ""\ |
|
version_requested ""\ |
|
versions ""\ |
|
optional ""\ |
|
recommended ""\ |
|
required_by ""\ |
|
] |
|
foreach pkg_req [dict get $pkg_availability missing] { |
|
lassign $pkg_req pkgname requirements_list |
|
set fields $fields_blank_missing |
|
dict set fields status "missing" |
|
dict set fields package $pkg_req |
|
if {[dict exists $::punkboot::bootsupport_optional $pkgname]} { |
|
dict set fields optional " ${A(OK)}(known optional)$A(RST)" |
|
} |
|
if {[dict exists $::punkboot::bootsupport_recommended $pkgname]} { |
|
dict set fields recommended "${A(HIGHLIGHT)}(RECOMMENDED)$A(RST)" |
|
} |
|
if {[dict exists $pkg_availability info $pkg_req required_by]} { |
|
dict set fields required_by [dict get $pkg_availability info $pkg_req required_by] |
|
} |
|
lappend missing_rows $fields |
|
} |
|
set missing_out "" |
|
set c1_width 40 |
|
foreach row $missing_rows { |
|
if {$haspkg(overtype)} { |
|
set line " [overtype::left [string repeat " " $c1_width] $A(BWHITE)[dict get $row package]$A(RST)]" |
|
} else { |
|
set line " [format "%-*s" $c1_width [dict get $row package]]" |
|
} |
|
append line " [dict get $row status]" |
|
append line " [dict get $row optional]" |
|
append line " [dict get $row recommended]" |
|
append line " requested_by:[join [dict get $row required_by] {, }]" |
|
append missing_out $line \n |
|
} |
|
return $missing_out |
|
} |
|
proc ::punkboot::get_display_broken_packages {pkg_availability} { |
|
array set haspkg [punkboot::package_bools $pkg_availability] ;#convenience e.g if {$haspkg(textblock)} ... |
|
global A |
|
if {![array size A]} { |
|
punkboot::define_global_ansi $pkg_availability |
|
} |
|
set broken_rows [list] |
|
set fields_blank_broken [dict create\ |
|
status ""\ |
|
package ""\ |
|
version ""\ |
|
optional ""\ |
|
recommended ""\ |
|
required_by ""\ |
|
error ""\ |
|
] |
|
foreach pkg_req [dict get $pkg_availability broken] { |
|
lassign $pkg_req pkgname vrequested |
|
set fields $fields_blank_broken |
|
dict set fields status "broken" |
|
dict set fields package $pkg_req |
|
|
|
if {[dict exists $pkg_availability info $pkg_req version]} { |
|
dict set fields version [dict get $pkg_availability info $pkg_req version] |
|
} |
|
|
|
if {[dict exist $::punkboot::bootsupport_optional $pkgname]} { |
|
dict set fields optional "${A(OK)}(known optional)$A(RST)" |
|
} |
|
|
|
if {[dict exists $::punkboot::bootsupport_recommended $pkgname]} { |
|
dict set fields recommended "${A(HIGHLIGHT)}(RECOMMENDED)$A(RST)" |
|
} |
|
|
|
set requiredby_list [list] |
|
if {[dict exists $::punkboot::bootsupport_requirements $pkgname]} { |
|
#punkboot also asked for this pkgname |
|
#the question of what other packages would also be satisfied had this request not been broken isn't necessarily something we need to answer here |
|
#we do so for punkboot anyway - but it's inclusion as 'requiredby or requestedby' isn't strictly accurate - |
|
# it is more like: would also be satisfied by |
|
#what is 'broken' may depend on what order packages were loaded |
|
#e.g if a package already required a specific low version (that was optional for it) that another then fails on because a different version was not optional for that later package. |
|
#puts stderr "$pkgname===$::punkboot::bootsupport_requirements" |
|
set pboot_required [dict get $::punkboot::bootsupport_requirements $pkgname version] ;#version key always present and empty or normalised |
|
if {[list $pkgname $pboot_required] eq $pkg_req} { |
|
#pboot had same requirespec as this broken record |
|
set requiredby_list [list punkboot] |
|
} elseif {[dict exists $pkg_availability info $pkg_req version]} { |
|
set vtried [dict get $pkg_availability info $pkg_req version] |
|
if {[dict exists $pkg_availability broken [list $pkgname $pboot_required]]} { |
|
#punkboot didn't get what it wanted directly |
|
if {$pboot_required eq "" || [package vsatisfies $vtried $pboot_required]} { |
|
#REVIEW |
|
#e.g punkboot might require no specific version - and this fail record might be for a specific version |
|
#we only list punkboot against this request if it's request also failed - but would be satisfied by this failure if it had worked |
|
set requiredby_list [list punkboot] |
|
} |
|
} |
|
} |
|
} |
|
if {[dict exists $pkg_availability info $pkg_req required_by]} { |
|
lappend requiredby_list {*}[dict get $pkg_availability info $pkg_req required_by] |
|
} |
|
dict set fields required_by $requiredby_list |
|
|
|
if {[dict exists $pkg_availability info $pkg_req error]} { |
|
dict set fields error "[dict get $pkg_availability info $pkg_req error]" |
|
} |
|
|
|
lappend broken_rows $fields |
|
} |
|
set broken_out "" |
|
set c1_width 40 |
|
set c3_width 20 |
|
set c3 [string repeat " " $c3_width] |
|
foreach row $broken_rows { |
|
if {$haspkg(overtype)} { |
|
set line " [overtype::left [string repeat " " $c1_width] $A(BAD)[dict get $row package]$A(RST)]" |
|
} else { |
|
set line " [format "%-*s" $c1_width [dict get $row package]]" |
|
} |
|
append line " [dict get $row status]" |
|
if {[dict get $row version] ne ""} { |
|
set txt " ver:[dict get $row version]" |
|
append line [format "%-*s" $c3_width $txt] |
|
} else { |
|
append line $c3 |
|
} |
|
if {[dict get $row optional] ne ""} { |
|
append line [dict get $row optional] |
|
} |
|
if {[dict get $row recommended] ne ""} { |
|
append line [dict get $row recommended] |
|
} |
|
if {[dict get $row required_by] ne ""} { |
|
append line " requested_by:[join [dict get $row required_by] {, }]" |
|
} |
|
if {[dict get $row error] ne ""} { |
|
append line " err:[dict get $row error]" |
|
} |
|
append broken_out $line \n |
|
} |
|
return $broken_out |
|
} |
|
proc ::punkboot::define_global_ansi {pkg_availability} { |
|
#stick to basic colours for themable aspects ? |
|
# |
|
array set haspkg [punkboot::package_bools $pkg_availability] ;#convenience e.g if {$haspkg(textblock)} ... |
|
global A |
|
set A(RST) \x1b\[m |
|
if {!$haspkg(punk::ansi)} { |
|
set A(HIGHLIGHT) \x1b\[93m ;#brightyellow |
|
set A(BWHITE) \x1b\[97m ;#brightwhite |
|
set A(OK) \x1b\[92m ;#brightgreen |
|
set A(BAD) \x1b\[33m ;# orange |
|
set A(ERR) \x1b\[31m ;# red |
|
} else { |
|
namespace eval ::punkboot { |
|
namespace import ::punk::ansi::a+ ::punk::ansi::a |
|
} |
|
set A(HIGHLIGHT) [a+ brightyellow] |
|
set A(BWHITE) [a+ brightwhite] |
|
set A(OK) [a+ web-lawngreen] ;#brightgreen |
|
set A(BAD) [a+ web-orange] |
|
set A(ERR) [a+ web-indianred] ;#easier on the eyes than standard red on some screens |
|
} |
|
} |
|
proc ::punkboot::punkboot_gethelp {args} { |
|
#we have currently restricted our package paths to those from 'bootsupport' |
|
#gather details on what is missing so that the info is always reported in help output. |
|
variable pkg_availability |
|
global A |
|
punkboot::define_global_ansi $pkg_availability |
|
|
|
array set haspkg [punkboot::package_bools $pkg_availability] ;#convenience e.g if {$haspkg(textblock)} ... |
|
|
|
set scriptname [file tail [info script]] |
|
append h "Usage:" \n |
|
append h "" \n |
|
append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n |
|
append h " - This help." \n \n |
|
append h " $scriptname project ?-k?" \n |
|
append h " - this is the literal word project - and confirms you want to run the project build - which includes src/vfs/* checks and builds" \n |
|
append h " - the optional -k flag will terminate running processes matching the executable being built (if applicable)" \n |
|
append h " - built modules go into <projectdir>/modules <projectdir>/lib etc." \n \n |
|
append h " $scriptname modules" \n |
|
append h " - build modules from src/modules src/vendormodules etc to their corresponding locations under <projectdir>" \n |
|
append h " This does not scan src/runtime and src/vfs folders to build kit/zipkit/cookfs executables" \n \n |
|
append h " $scriptname bootsupport" \n |
|
append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n |
|
append h " - bootsupport modules are pulled from locations specified in include_modules.config files within each src/bootsupport subdirectory" \n |
|
append h " - This should usually be from modules that have been built and tested in <projectdir>/modules <projectdir>/lib etc." \n |
|
append h " - bootsupport modules are available to make.tcl" \n \n |
|
append h " $scriptname vendorupdate" \n |
|
append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n |
|
append h " $scriptname vfscommonupdate" \n |
|
append h " - update the src/vfs/_vfscommon.vfs from compiled src/modules and src/lib etc" \n |
|
append h " - before calling this (followed by make project) - you can test using '<builtexe>(.exe) dev'" \n |
|
append h " this will load modules from your <projectdir>/module <projectdir>/lib paths instead of from the kit/zipkit" \n \n |
|
append h " $scriptname info" \n |
|
append h " - show the name and base folder of the project to be built" \n \n |
|
append h " $scriptname check" \n |
|
append h " - show module/library paths and any potentially problematic packages for running this script" \n |
|
append h "" \n |
|
if {[llength [dict get $pkg_availability missing]] || [llength [dict get $pkg_availability broken]]} { |
|
set has_recommended 0 |
|
set has_nonoptional 0 |
|
foreach pkg_req [list {*}[dict get $pkg_availability missing] {*}[dict get $pkg_availability broken]] { |
|
lassign $pkg_req pkgname _requirements |
|
if {[dict exists $::punkboot::bootsupport_recommended $pkgname]} { |
|
set has_recommended 1 |
|
break |
|
} |
|
if {![dict exists $::punkboot::bootsupport_optional $pkgname]} { |
|
set has_nonoptional 1 |
|
break |
|
} |
|
} |
|
if {$has_recommended || $has_nonoptional} { |
|
append h "* $A(HIGHLIGHT)** NOTE ** ***$A(RST)" \n |
|
append h " punk boot has detected that the following packages could not be loaded from the bootsystem path:" \n |
|
set missing_out [get_display_missing_packages $pkg_availability] |
|
append h $missing_out |
|
|
|
set broken_out [get_display_broken_packages $pkg_availability] |
|
|
|
append h $broken_out |
|
append h "* $A(HIGHLIGHT)** *** *** ***$A(RST)" \n |
|
append h " These packages are *probably* required for punk boot to function correctly and efficiently" \n |
|
append h " punk boot may still work if they are available elsewhere for the running interpreter" \n |
|
append h " Review to see if bootsupport should be updated" \n |
|
append h " Call 'make.tcl check' and examine the last table (which includes bootsupport + executable-provided packages)" \n |
|
append h " See if there are any items marked missing or broken that aren't marked as '(known optional)'" \n |
|
append h " If all are marked (known optional) then it should work." \n |
|
append h " A package marked (known optional) and (RECOMMENDED) may make the build/install processes run a lot faster. (e.g tcllibc)" \n |
|
append h "* $A(HIGHLIGHT)** *** *** ***$A(RST)" \n\n |
|
#append h "Successfully Loaded packages:" \n |
|
#append h " " [join $::punkboot::pkg_loaded "\n "] \n |
|
} |
|
} |
|
return $h |
|
} |
|
|
|
set scriptargs $::argv |
|
set do_help 0 |
|
if {![llength $scriptargs]} { |
|
set do_help 1 |
|
} else { |
|
foreach h $::punkboot::help_flags { |
|
if {[lsearch $scriptargs $h] >= 0} { |
|
set do_help 1 |
|
break |
|
} |
|
} |
|
} |
|
set commands_found [list] |
|
foreach a $scriptargs { |
|
if {![string match -* $a]} { |
|
lappend commands_found $a |
|
} else { |
|
if {$a ni $::punkboot::non_help_flags} { |
|
set do_help 1 |
|
} |
|
} |
|
} |
|
if {[llength $commands_found] != 1 } { |
|
set do_help 1 |
|
} elseif {[lindex $commands_found 0] ni $::punkboot::known_commands} { |
|
puts stderr "Unknown command: [lindex $commands_found 0]\n\n" |
|
set do_help 1 |
|
} |
|
if {$do_help} { |
|
puts stdout "Checking package availability..." |
|
set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] |
|
foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { |
|
#puts stderr "---> $pkg_request" |
|
lassign $pkg_request pkgname vrequest |
|
set vloaded [dict get $::punkboot::pkg_availability info $pkg_request version] ;#version that was selected to load in response to vrequest during test |
|
#catch {package require $pkgname {*}$vrequest} ;#todo |
|
package require $pkgname {*}$vrequest ;#todo |
|
#package require $pkgname $vloaded-$vloaded |
|
} |
|
puts stdout [::punkboot::punkboot_gethelp] |
|
exit 0 |
|
} |
|
|
|
set ::punkboot::command [lindex $commands_found 0] |
|
|
|
|
|
if {[lsearch $::argv -k] >= 0} { |
|
set forcekill 1 |
|
} else { |
|
set forcekill 0 |
|
} |
|
#puts stdout "::argv $::argv" |
|
# ---------------------------------------- |
|
|
|
set scriptfolder $::punkboot::scriptfolder |
|
|
|
|
|
|
|
#first look for a project root (something under fossil or git revision control AND matches punk project folder structure) |
|
#If that fails - just look for a 'project shaped folder' ie meets minimum requirements of /src /src/lib /src/modules /lib /modules |
|
if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]} { |
|
if {![string length [set projectroot [punk::repo::find_candidate $scriptfolder]]]} { |
|
puts stderr "punkboot script unable to determine an approprite project root at or above the path '$scriptfolder' ensure the make script is within a project folder structure" |
|
puts stderr " -aborted- " |
|
exit 2 |
|
#todo? |
|
#ask user for a project name and create basic structure? |
|
#call punk::mix::cli::new $projectname on parent folder? |
|
} else { |
|
puts stderr "WARNING punkboot script operating in project space that is not under version control" |
|
} |
|
} else { |
|
|
|
} |
|
|
|
set sourcefolder $projectroot/src |
|
if {$::punkboot::command eq "check"} { |
|
set sep [string repeat - 75] |
|
puts stdout $sep |
|
puts stdout "module/library checks - paths from bootsupport only" |
|
puts stdout $sep |
|
puts stdout "- tcl::tm::list" |
|
foreach fld [tcl::tm::list] { |
|
if {[file exists $fld]} { |
|
puts stdout " $fld" |
|
} else { |
|
puts stdout " $fld (not present)" |
|
} |
|
} |
|
puts stdout "- auto_path" |
|
foreach fld $::auto_path { |
|
if {[file exists $fld]} { |
|
puts stdout " $fld" |
|
} else { |
|
puts stdout " $fld (not present)" |
|
} |
|
} |
|
flush stdout |
|
set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] |
|
foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { |
|
lassign $pkg_request pkgname vrequest |
|
package require $pkgname {*}$vrequest ;#todo? |
|
} |
|
flush stderr |
|
#punk::lib::showdict -channel stderr $::punkboot::pkg_availability |
|
set missing_out [::punkboot::get_display_missing_packages $::punkboot::pkg_availability] |
|
puts stdout $missing_out\n |
|
|
|
set broken_out [::punkboot::get_display_broken_packages $::punkboot::pkg_availability] |
|
puts stdout $broken_out |
|
|
|
set v [package require punk::mix::base] |
|
|
|
#don't exit yet - 2nd part of "check" below package path restore |
|
} |
|
# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- |
|
# - package path restore original module paths and auto_path entries to take effect in addition to bootsupport paths |
|
# - This must be done between the two "check" command sections |
|
if {$package_paths_modified} { |
|
set tm_list_now [tcl::tm::list] |
|
foreach p $original_tm_list { |
|
if {$p ni $tm_list_now} { |
|
tcl::tm::add $p |
|
} |
|
} |
|
#set ::auto_path [list $bootsupport_lib {*}$original_auto_path] |
|
lappend ::auto_path {*}$original_auto_path |
|
} |
|
# -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- |
|
#2nd part of "check" |
|
if {$::punkboot::command eq "check"} { |
|
set sep [string repeat - 75] |
|
puts stdout $sep |
|
puts stdout "module/library checks - paths from bootsupport plus those provided by running interp [info nameofexecutable]" |
|
puts stdout $sep |
|
puts stdout "- tcl::tm::list" |
|
foreach fld [tcl::tm::list] { |
|
if {[file exists $fld]} { |
|
puts stdout " $fld" |
|
} else { |
|
#puts stdout " $fld (not present)" |
|
} |
|
} |
|
puts stdout "- auto_path" |
|
foreach fld $::auto_path { |
|
if {[file exists $fld]} { |
|
puts stdout " $fld" |
|
} else { |
|
#puts stdout " $fld (not present)" |
|
} |
|
} |
|
set ::punkboot::pkg_availability [::punkboot::check_package_availability -quiet 1 $::punkboot::bootsupport_requirements] |
|
foreach pkg_request [dict get $::punkboot::pkg_availability loaded] { |
|
lassign $pkg_request pkgname vrequest |
|
catch {package require $pkgname {*}$vrequest} ;#todo |
|
} |
|
flush stderr |
|
#punk::lib::showdict -channel stderr $::punkboot::pkg_availability |
|
set missing_out [::punkboot::get_display_missing_packages $::punkboot::pkg_availability] |
|
puts stdout $missing_out\n |
|
set broken_out [::punkboot::get_display_broken_packages $::punkboot::pkg_availability] |
|
puts stdout $broken_out |
|
puts stdout $sep |
|
puts stdout $sep |
|
catch {package require struct::set} |
|
puts stdout ---[package ifneeded struct::set 2.2.3] |
|
exit 0 |
|
} |
|
|
|
|
|
dict for {pkg pkginfo} $::punkboot::bootsupport_requirements { |
|
set verspec [dict get $pkginfo version] ;#version wanted specification always exists and is empty or normalised |
|
if {[catch {package require $pkg {*}$verspec} errM]} { |
|
puts stdout "\x1b\[33m$errM\x1b\[m" |
|
} |
|
} |
|
|
|
if {$::punkboot::command eq "info"} { |
|
puts stdout "- -- --- --- --- --- --- --- --- --- -- -" |
|
puts stdout "- -- info -- -" |
|
puts stdout "- -- --- --- --- --- --- --- --- --- -- -" |
|
puts stdout "- projectroot : $projectroot" |
|
set sourcefolder $projectroot/src |
|
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] |
|
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] |
|
puts stdout "- vendorlib folders: ([llength $vendorlibfolders])" |
|
foreach fld $vendorlibfolders { |
|
puts stdout " src/$fld" |
|
} |
|
puts stdout "- vendormodule folders: ([llength $vendormodulefolders])" |
|
foreach fld $vendormodulefolders { |
|
puts stdout " src/$fld" |
|
} |
|
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] |
|
puts stdout "- source module paths: [llength $source_module_folderlist]" |
|
foreach fld $source_module_folderlist { |
|
puts stdout " $fld" |
|
} |
|
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] |
|
lappend projectlibfolders lib |
|
puts stdout "- source libary paths: [llength $projectlibfolders]" |
|
foreach fld $projectlibfolders { |
|
puts stdout " src/$fld" |
|
} |
|
if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { |
|
set vc "fossil" |
|
set rev [punk::repo::fossil_revision $scriptfolder] |
|
set rem [punk::repo::fossil_remote $scriptfolder] |
|
} elseif {[punk::repo::find_git $scriptfolder] eq $projectroot} { |
|
set vc "git" |
|
set rev [punk::repo::git_revision $scriptfolder] |
|
set rem [punk::repo::git_remote $scriptfolder] |
|
} else { |
|
set vc " - none found -" |
|
set rev "n/a" |
|
set remotes "n/a" |
|
} |
|
puts stdout "- version control : $vc" |
|
puts stdout "- revision : $rev" |
|
puts stdout "- remote" |
|
foreach ln [split $rem \n] { |
|
puts stdout " $ln" |
|
} |
|
puts stdout "- -- --- --- --- --- --- --- --- --- -- -" |
|
|
|
exit 0 |
|
} |
|
|
|
|
|
|
|
|
|
if {$::punkboot::command eq "shell"} { |
|
package require punk |
|
package require punk::repl |
|
puts stderr "punk boot shell not implemented - dropping into ordinary punk shell" |
|
|
|
#todo - make procs vars etc from this file available? |
|
|
|
repl::init |
|
repl::start stdin |
|
|
|
exit 1 |
|
} |
|
|
|
if {$::punkboot::command eq "vfscommonupdate"} { |
|
puts "projectroot: $projectroot" |
|
puts "script: [info script]" |
|
puts stdout "Updating vfs/_vfscommon.vfs" |
|
|
|
puts stdout "REPLACE src/vfs/_vfscommon.vfs/* with project's modules and libs?? y|n" |
|
if {[gets stdin] eq "y"} { |
|
puts proceeding... |
|
|
|
proc vfscommonupdate {projectroot} { |
|
file delete -force $projectroot/src/vfs/_vfscommon.vfs/modules |
|
file copy $projectroot/modules $projectroot/src/vfs/_vfscommon.vfs/ |
|
#temp? (avoid zipfs mkimg windows dotfile bug) |
|
file delete $projectroot/src/vfs/_vfscommon.vfs/modules/.punkcheck |
|
|
|
file delete -force $projectroot/src/vfs/_vfscommon.vfs/lib |
|
file copy $projectroot/lib $projectroot/src/vfs/_vfscommon.vfs/ |
|
#temp? |
|
file delete $projectroot/src/vfs/_vfscommon.vfs/lib/.punkcheck |
|
|
|
} |
|
vfscommonupdate $projectroot |
|
|
|
} else { |
|
puts aborting... |
|
} |
|
|
|
|
|
|
|
puts stdout "\nvfscommonupdate done " |
|
flush stderr |
|
flush stdout |
|
::exit 0 |
|
} |
|
|
|
if {$::punkboot::command eq "vendorupdate"} { |
|
puts "projectroot: $projectroot" |
|
puts "script: [info script]" |
|
#puts "-- [tcl::tm::list] --" |
|
puts stdout "Updating vendor modules in src folder" |
|
|
|
proc vendor_localupdate {projectroot} { |
|
set local_modules [list] |
|
set git_modules [list] |
|
set fossil_modules [list] |
|
set sourcefolder $projectroot/src |
|
#todo vendor/lib |
|
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] |
|
|
|
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] |
|
#lappend vendormodulefolders vendormodules |
|
foreach vf $vendormodulefolders { |
|
lassign [split $vf _] _vm tclx |
|
if {$tclx ne ""} { |
|
set which _$tclx |
|
} else { |
|
set which "" |
|
} |
|
|
|
set vendor_config $sourcefolder/vendormodules$which/include_modules.config |
|
if {[file exists $vendor_config]} { |
|
set targetroot $sourcefolder/vendormodules$which |
|
source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list |
|
if {![llength $local_modules]} { |
|
puts stderr "src/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)" |
|
} else { |
|
if {[catch { |
|
#---------- |
|
set vendor_installer [punkcheck::installtrack new make.tcl $sourcefolder/vendormodules$which/.punkcheck] |
|
$vendor_installer set_source_target $projectroot $sourcefolder/vendormodules$which |
|
set installation_event [$vendor_installer start_event {-make_step vendorupdate}] |
|
#---------- |
|
} errM]} { |
|
puts stderr "Unable to use punkcheck for vendormodules$which update. Error: $errM" |
|
set installation_event "" |
|
} |
|
#todo - sync alg with bootsupport_localupdate! |
|
foreach {relpath requested_module} $local_modules { |
|
set requested_module [string trim $requested_module :] |
|
set module_subpath [string map {:: /} [namespace qualifiers $requested_module]] |
|
set srclocation [file join $projectroot $relpath $module_subpath] |
|
#puts stdout "$relpath $module $module_subpath $srclocation" |
|
|
|
#todo - check if requested_module has version extension and allow explicit versions instead of just latest |
|
#allow modulename-* literal in .config to request all versions |
|
|
|
set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $requested_module]-*] |
|
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 |
|
if {![llength $pkgmatches]} { |
|
puts stderr "Missing local source for requested vendor module $requested_module - not found in $srclocation" |
|
continue |
|
} |
|
set latestfile [lindex $pkgmatches 0] ;#default |
|
set latestver [lindex [split [file rootname $latestfile] -] 1] |
|
foreach m $pkgmatches { |
|
lassign [split [file rootname $m] -] _pkg ver |
|
#puts "comparing $ver vs $latestver" |
|
if {[package vcompare $ver $latestver] == 1} { |
|
set latestver $ver |
|
set latestfile $m |
|
} |
|
} |
|
|
|
set srcfile [file join $srclocation $latestfile] |
|
set tgtfile [file join $targetroot $module_subpath $latestfile] |
|
if {$installation_event ne ""} { |
|
#---------- |
|
$installation_event targetset_init INSTALL $tgtfile |
|
$installation_event targetset_addsource $srcfile |
|
#---------- |
|
if {\ |
|
[llength [dict get [$installation_event targetset_source_changes] changed]]\ |
|
|| [llength [$installation_event get_targets_exist]] < [llength [$installation_event get_targets]]\ |
|
} { |
|
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists |
|
$installation_event targetset_started |
|
# -- --- --- --- --- --- |
|
puts "VENDORMODULES$which update: $srcfile -> $tgtfile" |
|
if {[catch { |
|
file copy -force $srcfile $tgtfile |
|
} errM]} { |
|
$installation_event targetset_end FAILED |
|
} else { |
|
$installation_event targetset_end OK |
|
} |
|
# -- --- --- --- --- --- |
|
} else { |
|
puts -nonewline stderr "." |
|
$installation_event targetset_end SKIPPED |
|
} |
|
$installation_event end |
|
} else { |
|
file copy -force $srcfile $tgtfile |
|
} |
|
} |
|
|
|
} |
|
} else { |
|
puts stderr "No config at $vendor_config - nothing configured to update" |
|
} |
|
} |
|
} |
|
|
|
vendor_localupdate $projectroot |
|
|
|
puts stdout " vendor package update done " |
|
flush stderr |
|
flush stdout |
|
::exit 0 |
|
} |
|
|
|
if {$::punkboot::command eq "bootsupport"} { |
|
puts "projectroot: $projectroot" |
|
puts "script: [info script]" |
|
#puts "-- [tcl::tm::list] --" |
|
puts stdout "Updating bootsupport from local files" |
|
|
|
proc modfile_sort {p1 p2} { |
|
lassign [split [file rootname $p1] -] _ v1 |
|
lassign [split [file rootname $p1] -] _ v2 |
|
package vcompare $v1 $v2 |
|
} |
|
proc bootsupport_localupdate {projectroot} { |
|
set bootsupport_modules [list] ;#variable populated by include_modules.config file - review |
|
set sourcefolder $projectroot/src |
|
|
|
set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules modules_tcl*] |
|
foreach bm $bootmodulefolders { |
|
lassign [split $bm _] _bm tclx |
|
if {$tclx ne ""} { |
|
set which _$tclx |
|
} else { |
|
set which "" |
|
} |
|
set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# |
|
if {[file exists $bootsupport_config]} { |
|
set targetroot $projectroot/src/bootsupport/modules$which |
|
source $bootsupport_config ;#populate $bootsupport_modules with project-specific list |
|
if {![llength $bootsupport_modules]} { |
|
puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" |
|
} else { |
|
|
|
if {[catch { |
|
#---------- |
|
set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] |
|
$boot_installer set_source_target $projectroot $projectroot/src/bootsupport |
|
set boot_event [$boot_installer start_event {-make_step bootsupport}] |
|
#---------- |
|
} errM]} { |
|
puts stderr "Unable to use punkcheck for bootsupport error: $errM" |
|
set boot_event "" |
|
} |
|
|
|
foreach {relpath modulematch} $bootsupport_modules { |
|
set modulematch [string trim $modulematch :] |
|
set module_subpath [string map [list :: /] [namespace qualifiers $modulematch]] |
|
set srclocation [file join $projectroot $relpath $module_subpath] |
|
#puts stdout "$relpath $modulematch $module_subpath $srclocation" |
|
if {[string first - $modulematch]} { |
|
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]*.tm] |
|
} else { |
|
set pkgmatches [glob -nocomplain -dir $srclocation -tail -type f [namespace tail $modulematch]-*.tm] |
|
} |
|
if {![llength $pkgmatches]} { |
|
puts stderr "Missing source for bootsupport module $modulematch - no matches in $srclocation" |
|
continue |
|
} |
|
|
|
set modulematch_is_glob [regexp {[*?\[\]]} $modulematch] |
|
if {!$modulematch_is_glob} { |
|
#if modulematch was specified without globs - only copy latest |
|
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1b3 - use helper func |
|
set pkgmatches [lsort -command modfile_sort $pkgmatches] |
|
set latestfile [lindex $pkgmatches end] |
|
#set latestver [lindex [split [file rootname $latestfile] -] 1] |
|
set copy_files $latestfile |
|
} else { |
|
#globs in modulematch - may be different packages matched by glob - copy all versions of matches |
|
#review |
|
set copy_files $pkgmatches |
|
} |
|
foreach cfile $copy_files { |
|
set srcfile [file join $srclocation $cfile] |
|
set tgtfile [file join $targetroot $module_subpath $cfile] |
|
if {$boot_event ne ""} { |
|
#---------- |
|
$boot_event targetset_init INSTALL $tgtfile |
|
$boot_event targetset_addsource $srcfile |
|
#---------- |
|
if {\ |
|
[llength [dict get [$boot_event targetset_source_changes] changed]]\ |
|
|| [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ |
|
} { |
|
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists |
|
$boot_event targetset_started |
|
# -- --- --- --- --- --- |
|
puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile" |
|
if {[catch { |
|
file copy -force $srcfile $tgtfile |
|
} errM]} { |
|
$boot_event targetset_end FAILED |
|
} else { |
|
$boot_event targetset_end OK |
|
} |
|
# -- --- --- --- --- --- |
|
} else { |
|
puts -nonewline stderr "." |
|
$boot_event targetset_end SKIPPED |
|
} |
|
$boot_event end |
|
} else { |
|
file copy -force $srcfile $tgtfile |
|
} |
|
} |
|
} |
|
if {$boot_event ne ""} { |
|
puts \n |
|
$boot_event destroy |
|
$boot_installer destroy |
|
} |
|
} |
|
|
|
} |
|
} |
|
} |
|
|
|
bootsupport_localupdate $projectroot |
|
|
|
#if this project has custom project layouts, and there is a bootsupport folder - update their bootsupport |
|
|
|
set layout_bases [list\ |
|
$sourcefolder/project_layouts/custom/_project\ |
|
] |
|
foreach project_layout_base $layout_bases { |
|
if {[file exists $project_layout_base]} { |
|
set project_layouts [glob -nocomplain -dir $project_layout_base -type d -tail *] |
|
foreach layoutname $project_layouts { |
|
puts stdout "Processing layout $project_layout_base/$layoutname" |
|
#don't auto-create src/bootsupport - just update it if it exists |
|
if {[file exists [file join $project_layout_base $layoutname/src/bootsupport]]} { |
|
set antipaths [list\ |
|
README.md\ |
|
] |
|
#set boot_module_folders [list modules {*}[glob -nocomplain -dir $projectroot/src/bootsupport/modules_tcl*]] |
|
set bootsupport_module_folders "modules" |
|
foreach bm $bootsupport_module_folders { |
|
if {[file exists $projectroot/src/bootsupport/$bm]} { |
|
lassign [split $bm _] _bm tclx |
|
if {$tclx ne ""} { |
|
set which _$tclx |
|
} else { |
|
set which "" |
|
} |
|
set sourcemodules $projectroot/src/bootsupport/modules$which |
|
set targetroot [file join $project_layout_base $layoutname/src/bootsupport/modules$which] |
|
file mkdir $targetroot |
|
|
|
puts stdout "BOOTSUPPORT$which layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)" |
|
|
|
set resultdict [punkcheck::install $sourcemodules $targetroot\ |
|
-overwrite installedsourcechanged-targets\ |
|
-antiglob_paths $antipaths\ |
|
-installer "punkboot-bootsupport" |
|
] |
|
|
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
flush stdout |
|
} |
|
} |
|
} |
|
#make.tcl (to be boot.tcl?) is part of bootsupport |
|
set source_bootscript [file join $projectroot src/make.tcl] |
|
set targetroot_bootscript $project_layout_base/$layoutname/src |
|
if {[file exists $source_bootscript]} { |
|
puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $source_bootscript to $targetroot_bootscript (if source file changed)" |
|
set resultdict [punkcheck::install [file dirname $source_bootscript] $targetroot_bootscript\ |
|
-glob make.tcl\ |
|
-max_depth 1\ |
|
-createempty 0\ |
|
-overwrite installedsourcechanged-targets\ |
|
-installer "punkboot-bootsupport" |
|
] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
flush stdout |
|
} |
|
} |
|
} else { |
|
puts stderr "No layout base at $project_layout_base" |
|
} |
|
} |
|
puts stdout " bootsupport done " |
|
flush stderr |
|
flush stdout |
|
#punk86 can hang if calling make.tcl via 'run' without this 'after' delay. punk87 unaffected. cause unknown. |
|
#after 500 |
|
::exit 0 |
|
} |
|
|
|
|
|
|
|
if {$::punkboot::command ni {project modules vfs}} { |
|
puts stderr "Command $::punkboot::command not implemented - aborting." |
|
flush stderr |
|
after 100 |
|
exit 1 |
|
} |
|
|
|
|
|
|
|
#external libs and modules first - and any supporting files - no 'building' required |
|
|
|
#install src vendor contents (from version controlled src folder) to base of project (same target folders as our own src/modules etc ie to paths that go on the auto_path and in tcl::tm::list) |
|
|
|
if {$::punkboot::command in {project modules}} { |
|
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules vendormodules_tcl*] |
|
foreach vf $vendormodulefolders { |
|
lassign [split $vf _] _vm tclx |
|
if {$tclx ne ""} { |
|
set which _$tclx |
|
} else { |
|
set which "" |
|
} |
|
set target_module_folder $projectroot/modules$which |
|
file mkdir $target_module_folder |
|
|
|
#install .tm *and other files* |
|
puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" |
|
set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} |
|
if {![llength $vendormodulefolders]} { |
|
puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found." |
|
} |
|
|
|
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib vendorlib_tcl*] |
|
foreach lf $vendorlibfolders { |
|
lassign [split $lf _] _vm tclx |
|
if {$tclx ne ""} { |
|
set which _$tclx |
|
} else { |
|
set which "" |
|
} |
|
set target_lib_folder $projectroot/lib$which |
|
file mkdir $projectroot/lib$which |
|
#exclude README.md from source folder - but only the root one |
|
#-antiglob_paths takes relative patterns e.g |
|
# */test.txt will only match test.txt exactly one level deep. |
|
# */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. |
|
# **/test.txt will match at any level below the root (but not in the root) |
|
set antipaths [list\ |
|
README.md\ |
|
] |
|
puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" |
|
set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} |
|
if {![llength $vendorlibfolders]} { |
|
puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." |
|
} |
|
|
|
|
|
######################################################## |
|
#templates |
|
#e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync |
|
#src to src/modules/punk/mix/templates/layouts/project/src |
|
|
|
set old_layout_update_list [list\ |
|
[list project $sourcefolder/modules/punk/mix/templates]\ |
|
[list basic $sourcefolder/mixtemplates]\ |
|
] |
|
set layout_bases [list\ |
|
$sourcefolder/project_layouts/custom/_project\ |
|
] |
|
|
|
foreach layoutbase $layout_bases { |
|
if {![file exists $layoutbase]} { |
|
continue |
|
} |
|
set project_layouts [glob -nocomplain -dir $layoutbase -type d -tail *] |
|
foreach layoutname $project_layouts { |
|
set config [dict create\ |
|
-make-step sync_layouts\ |
|
] |
|
#---------- |
|
set tpl_installer [punkcheck::installtrack new make.tcl $layoutbase/.punkcheck] |
|
$tpl_installer set_source_target $sourcefolder $layoutbase |
|
set tpl_event [$tpl_installer start_event $config] |
|
#---------- |
|
set pairs [list] |
|
set pairs [list\ |
|
[list $sourcefolder/build.tcl $layoutbase/$layoutname/src/build.tcl]\ |
|
[list $sourcefolder/make.tcl $layoutbase/$layoutname/src/make.tcl]\ |
|
] |
|
|
|
foreach filepair $pairs { |
|
lassign $filepair srcfile tgtfile |
|
|
|
file mkdir [file dirname $tgtfile] |
|
#---------- |
|
$tpl_event targetset_init INSTALL $tgtfile |
|
$tpl_event targetset_addsource $srcfile |
|
#---------- |
|
if {\ |
|
[llength [dict get [$tpl_event targetset_source_changes] changed]]\ |
|
|| [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]]\ |
|
} { |
|
$tpl_event targetset_started |
|
# -- --- --- --- --- --- |
|
puts stdout "PROJECT LAYOUT update - layoutname: $layoutname Copying from $srcfile to $tgtfile" |
|
if {[catch { |
|
file copy -force $srcfile $tgtfile |
|
} errM]} { |
|
$tpl_event targetset_end FAILED -note "layout:$layoutname copy failed with err: $errM" |
|
} else { |
|
$tpl_event targetset_end OK -note "layout:$layoutname" |
|
} |
|
# -- --- --- --- --- --- |
|
} else { |
|
puts stderr "." |
|
$tpl_event targetset_end SKIPPED |
|
} |
|
} |
|
|
|
$tpl_event end |
|
$tpl_event destroy |
|
$tpl_installer destroy |
|
} |
|
} |
|
######################################################## |
|
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*] |
|
lappend projectlibfolders lib |
|
foreach lf $projectlibfolders { |
|
lassign [split $lf _] _vm tclx |
|
if {$tclx ne ""} { |
|
set which _$tclx |
|
} else { |
|
set which "" |
|
} |
|
set target_lib_folder $projectroot/lib$which |
|
file mkdir $projectroot/lib$which |
|
#exclude README.md from source folder - but only the root one |
|
#-antiglob_paths takes relative patterns e.g |
|
# */test.txt will only match test.txt exactly one level deep. |
|
# */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. |
|
# **/test.txt will match at any level below the root (but not in the root) |
|
set antipaths [list\ |
|
README.md\ |
|
] |
|
puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" |
|
set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} |
|
if {![llength $projectlibfolders]} { |
|
puts stderr "PROJECTLIB: No src/lib or src/lib_tcl* folder found." |
|
} |
|
|
|
#consolidated /modules /modules_tclX folder used for target where X is tcl major version |
|
#the make process will process for any _tclX not just the major version of the current interpreter |
|
|
|
#default source module folders are at projectroot/src/modules and projectroot/src/modules_tclX (where X is tcl major version) |
|
#There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) |
|
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] |
|
puts stdout "SOURCEMODULES: scanning [llength $source_module_folderlist] folders" |
|
foreach src_module_dir $source_module_folderlist { |
|
set mtail [file tail $src_module_dir] |
|
if {[string match "modules_tcl*" $mtail]} { |
|
set target_modules_base $projectroot/$mtail |
|
} else { |
|
set target_modules_base $projectroot/modules |
|
} |
|
file mkdir $target_modules_base |
|
|
|
puts stderr "Processing source module dir: $src_module_dir" |
|
set dirtail [file tail $src_module_dir] |
|
#modules and associated files belonging to this package/app |
|
set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm |
|
#set copied [list] |
|
puts stdout "--------------------------" |
|
puts stderr "Copied [llength $copied] tm modules from src/$dirtail to $target_modules_base " |
|
puts stdout "--------------------------" |
|
|
|
set overwrite "installedsourcechanged-targets" |
|
#set overwrite "ALL-TARGETS" |
|
puts stdout "MODULEFOLDER non_tm_files $src_module_dir - copying to $target_modules_base (if source file changed)" |
|
set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base -installer make.tcl -overwrite $overwrite -antiglob_paths {README.md}] |
|
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
|
} |
|
|
|
set installername "make.tcl" |
|
|
|
# ---------------------------------------- |
|
if {[punk::repo::is_fossil_root $projectroot]} { |
|
set config [dict create\ |
|
-make-step configure_fossil\ |
|
] |
|
#---------- |
|
set installer [punkcheck::installtrack new $installername $projectroot/.punkcheck] |
|
$installer set_source_target $projectroot $projectroot |
|
|
|
set event [$installer start_event $config] |
|
$event targetset_init VIRTUAL fossil_settings_mainmenu ;#VIRTUAL - since there is no actual target file |
|
set menufile $projectroot/.fossil-custom/mainmenu |
|
$event targetset_addsource $menufile |
|
#---------- |
|
|
|
if {\ |
|
[llength [dict get [$event targetset_source_changes] changed]]\ |
|
} { |
|
$event targetset_started |
|
# -- --- --- --- --- --- |
|
puts stdout "Configuring fossil setting: mainmenu from: $menufile" |
|
if {[catch { |
|
set fd [open $menufile r] |
|
fconfigure $fd -translation binary |
|
set data [read $fd] |
|
close $fd |
|
exec fossil settings mainmenu $data |
|
} errM]} { |
|
$event targetset_end FAILED -note "fossil update failed: $errM" |
|
} else { |
|
$event targetset_end OK |
|
} |
|
# -- --- --- --- --- --- |
|
} else { |
|
puts stderr "." |
|
$event targetset_end SKIPPED |
|
} |
|
$event end |
|
$event destroy |
|
$installer destroy |
|
} |
|
} |
|
|
|
#review |
|
set installername "make.tcl" |
|
|
|
if {$::punkboot::command ni {project vfs}} { |
|
#command = modules |
|
puts stdout "vfs folders not checked" |
|
puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into base vfs folder" |
|
puts stdout " - use 'make.tcl project' to build executable kits/zipkits from vfs folders as well if you have runtimes installed" |
|
puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but" |
|
puts stdout " without the latest built modules." |
|
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'" |
|
puts stdout "-done-" |
|
exit 0 |
|
} |
|
|
|
|
|
set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] |
|
if {$buildfolder ne "$sourcefolder/_build"} { |
|
puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure" |
|
puts stdout " -aborted- " |
|
exit 2 |
|
} |
|
|
|
|
|
#find runtimes |
|
set rtfolder $sourcefolder/runtime |
|
#review - when building kits for other platforms - it's unlikely runtime will be marked as executable - we should probably process all files in runtime folder except those with certain extensions |
|
set rtfolder_files [glob -nocomplain -dir $rtfolder -types {f} -tail *] |
|
set exclusions {.config .md .ico .txt .doc .pdf .htm .html} ;#we don't encourage other files in runtime folder aside from mapvfs.config - but lets ignore some common possibilities |
|
lappend exclusions .zip .7z .pea .bz2 .tar .gz .tgz .z .xz ;#don't allow archives to directly be treated as runtimes - tolerate presence but require user to unpack or rename if they're to be used as runtimes |
|
lappend exclusions .tail ;#result of running sdx mksplit on a kit - in theory the .head could be used - review/test |
|
set runtimes [list] |
|
foreach f $rtfolder_files { |
|
if {[string tolower [file extension $f]] in $exclusions} { |
|
continue |
|
} |
|
lappend runtimes $f |
|
} |
|
if {![llength $runtimes]} { |
|
puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables." |
|
puts stderr "Add runtimes to $sourcefolder/runtime if required" |
|
#todo - don't exit - it is valid to use runtime of - to just build a .kit/.zipkit ? |
|
exit 0 |
|
} |
|
|
|
set has_sdx 1 |
|
if {[catch {exec sdx help} errM]} { |
|
puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" |
|
puts stderr "err: $errM" |
|
#exit 1 |
|
set has_sdx 0 |
|
} |
|
|
|
# -- --- --- --- --- --- --- --- --- --- |
|
#load mapvfs.config file (if any) in runtime folder to map runtimes to vfs folders. |
|
#build a dict keyed on runtime executable name. |
|
#If no mapfile (or no mapfile entry for that runtime) - the runtime will be paired with a matching .vfs folder in src folder. e.g punk.exe to src/punk.vfs |
|
#If vfs folders or runtime executables which are explicitly listed in the mapfile don't exist - warn on stderr - but continue. if such nonexistants found; prompt user for whether to continue or abort. |
|
set mapfile $rtfolder/mapvfs.config |
|
set runtime_vfs_map [dict create] |
|
set vfs_runtime_map [dict create] |
|
if {[file exists $mapfile]} { |
|
set fdmap [open $mapfile r] |
|
fconfigure $fdmap -translation binary |
|
set mapdata [read $fdmap] |
|
close $fdmap |
|
set mapdata [string map [list \r\n \n] $mapdata] |
|
set missing [list] |
|
foreach ln [split $mapdata \n] { |
|
set ln [string trim $ln] |
|
if {$ln eq "" || [string match #* $ln]} { |
|
continue |
|
} |
|
set vfs_specs [lassign $ln runtime] |
|
if {[string match *.exe $runtime]} { |
|
#.exe is superfluous but allowed |
|
#drop windows .exe suffix so same config can work cross platform - extension will be re-added if necessary later |
|
set runtime [string range $runtime 0 end-4] |
|
} |
|
if {$runtime ne "-"} { |
|
set runtime_test $runtime |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
set runtime_test $runtime.exe |
|
} |
|
if {![file exists [file join $rtfolder $runtime_test]]} { |
|
puts stderr "WARNING: Missing runtime file $rtfolder/$runtime_test (line in mapvfs.config: $ln)" |
|
lappend missing $runtime |
|
} |
|
} |
|
foreach vfsconfig $vfs_specs { |
|
switch -- [llength $vfsconfig] { |
|
1 - 2 - 3 { |
|
lassign $vfsconfig vfstail appname kit_type |
|
if {![file isdirectory [file join $sourcefolder vfs $vfstail]]} { |
|
puts stderr "WARNING: Missing vfs folder [file join $sourcefolder vfs $vfstail] specified in mapvfs.config for runtime $runtime" |
|
lappend missing $vfstail |
|
} else { |
|
if {$appname eq ""} { |
|
set appname [file rootname $vfstail] |
|
} |
|
dict lappend vfs_runtime_map $vfstail [list $runtime $appname $kit_type] |
|
} |
|
} |
|
default { |
|
puts stderr "bad entry in mapvfs.config - expected each entry after the runtime name to be of length 1 or length 2. got: $vfsconfig ([llength $vfsconfig])" |
|
} |
|
} |
|
|
|
|
|
} |
|
if {[dict exists $runtime_vfs_map $runtime]} { |
|
puts stderr "CONFIG FILE ERROR. runtime: $runtime was specified more than once in $mapfile." |
|
exit 3 |
|
} |
|
dict set runtime_vfs_map $runtime $vfs_specs |
|
} |
|
if {[llength $missing]} { |
|
puts stderr "WARNING [llength $missing] missing items from $mapfile. (TODO - prompt user to continue/abort)" |
|
foreach m $missing { |
|
puts stderr " $m" |
|
} |
|
puts stderr "continuing..." |
|
} |
|
} |
|
# -- --- --- --- --- --- --- --- --- --- |
|
puts "-- runtime_vfs_map --" |
|
punk::lib::pdict runtime_vfs_map |
|
puts "---------------------" |
|
puts "-- vfs_runtime_map--" |
|
punk::lib::pdict vfs_runtime_map |
|
puts "---------------------" |
|
|
|
#only test the runtime capabilities for runtimes that are actually in our map |
|
#how can we do this for runtimes from other platforms? |
|
#method1 try to mount as zip and kit - depends on current runtime to have mkzip - just because there is zip data doesn't mean the kit can mount it |
|
#method2 analyze executable to determine if its for another platform - then ask user and save answers in a config file.? |
|
set runtime_caps [dict create] |
|
foreach runtime [dict keys $runtime_vfs_map] { |
|
set capscript { |
|
set caps [dict create] |
|
dict set caps patchlevel [info patchlevel] |
|
if {![catch { |
|
package require starkit |
|
} errM]} { |
|
dict set caps has_starkit 1 |
|
} else { |
|
dict set caps has_starkit 0 |
|
} |
|
if {![catch { |
|
set cmd [info commands tcl::zipfs::root] |
|
if {$cmd ne ""} { |
|
dict set caps has_zipfs 1 |
|
} else { |
|
dict set caps has_zipfs 0 |
|
} |
|
} errM]} |
|
if {![catch { |
|
package require cookfs |
|
} errM]} { |
|
dict set caps has_cookfs 1 |
|
} else { |
|
dict set caps has_cookfs 0 |
|
} |
|
puts -nonewline stdout $caps |
|
exit 0 |
|
} |
|
#invoke can fail if runtime not an executable file for the current platform |
|
if {![catch { |
|
lassign [punk::lib::invoke [list $rtfolder/$runtime <<$capscript]] stdout stderr exitcode |
|
} errM]} { |
|
if {$exitcode == 0} { |
|
dict set runtime_caps $runtime $stdout |
|
} |
|
dict set runtime_caps $runtime exitcode $exitcode |
|
} else { |
|
dict set runtime_caps $runtime exitcode -1 error "launch-fail" |
|
} |
|
} |
|
puts stdout "Runtime capabilities:" |
|
punk::lib::pdict runtime_caps |
|
|
|
set vfs_tails [glob -nocomplain -dir $sourcefolder/vfs -types d -tail *.vfs] |
|
#add any extra .vfs folders found in runtime/mapvfs.config file (e.g myotherruntimes/something.vfs) |
|
dict for {vfstail -} $vfs_runtime_map { |
|
if {$vfstail ni $vfs_tails} { |
|
lappend vfs_tails $vfstail |
|
} |
|
} |
|
if {![llength $vfs_tails]} { |
|
puts stdout "No .vfs folders found at '$sourcefolder/vfs' - no kits to build" |
|
puts stdout " -done- " |
|
exit 0 |
|
} |
|
|
|
set vfs_folder_changes [dict create] ;#cache whether each .vfs folder has changes so we don't re-run tests if building from same .vfs with multiple runtime executables |
|
|
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
#make build copy for all runtimes - not just those in the map - because even without a mapvfs.config file entry we build an exe for a runtime that matches .vfs folder name - REVIEW. |
|
foreach runtimefile $runtimes { |
|
#runtimefile e.g tclkit86bi.exe on windows tclkit86bi on other platforms |
|
|
|
#sdx *may* be pointed to use the runtime we use to build the kit, or the user may manually use this runtime if they don't have tclsh |
|
#sdx will complain if the same runtime is used for the shell as is used in the -runtime argument - so we make a copy (REVIEW) |
|
#if {![file exists $buildfolder/buildruntime.exe]} { |
|
# file copy $rtfolder/$runtimefile $buildfolder/buildruntime.exe |
|
#} |
|
|
|
set basedir $buildfolder |
|
set config [dict create\ |
|
-make-step copy_runtime\ |
|
] |
|
#---------- |
|
set installer [punkcheck::installtrack new $installername $basedir/.punkcheck] |
|
$installer set_source_target $rtfolder $buildfolder |
|
set event [$installer start_event $config] |
|
$event targetset_init INSTALL $buildfolder/build_$runtimefile |
|
$event targetset_addsource $rtfolder/$runtimefile |
|
#---------- |
|
|
|
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
|
if {\ |
|
[llength [dict get [$event targetset_source_changes] changed]]\ |
|
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
|
} { |
|
$event targetset_started |
|
# -- --- --- --- --- --- |
|
#This is the full runtime - *possibly* with some sort of vfs attached. |
|
puts stdout "Copying runtime (as is) from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" |
|
if {[catch { |
|
file copy -force $rtfolder/$runtimefile $buildfolder/build_$runtimefile ;#becomes building_runtime |
|
} errM]} { |
|
puts stderr " >> copy runtime to $buildfolder/build_$runtimefile FAILED" |
|
$event targetset_end FAILED |
|
} else { |
|
$event targetset_end OK |
|
} |
|
# -- --- --- --- --- --- |
|
} else { |
|
puts stderr "unchanged: $runtimefile" |
|
$event targetset_end SKIPPED |
|
} |
|
$event end |
|
|
|
} |
|
|
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
set failed_kits [list] |
|
set installed_kits [list] |
|
set skipped_kits [list] |
|
set skipped_kit_installs [list] |
|
|
|
proc ::make_file_traversal_error {args} { |
|
error "file_traverse error: $args" |
|
} |
|
|
|
#fauxlink aware recursive copy of files and folders |
|
#will follow fauxlinks with 'merge_over' tag, will copy other fauxlinks |
|
proc merge_over {sourcedir targetdir {depth 0}} { |
|
package require fileutil |
|
package require fauxlink |
|
set margin [string repeat " " [expr {$depth * 4}]] |
|
|
|
set ver [package require fileutil::traverse] |
|
puts stdout "${margin}using fileutil::traverse $ver\n[package ifneeded fileutil::traverse $ver]" |
|
package require control |
|
|
|
if {![file exists $sourcedir]} { |
|
puts stderr "${margin}merge_over sourcedir '$sourcedir' not found" |
|
return |
|
} |
|
if {![file exists $targetdir]} { |
|
puts stderr "${margin}merge_over targetdir '$targetdir' not found - target folder must already exist" |
|
return |
|
} |
|
puts stdout "${margin}merge vfs $sourcedir over $targetdir STARTING" |
|
|
|
#The tails should be unique enough for clarity in progress emissions to stdout |
|
set sourcename [file tail $sourcedir] |
|
set targetname [file tail $targetdir] |
|
|
|
set t [fileutil::traverse %AUTO% $sourcedir -errorcmd ::make_file_traversal_error] |
|
set last_type "-" |
|
$t foreach file_or_dir { |
|
set relpath [fileutil::stripPath $sourcedir $file_or_dir] |
|
set target [file join $targetdir $relpath] |
|
set this_type [file type $file_or_dir] |
|
switch -exact -- $this_type { |
|
directory { |
|
if {$last_type ne "directory"} { |
|
puts -nonewline stdout \n |
|
} |
|
if {![file exists $target]} { |
|
#puts stdout "-- mkdir $target" |
|
puts stdout "${margin}$sourcename -> $targetname mkdir $relpath" |
|
#puts stdout "calling: file mkdir $target" |
|
#note - file mkdir can fail on vfs mounts with non-existant intermediate paths. |
|
#e.g if mount is at: //cookfstemp:/subpath/file.exe |
|
#if mounted lower, e.g //cookfstemp:/file.exe it works |
|
#todo - determine where the bug lies - submit ticket? |
|
file mkdir $target |
|
file mtime $target [file mtime $file_or_dir] |
|
} else { |
|
puts stdout "${margin}$sourcename -> $targetname existing dir $relpath" |
|
} |
|
} |
|
file { |
|
if {[file extension $file_or_dir] in {.fxlnk .fauxlink}} { |
|
puts stdout "fauxlink: $file_or_dir" |
|
flush stdout |
|
if {[catch { |
|
puts stdout ">";flush stdout |
|
set linkinfo [fauxlink::resolve $file_or_dir] |
|
} errM]} { |
|
puts stdout ">>";flush stdout |
|
puts stdout "${margin}--->fauxlink::resolve error\n $errM" |
|
flush stdout |
|
error $errM |
|
} |
|
puts stdout ">>>";flush stdout |
|
puts stdout "--- '$linkinfo'" |
|
flush stdout |
|
set flinktags [dict get $linkinfo tags] |
|
puts stdout "fauxlink tags: $flinktags" |
|
flush stdout |
|
if {"punk::boot,merge_over" in $flinktags} { |
|
puts stdout "fauxlink got correct tag from $flinktags" |
|
flush stdout |
|
set linktarget [dict get $linkinfo targetpath] |
|
if {[file pathtype $linktarget] eq "relative"} { |
|
set actualsource [file join $sourcedir $linktarget] |
|
} else { |
|
set actualsource $linktarget |
|
} |
|
set name [dict get $linkinfo name] ;#name the linked file will become |
|
set aliased_file_or_dir [file join [file dirname $file_or_dir] $name] |
|
set relpath [fileutil::stripPath $sourcedir $aliased_file_or_dir] |
|
set target [file join $targetdir $relpath] |
|
if {[file type $actualsource] eq "file"} { |
|
#fauxlink linktarget (source data) is a file |
|
puts -nonewline stdout "\x1b\[32m<fxlnk.targetfor.${name}>\x1b\[m" |
|
#puts "file copy -force $actualsource $target" |
|
file copy -force $actualsource $target |
|
} else { |
|
#fauxlink linktarget (source data) is a folder |
|
puts stdout "${margin}RECURSING merge_over for link-target $actualsource due to fauxlink:[file tail $file_or_dir]" |
|
#merge_over initial target dir must exist - use file mkdir to ensure |
|
file mkdir $target |
|
puts stdout "merge_over $actualsource $target [expr {$depth + 1}]" |
|
merge_over $actualsource $target [expr {$depth + 1}] |
|
} |
|
} else { |
|
puts stdout "fauxlink tag not matched" |
|
flush stdout |
|
#tag not targetted at us - just copy the fauxlink as an ordinary file |
|
puts -nonewline stdout "<fxlnk>" |
|
file copy -force $file_or_dir $target |
|
} |
|
} else { |
|
puts -nonewline stdout "." |
|
file copy -force $file_or_dir $target |
|
} |
|
} |
|
default { |
|
puts stderr "${margin}merge vfs $sourcedir !!! unhandled file type $this_type !!!" |
|
} |
|
} |
|
set last_type $this_type |
|
} |
|
$t destroy |
|
puts stdout "\n${margin}merge vfs $sourcedir over $targetdir done." |
|
} |
|
set startdir [pwd] |
|
puts stdout "Found [llength $vfs_tails] .vfs folders - checking each for executables that may need to be built" |
|
cd [file dirname $buildfolder] |
|
#root folder mtime is insufficient for change detection. Tree mtime of folders only is a barely passable mechanism for vfs change detection in some circumstances - e.g if files added/removed but never edited in place |
|
#a hash of full tree file & dir mtime may be more reasonable - but it remains to be seen if just tar & checksum is any/much slower. |
|
#Simply rebuilding all the time may be close the speed of detecting change anyway - and almost certainly much faster when there is a change. |
|
#Using first mtime encountered that is later than target is another option - but likely to be highly variable in speed. Last file in the tree could happen to be the latest, and this mechanism doesn't handle build on reversion to older source. |
|
set exe_names_seen [list] |
|
set path_cksum_cache [dict create] |
|
dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/_vfscommon.vfs] |
|
|
|
# |
|
# loop over vfs_tails and for each one, loop over configured (or matching) runtimes - build with sdx or zipfs if source .vfs or source runtime exe has changed. |
|
# we are using punkcheck to install result to buildfolder so we create a .punkcheck file at the target folder to store metadata. |
|
# punkcheck allows us to not rely purely on timestamps (which may be unreliable) |
|
# |
|
foreach vfstail $vfs_tails { |
|
|
|
set vfsname [file rootname $vfstail] |
|
puts stdout " ------------------------------------" |
|
puts stdout " checking vfs $sourcefolder/vfs/$vfstail for configured runtimes" |
|
set skipped_vfs_build 0 |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
set basedir $buildfolder |
|
set config [dict create\ |
|
-make-step build_vfs\ |
|
] |
|
|
|
|
|
set runtimes [list] |
|
if {[dict exists $vfs_runtime_map $vfstail]} { |
|
#set runtimes [dict get $vfs_runtime_map $vfstail] |
|
#runtimes in vfs_runtime_map_vfs dict are unsuffixed (.exe stripped or was not present) |
|
set applist [dict get $vfs_runtime_map $vfstail] |
|
foreach rt_app $applist { |
|
lappend runtimes [lindex $rt_app 0] |
|
} |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
set runtimes_raw $runtimes |
|
set runtimes [list] |
|
foreach rt $runtimes_raw { |
|
if {![string match *.exe $rt] && $rt ne "-"} { |
|
set rt $rt.exe |
|
} |
|
lappend runtimes $rt |
|
} |
|
} |
|
} else { |
|
#only match this vfs to a correspondingly named runtime if there was no explicit entry for that runtime |
|
set matchrt [file rootname [file tail $vfstail]] ;#e.g project.vfs -> project |
|
if {![dict exists $runtime_vfs_map $matchrt]} { |
|
if {"windows" eq $::tcl_platform(platform)} { |
|
if {[file exists $rtfolder/$matchrt.exe]} { |
|
lappend runtimes $matchrt.exe |
|
} |
|
} else { |
|
lappend runtimes $matchrt |
|
} |
|
} |
|
} |
|
#assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config |
|
|
|
puts " vfs: $vfstail runtimes to process ([llength $runtimes]): $runtimes" |
|
#todo - non kit based - zipkit? |
|
# $runtimes may now include a dash entry "-" (from mapvfs.config file) |
|
foreach runtime_fullname $runtimes { |
|
set rtname [file rootname $runtime_fullname] |
|
#rtname of "-" indicates build a kit without a runtime |
|
|
|
#first configured runtime will be the one to use the same name as .vfs folder for output executable. Additional runtimes on this .vfs will need to suffix the runtime name to disambiguate. |
|
#review: This mechanism may not be great for multiplatform builds ? We may be better off consistently combining vfsname and rtname and letting a later platform-specific step choose ones to install in bin with simpler names. |
|
|
|
set targetkits [list] |
|
|
|
if {[dict exists $runtime_vfs_map $rtname]} { |
|
set applist [dict get $runtime_vfs_map $rtname] |
|
foreach vfs_app $applist { |
|
lassign $vfs_app configured_vfs appname kit_type |
|
if {$configured_vfs ne $vfstail} { |
|
continue |
|
} |
|
if {$appname eq ""} { |
|
set appname $vfsname |
|
} |
|
if {$kit_type eq ""} { |
|
set kit_type "kit" ;#review - we should probably move to defaulting to zip (zipkit) |
|
} |
|
if {$rtname eq "-"} { |
|
set targetkit $appname.kit |
|
} else { |
|
if {$::tcl_platform(platform) eq "windows"} { |
|
set targetkit ${appname}.exe |
|
} else { |
|
set targetkit $appname |
|
} |
|
if {$targetkit in $exe_names_seen} { |
|
#duplicate appname configured? |
|
#todo - consider creating as ${appname}(2) etc? |
|
puts stderr "targetkit: $targetkit already seen - using name ${appname}_$rtname" |
|
set targetkit ${appname}_$rtname |
|
} |
|
} |
|
lappend exe_names_seen $targetkit |
|
lappend targetkits [list $targetkit $kit_type] |
|
} |
|
} |
|
puts stdout " vfs: $vfstail runtime: $rtname targetkits: $targetkits" |
|
foreach targetkit_info $targetkits { |
|
puts stdout " processing targetkit: $targetkit_info" |
|
lassign $targetkit_info targetkit kit_type |
|
# -- ---------- |
|
set vfs_installer [punkcheck::installtrack new $installername $basedir/.punkcheck] |
|
$vfs_installer set_source_target $sourcefolder $buildfolder |
|
set vfs_event [$vfs_installer start_event {-make-step build_vfs}] |
|
$vfs_event targetset_init INSTALL $buildfolder/$targetkit |
|
set relvfs [punkcheck::lib::path_relative $basedir $sourcefolder/vfs/$vfstail] |
|
if {![dict exists $path_cksum_cache $relvfs]} { |
|
#e.g ../vfs/punk87.vfs {cksum xxxx cksum_all_opts {-cksum_content 1 ... -cksum_algorithm sha1}} |
|
dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/$vfstail] |
|
} |
|
$vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder |
|
$vfs_event targetset_addsource $sourcefolder/vfs/_config ;#some files linked via fauxlink - need to detect change |
|
$vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon.vfs |
|
$vfs_event targetset_addsource $sourcefolder/vfs/$vfstail |
|
if {$rtname ne "-"} { |
|
set building_runtime $buildfolder/build_$runtime_fullname ;#working copy of runtime executable - (possibly with kit/zipfs/cookfs etc attached!) |
|
$vfs_event targetset_addsource $building_runtime |
|
set raw_runtime "" ;#building runtime with vfs (zip,kit,cookfs etc stripped) |
|
} else { |
|
set building_runtime "-" ;#REVIEW |
|
set raw_runtime "-" |
|
} |
|
# -- ---------- |
|
|
|
|
|
set changed_unchanged [$vfs_event targetset_source_changes] |
|
set vfs_or_runtime_changed [expr {[llength [dict get $changed_unchanged changed]] || [llength [$vfs_event get_targets_exist]] < [llength [$vfs_event get_targets]]}] |
|
|
|
if {$vfs_or_runtime_changed} { |
|
#source .vfs folder has changes |
|
$vfs_event targetset_started |
|
# -- --- --- --- --- --- |
|
|
|
if {[file exists $buildfolder/$vfsname.new]} { |
|
puts stderr "deleting existing $buildfolder/$vfsname.new" |
|
file delete $buildfolder/$vfsname.new |
|
} |
|
|
|
package require fileutil |
|
package require fileutil::traverse |
|
package require control |
|
|
|
#keep this a simple name - bin/punk script calls into src/_build/exename.vfs/main.tcl |
|
set targetvfs $buildfolder/$targetkit.vfs |
|
file delete -force $targetvfs |
|
|
|
#we switch on the target kit_type. we could switch on source kit_type..allowing extraction from one type but writing to another? |
|
#it usually won't make sense to try to convert a runtime kit_type to another - unless the runtime happens to support multiple types - |
|
# - but which location would main.tcl be run from? |
|
#todo - check runtime's 'kit_type' and warn/disallow. |
|
#to consider: - allow specifying runtime kits as if they are vfs folders in the normal xxx.vfs list - and autodetect and extract |
|
#would need to detect UPX, cookfs,zipfs,tclkit |
|
set rtmountpoint "" |
|
switch -- $kit_type { |
|
zip - zipcat { |
|
#for a zipkit - we need to extract the existing vfs from the runtime |
|
#zipfs mkimg replaces the entire zipped vfs in the runtime - so we need the original data to be part of our targetvfs. |
|
puts stdout "building $vfsname.new with zipfs vfsdir:$vfstail cwd: [pwd]" |
|
file mkdir $targetvfs |
|
set rtmountpoint //zipfs:/rtmounts/$runtime_fullname |
|
|
|
if {![file exists $rtmountpoint]} { |
|
if {[catch { |
|
tcl::zipfs::mount $building_runtime rtmounts/$runtime_fullname |
|
} errM]} { |
|
puts stderr "Failed to mount $building_runtime using standard api. Err:$errM\n trying reverse args on tcl::zipfs::mount..." |
|
if {[catch { |
|
tcl::zipfs::mount rtmounts/$runtime_fullname $building_runtime |
|
} errM]} { |
|
puts stderr "ALSO Failed to mount $building_runtime using reverse args to api. Err:$errM - no mountable zipfs on runtime?" |
|
} |
|
} |
|
} |
|
|
|
#strip any existing zipfs on the runtime.. |
|
#2024 - 'zipfs info //zipfs:/mountpoint' is supposed to give us the offset - but it doesn't if the exe has been 'adjusted' to use file offsets. |
|
#which unfortunately Tcl does by default after the 2021 'fix' :( |
|
#https://core.tcl-lang.org/tcl/tktview/aaa84fbbc5 |
|
|
|
set raw_runtime $buildfolder/raw_$runtime_fullname |
|
if {[file exists $rtmountpoint]} { |
|
merge_over $rtmountpoint $targetvfs |
|
#see if we can extract the exe part |
|
set baseoffset [lindex [tcl::zipfs::info $rtmountpoint] 3] |
|
if {$baseoffset != 0} { |
|
#tcl was able to determine the compressed-data offset |
|
#either because runtime is a basic catted exe+zip, or Tcl fixed 'zipfs info' |
|
set fdrt [open $building_runtime r] |
|
chan configure $fdrt -translation binary |
|
set exedata [read $fdrt $baseoffset] ;#may include stored password and ending header // REVIEW - strip it? |
|
close $fdrt |
|
set fdraw [open $raw_runtime w] |
|
chan configure $fdraw -translation binary |
|
puts -nonewline $fdraw $exedata |
|
close $fdraw |
|
} else { |
|
#presumably the supplied building_runtime has had its offsets adjusted so that it all appears within offsets off the zip. (file relative offsets) |
|
#due to zipfs info bug - zipfs now can't tell us the offset of the compressed data. |
|
#we need to use a similarly assumptive method as tclZipfs.c uses to determine the start of the compressed contents |
|
package require punk::zip |
|
#we don't technically need to extract the raw exe for 'zip' - as zipfs mkimg can work on the combined file (ignores zip) |
|
# - but for consistency we want raw_runtime to be emitted in the filesystem. |
|
punk::zip::extract_preamble $building_runtime $raw_runtime |
|
} |
|
} else { |
|
#the input building_runtime wasn't mountable - so presumably a plain executable |
|
#set building_runtime $buildfolder/build_$runtime_fullname ;#working copy of runtime executable - (possibly with kit/zipfs/cookfs etc attached!) |
|
#set raw_runtime $buildfolder/raw_$runtime_fullname |
|
file copy -force $building_runtime $raw_runtime |
|
} |
|
|
|
merge_over $sourcefolder/vfs/_vfscommon.vfs $targetvfs |
|
|
|
} |
|
cookit - cookfs { |
|
#upx easy enough to deal with if we have/install a upx executable (avail on windows via scoop, freshports for freebsd and presumably various for linux) |
|
# ------------------------------------------------------ |
|
#we can't use cookfs with arbitrary tclsh/kits etc yet.. |
|
# ------------------------------------------------------ |
|
#cookfs seems to need compilation - we would need to be able to build for windows,linux,freebsd at a minimum. |
|
#preferably vi cross-compile using zig. |
|
|
|
#However, if our calling executable is also a cookit, or the user has cookfs package installed - we may have it available |
|
if {[catch {package require cookfs} version]} { |
|
puts stderr "cookit/cookvfs unsupported - unable to load cookfs" |
|
puts stderr " - Try running make.tcl using a cookkit binary (e.g put it in <projectdir>/bin) or installing the tcl-cookfs module" |
|
} else { |
|
puts stdout "building $vfsname.new with cookfs.. vfsdir:$vfstail cwd: [pwd]" ;flush stdout |
|
file mkdir $targetvfs |
|
#Mount it in the currently running executable |
|
#REVIEW - it seems to work to pick a pseudovol name like //cookfstemp:/ |
|
#unlike cookit's //cookit:/ it doesn't show up in file volumes |
|
#set rtmountpoint //cookfstemp:/rtmounts/$runtime_fullname ;#not writable with 'file mkdir' which doesn't seem to handle intermediate nonexistant path |
|
set rtmountpoint //cookfstemp:/$runtime_fullname |
|
cookfs::Mount $building_runtime $rtmountpoint |
|
if {[file exists $rtmountpoint]} { |
|
#copy from mounted runtime's vfs to the filesystem vfs |
|
merge_over $rtmountpoint $targetvfs |
|
} |
|
merge_over $sourcefolder/vfs/_vfscommon.vfs $targetvfs |
|
} |
|
} |
|
kit { |
|
#for a kit, we don't need to extract the existing vfs from the runtime. |
|
# - the sdx merge process can merge our .vfs folder with the existing contents. |
|
puts stdout "building $vfsname.new with sdx.. vfsdir:$vfstail cwd: [pwd]" |
|
if {[file exists $sourcefolder/vfs/_vfscommon.vfs]} { |
|
file copy $sourcefolder/vfs/_vfscommon.vfs $targetvfs |
|
} else { |
|
file mkdir $targetvfs |
|
} |
|
} |
|
} |
|
|
|
|
|
set sourcevfs [file join $sourcefolder vfs $vfstail] |
|
merge_over $sourcevfs $targetvfs |
|
|
|
#set wrapvfs $sourcefolder/$vfs |
|
|
|
set wrapvfs $targetvfs |
|
switch -- $kit_type { |
|
zip { |
|
#WARNING - 2024-10-08 - zipfs mkimg based exezips are not editable with 7z |
|
# (central directory offset has been 'adjusted' to be file relative) |
|
#This makes finding the split between prefixed exe and zip-data harder for Tcl scripts |
|
#- although zipfs mkimg does it in a somewhat wonky way. |
|
#tclZipfs.c as at 2024 assumes first file header in the CDR points to first local file header and assumes that is the top of the zipdata. |
|
#This is only *mostly* true. order of entries or completeness is not guaranteed. |
|
#e.g topmost file data in zip may not be pointed to if deleted by certain tools. |
|
#for files created by zipfs mkimg and not externally edited - it shouldn't be an issue though. |
|
|
|
if {$rtname eq "-"} { |
|
#todo - just make a zip? |
|
error "runtime name of - unsupported for zip - (todo)" |
|
} |
|
if {[catch { |
|
if {[dict exists $runtime_caps $rtname]} { |
|
if {[dict get $runtime_caps $rtname exitcode] == 0} { |
|
if {![dict get $runtime_caps $rtname has_zipfs]} { |
|
error "runtime $rtname doesn't have zipfs capability" |
|
} |
|
} else { |
|
#could be runtime for another platform |
|
puts stderr "RUNTIME capabilities unknown. Unsure if zip supported. trying anyway.." |
|
} |
|
} |
|
#note - as at 2024-08 - there is some discussion about the interface to mkimg - it is considered unstable (may change to -option value syntax) |
|
puts stderr "calling: tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs \"\" $raw_runtime" |
|
tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $raw_runtime |
|
} result ]} { |
|
set failmsg "zipfs mkimg failed with msg: $result" |
|
puts stderr "tcl::zipfs::mkimg $targetkit failed" |
|
lappend failed_kits [list kit $targetkit reason $failmsg] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} else { |
|
puts stdout "ok - finished tcl::zipfs::mkimg" |
|
set separator [string repeat = 40] |
|
puts stdout $separator |
|
puts stdout $result |
|
puts stdout $separator |
|
} |
|
} |
|
zipcat { |
|
#simple catenated runtime + zip - we need an exe runtime with no zipfs attached.. |
|
if {$rtname eq "-"} { |
|
#todo - just make a zip? |
|
error "runtime name of - unsupported for zip - (todo)" |
|
} |
|
if {[catch { |
|
if {[dict exists $runtime_caps $rtname]} { |
|
if {[dict get $runtime_caps $rtname exitcode] == 0} { |
|
if {![dict get $runtime_caps $rtname has_zipfs]} { |
|
error "runtime $rtname doesn't have zipfs capability" |
|
} |
|
} else { |
|
#could be runtime for another platform |
|
puts stderr "RUNTIME capabilities unknown. Unsure if zip supported. trying anyway.." |
|
} |
|
} |
|
|
|
#'archive' based zip offsets - editable in 7z,peazip |
|
file copy $raw_runtime $buildfolder/$vfsname.new |
|
file delete $buildfolder/$vfsname.zip |
|
|
|
if {[info commands ::tcl::zipfs] ne ""} { |
|
puts stdout "tcl::zipfs::mkzip $buildfolder/$vfsname.zip $wrapvfs $wrapvfs" |
|
::tcl::zipfs::mkzip $buildfolder/$vfsname.zip $wrapvfs $wrapvfs |
|
} else { |
|
puts stdout "punk::zip::mkzip -directory $wrapvfs -base $wrapvfs $buildfolder/$vfsname.zip *" |
|
package require punk::zip |
|
punk::zip::mkzip -directory $wrapvfs -base $wrapvfs $buildfolder/$vfsname.zip * |
|
} |
|
|
|
|
|
puts stderr "concatenating executable to zip.." |
|
set fdout [open $buildfolder/$vfsname.new a] |
|
chan conf $fdout -translation binary |
|
puts stderr "runtime bytes: [tell $fdout]" |
|
set fdzip [open $buildfolder/$vfsname.zip r] |
|
chan conf $fdzip -translation binary |
|
set zipbytes [fcopy $fdzip $fdout] |
|
close $fdzip |
|
puts stderr "zip bytes: $zipbytes" |
|
puts stderr "exezip bytes: [tell $fdout]" |
|
close $fdout |
|
} result ]} { |
|
set failmsg "creating zipcat image failed with msg: $result" |
|
puts stderr "creating image (zipcat) $targetkit failed" |
|
lappend failed_kits [list kit $targetkit reason $failmsg] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} else { |
|
puts stdout "ok - finished zipcat image" |
|
set separator [string repeat = 40] |
|
puts stdout $separator |
|
puts stdout $result |
|
puts stdout $separator |
|
} |
|
|
|
|
|
} |
|
cookit - cookfs { |
|
if {$rtmountpoint eq ""} { |
|
lappend failed_kits [list kit $targetkit reason mount_failed] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} else { |
|
if {[catch { |
|
#we still have the $building_runtime mounted |
|
if {[catch { |
|
merge_over $targetvfs $rtmountpoint |
|
} errM]} { |
|
puts stderr "$kit_type 'merge_over $targetvfs $rtmountpoint' failed\n$errM" |
|
error $errM |
|
} |
|
if {[catch { |
|
cookfs::Unmount $rtmountpoint |
|
} errM]} { |
|
puts stderr "$kit_type 'cookfs::Unmount $rtmountpoint' failed\n$errM" |
|
error $errM |
|
} |
|
|
|
#copy the version that is mounted in this runtime to vfsname.new |
|
if {[catch { |
|
file copy -force $building_runtime $buildfolder/$vfsname.new |
|
} errM]} { |
|
puts stderr "$kit_type 'file copy -force $building_runtime $buildfolder/$vfsname.new' failed\n$errM" |
|
error $errM |
|
} |
|
} result]} { |
|
puts stderr "Writing vfs data and opying cookfs file $building_runtime to $buildfolder/$vfsname.new failed\n $result" |
|
lappend failed_kits [list kit $targetkit reason copy_failed] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} else { |
|
puts stdout "ok - finished $kit_type" |
|
set separator [string repeat = 40] |
|
puts stdout $separator |
|
puts stdout $result |
|
puts stdout $separator |
|
} |
|
} |
|
} |
|
kit { |
|
if {!$has_sdx} { |
|
puts stderr "no sdx available to wrap $targetkit" |
|
lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} else { |
|
set verbose "" |
|
#set verbose "-verbose" |
|
|
|
if {[catch { |
|
if {$rtname ne "-"} { |
|
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $building_runtime {*}$verbose |
|
} else { |
|
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs {*}$verbose |
|
} |
|
} result]} { |
|
if {$rtname ne "-"} { |
|
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname {*}$verbose failed with msg: $result" |
|
} else { |
|
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs {*}$verbose failed with msg: $result" |
|
} |
|
puts stderr "sdx wrap $targetkit failed" |
|
lappend failed_kits [list kit $targetkit reason $sdxmsg] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} else { |
|
puts stdout "ok - finished sdx" |
|
set separator [string repeat = 40] |
|
puts stdout $separator |
|
puts stdout $result |
|
puts stdout $separator |
|
} |
|
} |
|
} |
|
} |
|
|
|
|
|
if {![file exists $buildfolder/$vfsname.new]} { |
|
puts stderr "|err> make.tcl build didn't seem to produce output at $buildfolder/$vfsname.new" |
|
lappend failed_kits [list kit $targetkit reason "build failed to produce output at $buildfolder/$vfsname.new"] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} |
|
|
|
# -- --- --- |
|
if {$::tcl_platform(platform) eq "windows"} { |
|
set pscmd "tasklist" |
|
} else { |
|
set pscmd "ps" |
|
} |
|
|
|
#killing process doesn't apply to .kit build |
|
if {$rtname ne "-"} { |
|
if {![catch { |
|
exec $pscmd | grep $targetkit |
|
} still_running]} { |
|
set still_running_lines [split [string trim $still_running] \n] |
|
puts stdout "found ([llength $still_running_lines]) $targetkit instances still running\n" |
|
set count_killed 0 |
|
set num_to_kill [llength $still_running_lines] |
|
foreach ln [split $still_running \n] { |
|
puts stdout " $ln" |
|
|
|
if {$::tcl_platform(platform) eq "windows"} { |
|
set pid [lindex $ln 1] |
|
if {$forcekill} { |
|
set killcmd [list taskkill /F /PID $pid] |
|
} else { |
|
set killcmd [list taskkill /PID $pid] |
|
} |
|
} else { |
|
set pid [lindex $ln 0] |
|
#review! |
|
if {$forcekill} { |
|
set killcmd [list kill -9 $pid] |
|
} else { |
|
set killcmd [list kill $pid] |
|
} |
|
} |
|
puts stdout " pid: $pid (attempting to kill now using '$killcmd')" |
|
if {[catch { |
|
exec {*}$killcmd |
|
} errMsg]} { |
|
puts stderr "$killcmd returned an error:" |
|
puts stderr $errMsg |
|
if {!$forcekill} { |
|
puts stderr "(try '[info script] -k' option to force kill)" |
|
} |
|
#avoid exiting if the kill failure was because the task has already exited |
|
#review - *no running instance* works with windows taskkill - "*No such process*" works with kill -9 on FreeBSD and linux - other platforms? |
|
if {![string match "*no running instance*" $errMsg] && ![string match "*No such process*" $errMsg]} { |
|
lappend failed_kits [list kit $targetkit reason "could not kill running process for $targetkit (using '$killcmd')"] |
|
continue |
|
} |
|
} else { |
|
puts stderr "$killcmd ran without error" |
|
incr count_killed |
|
} |
|
} |
|
if {$count_killed < $num_to_kill} { |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} |
|
|
|
puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" |
|
after 1000 |
|
} else { |
|
puts stderr "Ok.. no running '$targetkit' processes found" |
|
} |
|
} |
|
|
|
if {[file exists $buildfolder/$targetkit]} { |
|
puts stderr "deleting existing $buildfolder/$targetkit" |
|
if {[catch { |
|
file delete $buildfolder/$targetkit |
|
} msg]} { |
|
puts stderr "Failed to delete $buildfolder/$targetkit" |
|
lappend failed_kits [list kit $targetkit reason "could not delete buildfolder kit at $buildfolder/$targetkit"] |
|
$vfs_event targetset_end FAILED |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
continue |
|
} |
|
} |
|
|
|
#WINDOWS filesystem 'tunnelling' (file replacement within 15secs) could cause targetkit to copy ctime & shortname metadata from previous file! |
|
#This is probably harmless - but worth being aware of. |
|
file rename $buildfolder/$vfsname.new $buildfolder/$targetkit |
|
# -- --- --- --- --- --- |
|
$vfs_event targetset_end OK |
|
|
|
} else { |
|
set skipped_vfs_build 1 |
|
puts stderr "." |
|
puts stdout "Skipping build for vfs $vfstail with runtime $rtname - no change detected" |
|
lappend skipped_kits [list kit $targetkit reason "no change detected"] |
|
$vfs_event targetset_end SKIPPED |
|
} |
|
$vfs_event destroy |
|
$vfs_installer destroy |
|
|
|
after 200 |
|
set deployment_folder [file dirname $sourcefolder]/bin |
|
file mkdir $deployment_folder |
|
|
|
# -- ---------- |
|
set bin_installer [punkcheck::installtrack new "make.tcl" $deployment_folder/.punkcheck] |
|
$bin_installer set_source_target $buildfolder $deployment_folder |
|
set bin_event [$bin_installer start_event {-make-step final_kit_install}] |
|
$bin_event targetset_init INSTALL $deployment_folder/$targetkit |
|
#todo - move final deployment step outside of the build vfs loop? (final deployment can fail and then isn't rerun even though _build and deployed versions differ, unless .vfs modified again) |
|
#set last_completion [$bin_event targetset_last_complete] |
|
|
|
$bin_event targetset_addsource $deployment_folder/$targetkit ;#add target as a source of metadata for change detection |
|
$bin_event targetset_addsource $buildfolder/$targetkit |
|
$bin_event targetset_started |
|
# -- ---------- |
|
|
|
set changed_unchanged [$bin_event targetset_source_changes] |
|
set built_or_installed_kit_changed [expr {[llength [dict get $changed_unchanged changed]] || [llength [$bin_event get_targets_exist]] < [llength [$bin_event get_targets]]}] |
|
if {$built_or_installed_kit_changed} { |
|
|
|
if {[file exists $deployment_folder/$targetkit]} { |
|
puts stderr "built or deployed kit changed - deleting existing deployed at $deployment_folder/$targetkit" |
|
if {[catch { |
|
file delete $deployment_folder/$targetkit |
|
} errMsg]} { |
|
puts stderr "deletion of deployed version at $deployment_folder/$targetkit failed: $errMsg" |
|
lappend failed_kits [list kit $targetkit reason "could not delete target binary at $deployment_folder/$targetkit"] |
|
$bin_event targetset_end FAILED -note "could not delete" |
|
$bin_event destroy |
|
$bin_installer destroy |
|
continue |
|
} |
|
} |
|
|
|
puts stdout "copying.." |
|
puts stdout "$buildfolder/$targetkit" |
|
puts stdout "to:" |
|
puts stdout "$deployment_folder/$targetkit" |
|
after 300 |
|
file copy $buildfolder/$targetkit $deployment_folder/$targetkit |
|
lappend installed_kits $targetkit |
|
# -- ---------- |
|
$bin_event targetset_end OK |
|
# -- ---------- |
|
} else { |
|
set skipped_kit_install 1 |
|
puts stderr "." |
|
puts stdout "Skipping kit install for $targetkit with vfs $vfstail runtime $rtname - no change detected" |
|
lappend skipped_kit_installs [list kit $targetkit reason "no change detected"] |
|
$bin_event targetset_end SKIPPED |
|
} |
|
$bin_event destroy |
|
$bin_installer destroy |
|
|
|
|
|
|
|
} ;#end foreach targetkit |
|
} ;#end foreach rtname in runtimes |
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
|
} |
|
cd $startdir |
|
if {[llength $installed_kits]} { |
|
puts stdout "INSTALLED KITS: ([llength $installed_kits])" |
|
punk::lib::showdict -channel stdout -roottype list $installed_kits |
|
} |
|
if {[llength $failed_kits]} { |
|
puts stderr "FAILED KITS:([llength $failed_kits])" |
|
punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@* |
|
#puts stderr [join $failed_kits \n] |
|
} |
|
set had_kits [expr {[llength $installed_kits] || [llength $failed_kits] || [llength $skipped_kits]}] |
|
if {$had_kits} { |
|
puts stdout " module builds and kit/zipkit builds processed (vfs config: src/runtime/mapvfs.config)" |
|
puts stdout " - use 'make.tcl modules' to build modules without scanning/building the vfs folders into executable kits/zipkits" |
|
puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into the base vfs folder <projectdir>/src/vfs/_vfscommon.vfs" |
|
puts stdout " - Note that without the vfscommonupdate step, 'make tcl vfs' (included in 'make tcl project') will build vfs based executables" |
|
puts stdout " that include your current custom vfs folders in src/vfs, but with a _vfscommon.vfs that doesn't have the latest built modules" |
|
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'" |
|
} else { |
|
puts stdout " module builds processed" |
|
puts stdout "" |
|
puts stdout " If kit/zipkit based executables required - create src/vfs/<somename>.vfs folders containing lib,modules,modules_tcl9 etc folders" |
|
puts stdout " Also ensure appropriate executables exist in src/runtime along with src/runtime/mapvfs.config" |
|
} |
|
puts stdout "-done-" |
|
exit 0 |
|
|
|
|
|
|