From cc3380a70e36efb6919d0597e24569406559e563 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 3 Oct 2024 05:35:51 +1000 Subject: [PATCH] project_layouts sync --- .../custom/_project/punk.basic/src/make.tcl | 1299 +++++++++++++++-- .../src/bootsupport/modules/fauxlink-0.1.0.tm | 10 + .../modules/include_modules.config | 1 - .../src/bootsupport/modules/punk-0.1.tm | 39 +- .../bootsupport/modules/punk/args-0.1.0.tm | 145 +- .../bootsupport/modules/punk/config-0.1.tm | 5 +- .../bootsupport/modules/punk/console-0.1.1.tm | 39 +- .../src/bootsupport/modules/punk/du-0.1.0.tm | 160 +- .../modules/punk/fileline-0.1.0.tm | 1 - .../src/bootsupport/modules/punk/lib-0.1.1.tm | 171 ++- .../bootsupport/modules/punk/mix/base-0.1.tm | 25 +- .../modules/punk/mix/commandset/doc-0.1.0.tm | 7 +- .../modules/punk/mix/util-0.1.0.tm | 2 + .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 52 +- .../modules/punk/packagepreference-0.1.0.tm | 26 +- .../modules/punk/repl/codethread-0.1.0.tm | 24 +- .../bootsupport/modules/punk/repo-0.1.1.tm | 5 + .../bootsupport/modules/textblock-0.1.1.tm | 10 +- .../src/bootsupport/modules/textutil-0.9.tm | 2 +- .../_project/punk.project-0.1/src/make.tcl | 1299 +++++++++++++++-- .../src/bootsupport/modules/fauxlink-0.1.0.tm | 10 + .../modules/include_modules.config | 1 - .../src/bootsupport/modules/punk-0.1.tm | 39 +- .../bootsupport/modules/punk/args-0.1.0.tm | 145 +- .../bootsupport/modules/punk/config-0.1.tm | 5 +- .../bootsupport/modules/punk/console-0.1.1.tm | 39 +- .../src/bootsupport/modules/punk/du-0.1.0.tm | 160 +- .../modules/punk/fileline-0.1.0.tm | 1 - .../src/bootsupport/modules/punk/lib-0.1.1.tm | 171 ++- .../bootsupport/modules/punk/mix/base-0.1.tm | 25 +- .../modules/punk/mix/commandset/doc-0.1.0.tm | 7 +- .../modules/punk/mix/util-0.1.0.tm | 2 + .../bootsupport/modules/punk/nav/fs-0.1.0.tm | 52 +- .../modules/punk/packagepreference-0.1.0.tm | 26 +- .../modules/punk/repl/codethread-0.1.0.tm | 24 +- .../bootsupport/modules/punk/repo-0.1.1.tm | 5 + .../bootsupport/modules/textblock-0.1.1.tm | 10 +- .../src/bootsupport/modules/textutil-0.9.tm | 2 +- .../_project/punk.shell-0.1/src/make.tcl | 1299 +++++++++++++++-- 39 files changed, 4762 insertions(+), 583 deletions(-) diff --git a/src/project_layouts/custom/_project/punk.basic/src/make.tcl b/src/project_layouts/custom/_project/punk.basic/src/make.tcl index 24206ba7..f6ade4c4 100644 --- a/src/project_layouts/custom/_project/punk.basic/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.basic/src/make.tcl @@ -1,13 +1,19 @@ # tcl # -#make any tclkits and modules in src and place them and associated data files/scripts in the parent folder of src. +# punkboot - make any tclkits and modules in /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. - set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" puts $hashline -puts " punkshell make script " +puts " Punk Boot" puts $hashline\n -namespace eval ::punkmake { + +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] @@ -15,6 +21,139 @@ namespace eval ::punkmake { variable help_flags [list -help --help /?] variable known_commands [list project modules 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 @@ -23,30 +162,96 @@ if {"::try" ni [info commands ::try]} { #------------------------------------------------------------------------------ #Module loading from src/bootsupport or [pwd]/modules if pwd is a 'src' folder #------------------------------------------------------------------------------ -#If the there is a folder under the current directory /src/bootsupport/modules which contains .tm files +#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 make script +# 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]]} { - set bootsupport_mod [file join $startdir src bootsupport modules] - set bootsupport_lib [file join $startdir src bootsupport lib] + lappend bootsupport_module_paths [file join $startdir src bootsupport modules] + lappend bootsupport_library_paths [file join $startdir src bootsupport lib] } else { - set bootsupport_mod [file join $startdir bootsupport modules] - set bootsupport_lib [file join $startdir bootsupport lib] + lappend bootsupport_module_paths [file join $startdir bootsupport modules] + lappend bootsupport_library_paths [file join $startdir bootsupport lib] +} +set bootsupport_paths_exist 0 +foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] { + if {[file exists $p]} { + set bootsupport_paths_exist 1 ;#at least one exists + break + } } +# ------------------------------------------------------------------------------------- +# ------------------------------------------------------------------------------------- +set sourcesupport_module_paths [list] +set sourcesupport_library_paths [list] +set sourcesupport_paths_exist 0 +#we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir. +#The /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] { + if {[file exists $p]} { + lappend sourcesupport_module_paths $p + } + } + # -- -- -- + foreach p [list $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 /modules are the very modules we are building - and may be in a broken state, which make.tcl then can't fix. - if {[file tail $startdir] eq "src"} { - if {[file exists $startdir/modules]} { - #launch from .' (minbounded) as .- 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]\ + overtype [list version "1.6.5-"]\ + punkcheck [list]\ + 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}]\ +] + # ** *** *** *** *** *** *** *** *** *** *** *** -#*temporarily* hijack package command +# 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. # ** *** *** *** *** *** *** *** *** *** *** *** -try { - rename ::package ::punkmake::package_temp_aside - proc ::package {args} { - if {[lindex $args 0] eq "require"} { - lappend ::punkmake::pkg_requirements [lindex $args 1] +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 .. + 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] } } - package require punk::mix - package require punk::repo - package require punk::ansi - package require overtype -} finally { - catch {rename ::package ""} - catch {rename ::punkmake::package_temp_aside ::package} + + #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 } -# ** *** *** *** *** *** *** *** *** *** *** *** -foreach pkg $::punkmake::pkg_requirements { - if {[catch {package require $pkg} errM]} { - puts stderr "missing pkg: $pkg" - lappend ::punkmake::pkg_missing $pkg - } else { - lappend ::punkmake::pkg_loaded $pkg + + +#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)} ... -proc punkmake_gethelp {args} { set scriptname [file tail [info script]] append h "Usage:" \n append h "" \n @@ -138,12 +1028,15 @@ proc punkmake_gethelp {args} { 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 processes running as the executable being built (if applicable)" \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 /modules /lib etc." \n \n append h " $scriptname modules" \n - append h " - build modules from src/modules etc without scanning src/runtime and src/vfs folders to build kit/zipkit executables" \n \n + append h " - build modules from src/modules src/vendormodules etc to their corresponding locations under " \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//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 /modules /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 @@ -154,24 +1047,51 @@ proc punkmake_gethelp {args} { append h " $scriptname info" \n append h " - show the name and base folder of the project to be built" \n append h "" \n - if {[llength $::punkmake::pkg_missing]} { - append h "* ** NOTE ** ***" \n - append h " punkmake has detected that the following packages could not be loaded:" \n - append h " " [join $::punkmake::pkg_missing "\n "] \n - append h "* ** *** *** ***" \n - append h " These packages are required for punk make to function" \n \n - append h "* ** *** *** ***" \n\n - append h "Successfully Loaded packages:" \n - append h " " [join $::punkmake::pkg_loaded "\n "] \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 $::punkmake::help_flags { + foreach h $::punkboot::help_flags { if {[lsearch $scriptargs $h] >= 0} { set do_help 1 break @@ -183,23 +1103,32 @@ foreach a $scriptargs { if {![string match -* $a]} { lappend commands_found $a } else { - if {$a ni $::punkmake::non_help_flags} { + 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 $::punkmake::known_commands} { +} 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 stderr [punkmake_gethelp] + 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 ::punkmake::command [lindex $commands_found 0] +set ::punkboot::command [lindex $commands_found 0] if {[lsearch $::argv -k] >= 0} { @@ -210,7 +1139,7 @@ if {[lsearch $::argv -k] >= 0} { #puts stdout "::argv $::argv" # ---------------------------------------- -set scriptfolder $::punkmake::scriptfolder +set scriptfolder $::punkboot::scriptfolder @@ -218,21 +1147,25 @@ set scriptfolder $::punkmake::scriptfolder #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 "punkmake 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 "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 punkmake script operating in project space that is not under version control" + puts stderr "WARNING punkboot script operating in project space that is not under version control" } } else { } set sourcefolder $projectroot/src -if {$::punkmake::command eq "check"} { +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]} { @@ -249,25 +1182,87 @@ if {$::punkmake::command eq "check"} { 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] - puts stdout "punk::mix::base version $v\n[package ifneeded punk::mix::base $v]" - exit 0 -} + #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} { - #restore module paths and auto_path in addition to the bootsupport ones 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] + #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 {$::punkmake::command eq "info"} { +if {$::punkboot::command eq "info"} { puts stdout "- -- --- --- --- --- --- --- --- --- -- -" puts stdout "- -- info -- -" puts stdout "- -- --- --- --- --- --- --- --- --- -- -" @@ -318,16 +1313,23 @@ if {$::punkmake::command eq "info"} { exit 0 } -if {$::punkmake::command eq "shell"} { + + + +if {$::punkboot::command eq "shell"} { package require punk package require punk::repl - puts stderr "make shell not fully implemented - dropping into ordinary punk shell" + 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 {$::punkmake::command eq "vfscommonupdate"} { +if {$::punkboot::command eq "vfscommonupdate"} { puts "projectroot: $projectroot" puts "script: [info script]" puts stdout "Updating vfs/_vfscommon" @@ -362,7 +1364,7 @@ if {$::punkmake::command eq "vfscommonupdate"} { ::exit 0 } -if {$::punkmake::command eq "vendorupdate"} { +if {$::punkboot::command eq "vendorupdate"} { puts "projectroot: $projectroot" puts "script: [info script]" #puts "-- [tcl::tm::list] --" @@ -479,7 +1481,7 @@ if {$::punkmake::command eq "vendorupdate"} { ::exit 0 } -if {$::punkmake::command eq "bootsupport"} { +if {$::punkboot::command eq "bootsupport"} { puts "projectroot: $projectroot" puts "script: [info script]" #puts "-- [tcl::tm::list] --" @@ -635,8 +1637,8 @@ if {$::punkmake::command eq "bootsupport"} { -if {$::punkmake::command ni {project modules}} { - puts stderr "Command $::punkmake::command not implemented - aborting." +if {$::punkboot::command ni {project modules}} { + puts stderr "Command $::punkboot::command not implemented - aborting." flush stderr after 100 exit 1 @@ -874,7 +1876,7 @@ if {[punk::repo::is_fossil_root $projectroot]} { $installer destroy } -if {$::punkmake::command ne "project"} { +if {$::punkboot::command ne "project"} { #command = modules puts stdout "vfs folders not checked" puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into base vfs folder" @@ -1027,6 +2029,13 @@ foreach runtime [dict keys $runtime_vfs_map] { 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 } @@ -1092,7 +2101,7 @@ foreach runtimefile $runtimes { # -- --- --- --- --- --- puts stdout "Copying runtime from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" if {[catch { - file copy -force $rtfolder/$runtimefile $buildfolder/build_$runtimefile + 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 @@ -1101,7 +2110,7 @@ foreach runtimefile $runtimes { } # -- --- --- --- --- --- } else { - puts stderr "." + puts stderr "unchanged: $runtimefile" $event targetset_end SKIPPED } $event end @@ -1119,7 +2128,8 @@ proc ::make_file_traversal_error {args} { } proc merge_over {sourcedir targetdir} { package require fileutil - package require fileutil::traverse + set ver [package require fileutil::traverse] + puts stdout "using fileutil::traverse $ver\n[package ifneeded fileutil::traverse $ver]" package require control if {![file exists $sourcedir]} { @@ -1150,6 +2160,11 @@ proc merge_over {sourcedir targetdir} { if {![file exists $target]} { #puts stdout "-- mkdir $target" puts stdout "$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 { @@ -1293,11 +2308,13 @@ foreach vfstail $vfs_tails { $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon $vfs_event targetset_addsource $sourcefolder/vfs/$vfstail if {$rtname ne "-"} { - $vfs_event targetset_addsource $buildfolder/build_$runtime_fullname ;#working copy of runtime executable + set building_runtime $buildfolder/build_$runtime_fullname ;#working copy of runtime executable + $vfs_event targetset_addsource $building_runtime + } else { + set building_runtime "-" ;#REVIEW } # -- ---------- - set rtmountpoint //zipfs:/rtmounts/$runtime_fullname 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]]}] @@ -1319,18 +2336,31 @@ foreach vfstail $vfs_tails { set targetvfs $buildfolder/buildvfs_$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 { #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 $buildfolder/build_$runtime_fullname rtmounts/$runtime_fullname + tcl::zipfs::mount $building_runtime rtmounts/$runtime_fullname } errM]} { - tcl::zipfs::mount rtmounts/$runtime_fullname $buildfolder/build_$runtime_fullname + 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?" + } } } @@ -1341,6 +2371,34 @@ foreach vfstail $vfs_tails { merge_over $sourcefolder/vfs/_vfscommon $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 /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 $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. @@ -1358,9 +2416,14 @@ foreach vfstail $vfs_tails { merge_over $sourcevfs $targetvfs #set wrapvfs $sourcefolder/$vfs + set wrapvfs $targetvfs switch -- $kit_type { zip { + 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} { @@ -1373,8 +2436,8 @@ foreach vfstail $vfs_tails { } } #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 \"\" $buildfolder/build_$runtime_fullname" - tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $buildfolder/build_$runtime_fullname + puts stderr "calling: tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs \"\" $building_runtime" + tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $building_runtime } result ]} { set failmsg "zipfs mkimg failed with msg: $result" puts stderr "tcl::zipfs::mkimg $targetkit failed" @@ -1391,6 +2454,52 @@ foreach vfstail $vfs_tails { 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" @@ -1402,7 +2511,7 @@ foreach vfstail $vfs_tails { } else { if {[catch { if {$rtname ne "-"} { - exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose + exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $building_runtime -verbose } else { exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose } @@ -1560,7 +2669,7 @@ foreach vfstail $vfs_tails { if {$built_or_installed_kit_changed} { if {[file exists $deployment_folder/$targetkit]} { - puts stderr "deleting existing deployed at $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]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm index 8424ce07..d0fdc8ec 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm @@ -66,6 +66,16 @@ # "my-program-files#++server+c+Program%20Files.fxlnk" #If we needed the old-style literal %20 it would become # "my-program-files#++server+c+Program%2520Files.fxlnk" +# +# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) +# e.g +# pfiles#file%3a++++localhost+c+Program%2520files +# The browser will work with literal spaces too though - so it could just as well be: +# pfiles#file%3a++++localhost+c+Program%20files +#windows may default to using explorer.exe instead of a browser for file:// urls though +#and explorer doesn't want the literal %20. It probably depends what API the file:// url is to be passed to? +#in a .url shortcut either literal space or %20 will work ie %xx values are decoded + #*** !doctools diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config index 922ff786..17b5192a 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/include_modules.config @@ -14,7 +14,6 @@ set bootsupport_modules [list\ src/vendormodules debug\ src/vendormodules dictutils\ src/vendormodules fauxlink\ - src/vendormodules fileutil\ src/vendormodules http\ src/vendormodules md5\ src/vendormodules metaface\ diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm index 2d6e61da..4bd8aae0 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm @@ -213,6 +213,13 @@ namespace eval punk { proc objclone {obj} { append obj2 $obj {} } + proc set_clone {varname obj} { + #maintenance: also punk::lib::set_clone + #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + interp alias "" strlen "" ::punk::strlen interp alias "" str_len "" ::punk::strlen interp alias "" objclone "" ::punk::objclone @@ -2121,8 +2128,8 @@ namespace eval punk { set level_script_complete 1 } {@V\*@*} - {@v\*@*} { - #dict value glob - return values - set active_key_type "dict" + #dict value glob - return values + set active_key_type dict set keyglob [string range $index 4 end] append script [tstr -return string -allowcommands { if {[catch {dict size $leveldata}]} { @@ -2132,7 +2139,7 @@ namespace eval punk { if {$get_not} { lappend INDEX_OPERATIONS globvalue-get-values-not append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operation: globvalue-get-values-not" + # set active_key_type "dict" ;# index_operation: globvalue-get-values-not set assigned [list] tcl::dict::for {k v} $leveldata { if {![string match $v]} { @@ -2144,7 +2151,7 @@ namespace eval punk { } else { lappend INDEX_OPERATIONS globvalue-get-values append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operation: globvalue-get-value + # set active_key_type "dict" ;#index_operation: globvalue-get-value set assigned [dict values $leveldata ] }] } @@ -2166,7 +2173,7 @@ namespace eval punk { } else { lappend INDEX_OPERATIONS globkeyvalue-get-pairs append script \n [string map [list $keyvalglob] { - # set active_key_type "dict" index_operation: globkeyvalue-get-pairs-not" + # set active_key_type "dict" ;# index_operation: globkeyvalue-get-pairs-not set assigned [dict create] tcl::dict::for {k v} $leveldata { if {[string match $k] || [string match $v]} { @@ -4952,17 +4959,14 @@ namespace eval punk { } else { #tags ? #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 - if 0 { - - - + if {false} { #set s [list uplevel 1 [concat $rhs $segment_members_filled]] if {![info exists pscript]} { upvar ::_pipescript pscript } if {![info exists pscript]} { #set pscript $s - set pscript [funcl::o_of_n 1 $segment_members] + set pscript [funcl::o_of_n 1 $segment_members] } else { #set pscript [string map [list

$pscript] {uplevel 1 [concat $rhs $segment_members_filled [

]]}] #set snew "set pipe_$i \[uplevel 1 \[list $rhs $segment_members_filled " @@ -4972,6 +4976,7 @@ namespace eval punk { } } + set cmdlist_result [uplevel 1 $segment_members_filled] #set d [_multi_bind_result $returnvarspec [punk::K $segment_members_filled [unset segment_members_filled]]] set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result]] 0 ]] @@ -7321,16 +7326,22 @@ namespace eval punk { if {$topic in [list tcl]} { - if {[punk::lib::system::has_script_var_bug]} { - append warningblock \n "minor warning: punk::lib::system::has_script_var_bug returned true! (string rep for list variable in script generated when script changed)" + if {[punk::lib::system::has_tclbug_script_var]} { + append warningblock \n "minor warning: punk::lib::system::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" } - if {[punk::lib::system::has_safeinterp_compile_bug]} { + if {[punk::lib::system::has_tclbug_safeinterp_compile]} { set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::system::has_safeinterp_compile_bug returned true!" \n + append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_safeinterp returned true!" \n append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/1095bf7f75" append warningblock [a] } + if {[punk::lib::system::has_tclbug_list_quoting_emptyjoin]} { + set indent " " + append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_list_quoting returned true!" \n + append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n + append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/e38dce74e2" + } } set text "" diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm index 5e270ac8..c8a6ec84 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/args-0.1.0.tm @@ -201,6 +201,7 @@ #[para] packages used by punk::args #[list_begin itemized] package require Tcl 8.6- +#optional? punk::trie #*** !doctools #[item] [package {Tcl 8.6-}] @@ -293,6 +294,7 @@ tcl::namespace::eval punk::args { -validate_without_ansi 0\ -strip_ansi 0\ -nocase 0\ + -choiceprefix 1\ -multiple 0\ ] set valspec_defaults [tcl::dict::create\ @@ -301,8 +303,12 @@ tcl::namespace::eval punk::args { -allow_ansi 1\ -validate_without_ansi 0\ -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ -multiple 0\ ] + #we need a -choiceprefix default even though it often doesn't apply so we can look it up to display in Help if there are -choices + #default to 1 for convenience #checks with no default #-minlen -maxlen -range @@ -415,11 +421,11 @@ tcl::namespace::eval punk::args { -anyopts { set opt_any $v } - -minlen - -maxlen - -range - -choices - -choicelabels { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix { #review - only apply to certain types? tcl::dict::set optspec_defaults $k $v } - -nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels { + -nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels - -nocase { if {$v} { tcl::dict::unset optspec_defaults $k } @@ -459,7 +465,7 @@ tcl::namespace::eval punk::args { tcl::dict::set optspec_defaults $k $v } default { - set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels\ + set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ } @@ -479,7 +485,7 @@ tcl::namespace::eval punk::args { -maxvalues { set val_max $v } - -minlen - -maxlen - -range - -choices - -choicelabels { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -nocase { #review - only apply to certain types? tcl::dict::set valspec_defaults $k $v } @@ -520,7 +526,7 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minlen -maxlen -range -choices -choicelabels\ + -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ } @@ -596,12 +602,12 @@ tcl::namespace::eval punk::args { } } } - -default - -solo - -range - -choices - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { + -default - -solo - -range - -choices - -choiceprefix - -choicelabels - -choiceprefix - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { #review -solo 1 vs -type none ? tcl::dict::set spec_merged $spec $specval } default { - set known_argspecs [list -default -type -range -choices -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help] + set known_argspecs [list -default -type -range -choices -choiceprefix -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help] error "punk::args::get_dict - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" } } @@ -752,7 +758,28 @@ tcl::namespace::eval punk::args { #set greencheck [a+ web-limegreen]\u2713[a] set greencheck [a+ brightgreen]\u2713[a] - foreach arg [dict get $spec_dict opt_names] { + if {![catch {package require punk::trie}]} { + set opt_names_display [list] + set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $spec_dict opt_names] { + set id [dict get $idents $c] + if {$id eq $c} { + lappend opt_names_display $M$c$RST + } else { + set idlen [string length $id] + lappend opt_names_display "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" + } + } + } else { + set opt_names_display [dict get $spec_dict opt_names] + } + + + foreach argshow $opt_names_display arg [dict get $spec_dict opt_names] { set arginfo [dict get $spec_dict arg_info $arg] if {[dict exists $arginfo -default]} { #set default $c_default[dict get $arginfo -default] @@ -763,14 +790,47 @@ tcl::namespace::eval punk::args { set help [punk::lib::dict_getdef $arginfo -help ""] if {[dict exists $arginfo -choices]} { if {$help ne ""} {append help \n} - append help "Choices: [dict get $arginfo -choices]" + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + } else { + set casemsg " (case sensitive)" + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + append help "Choices$prefixmsg$casemsg" + if {[catch {package require punk::trie}]} { + append help "\n " [join [dict get $arginfo -choices] "\n "] + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $arginfo -choices] { + set id [dict get $idents $c] + if {$id eq $c} { + append help "\n " "$M$c$RST" + } else { + set idlen [string length $id] + append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" + } + } + } errM]} { + puts stderr "prefix marking failed\n$errM" + append help "\n " [join [dict get $arginfo -choices] "\n "] + } + } } if {[punk::lib::dict_getdef $arginfo -multiple 0]} { set multiple $greencheck } else { set multiple "" } - $t add_row [list $arg [dict get $arginfo -type] $default $multiple $help] + $t add_row [list $argshow [dict get $arginfo -type] $default $multiple $help] if {$arg eq $badarg} { $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg } @@ -785,7 +845,40 @@ tcl::namespace::eval punk::args { set help [punk::lib::dict_getdef $arginfo -help ""] if {[dict exists $arginfo -choices]} { if {$help ne ""} {append help \n} - append help "Choices: [dict get $arginfo -choices]" + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + } else { + set casemsg " (case sensitive)" + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + append help "Choices$prefixmsg$casemsg" + if {[catch {package require punk::trie}]} { + append help "\n " [join [dict get $arginfo -choices] "\n "] + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $arginfo -choices] { + set id [dict get $idents $c] + if {$id eq $c} { + append help "\n " "$M$c$RST" + } else { + set idlen [string length $id] + append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" + } + } + } errM]} { + puts stderr "prefix marking failed\n$errM" + append help "\n " [join [dict get $arginfo -choices] "\n "] + } + } } if {[punk::lib::dict_getdef $arginfo -multiple 0]} { set multiple $greencheck @@ -1429,20 +1522,38 @@ tcl::namespace::eval punk::args { } if {$has_choices} { #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set nocase [tcl::dict::get $thisarg -nocase] + set choices [tcl::dict::get $thisarg -choices] + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set nocase [tcl::dict::get $thisarg -nocase] foreach e $vlist e_check $vlist_check { if {$nocase} { - set casemsg "(case insensitive)" + set casemsg " (case insensitive)" set choices_test [tcl::string::tolower $choices] set v_test [tcl::string::tolower $e_check] } else { - set casemsg "(case sensitive)" + set casemsg " (case sensitive)" set v_test $e_check set choices_test $choices } - if {$v_test ni $choices_test} { - arg_error "Option $argname for [Get_caller] must be one of the listed values $choices $casemsg. Received: '$e'" $argspecs $argname + set choice_ok 0 + if {$choiceprefix} { + if {![catch {tcl::prefix::match $choices_test $v_test} chosen]} { + set choice_ok 1 + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice [lsearch -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list + if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { + tcl::dict::set opts $argname $choice + } else { + tcl::dict::set values_dict $argname $choice + } + } + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + set choice_ok [expr {$v_test in $choices_test}] + } + if {!$choice_ok} { + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs $argname } } } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm index 206b560b..1e4de9ec 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -362,10 +362,11 @@ tcl::namespace::eval punk::config { proc configure {args} { set argd [punk::args::get_dict { - - whichconfig -type string -choices {startup running} + *values -min 1 -max 1 + whichconfig -type string -choices {startup running stop} } $args] + return "unimplemented - $argd" } proc show {whichconfig {globfor *}} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index 95ecb27d..001a7653 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -44,6 +44,7 @@ #[list_begin itemized] package require Tcl 8.6- +package require Thread ;#tsv required to sync is_raw package require punk::ansi #*** !doctools #[item] [package {Tcl 8.6-}] @@ -84,7 +85,12 @@ namespace eval punk::console { variable previous_stty_state_stdin "" variable previous_stty_state_stdout "" variable previous_stty_state_stderr "" - variable is_raw 0 + + #variable is_raw 0 + if {![tsv::exists console is_raw]} { + tsv::set console is_raw 0 + } + variable input_chunks_waiting if {![info exists input_chunks_waiting(stdin)]} { set input_chunks_waiting(stdin) [list] @@ -183,7 +189,8 @@ namespace eval punk::console { #NOTE - the is_raw is only being set in current interp - but the channel is shared. #this is problematic with the repl thread being separate. - must be a tsv? REVIEW proc enableRaw {{channel stdin}} { - variable is_raw + #variable is_raw + variable previous_stty_state_$channel set sttycmd [auto_execok stty] if {[set previous_stty_state_$channel] eq ""} { @@ -193,21 +200,21 @@ namespace eval punk::console { } exec {*}$sttycmd raw -echo <@$channel - set is_raw 1 + tsv::set console is_raw 1 return [dict create previous [set previous_stty_state_$channel]] } proc disableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel set sttycmd [auto_execok stty] if {[set previous_stty_state_$channel] ne ""} { exec {*}$sttycmd [set previous_stty_state_$channel] set previous_stty_state_$channel "" - set is_raw 0 + tsv::set console is_raw 0 return restored } exec {*}$sttycmd -raw echo <@$channel - set is_raw 0 + tsv::set console is_raw 0 return done } proc enableVirtualTerminal {{channels {input output}}} { @@ -249,11 +256,11 @@ namespace eval punk::console { } proc mode {{raw_or_line query}} { - variable is_raw + #variable is_raw variable ansi_available set raw_or_line [string tolower $raw_or_line] if {$raw_or_line eq "query"} { - if {$is_raw} { + if {[tsv::get console is_raw]} { return "raw" } else { return "line" @@ -493,7 +500,7 @@ namespace eval punk::console { } proc [namespace parent]::enableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel if {[package provide twapi] ne ""} { @@ -506,7 +513,7 @@ namespace eval punk::console { #set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]] set newmode [twapi::get_console_input_mode] - set is_raw 1 + tsv::set console is_raw 1 #don't disable handler - it will detect is_raw ### twapi::set_console_control_handler {} return [list stdin [list from $oldmode to $newmode]] @@ -516,7 +523,7 @@ namespace eval punk::console { } exec {*}$sttycmd raw -echo <@$channel - set is_raw 1 + tsv::set console is_raw 1 #review - inconsistent return dict return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] } else { @@ -528,7 +535,7 @@ namespace eval punk::console { #could be we were missing a step in reopening stdin and console configuration? proc [namespace parent]::disableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel if {[package provide twapi] ne ""} { @@ -537,7 +544,7 @@ namespace eval punk::console { # Turn on the echo and line-editing bits twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1 set newmode [twapi::get_console_input_mode] - set is_raw 0 + tsv::set console is_raw 0 return [list stdin [list from $oldmode to $newmode]] } elseif {[set sttycmd [auto_execok stty]] ne ""} { #stty can return info on windows - but doesn't seem to be able to set anything. @@ -550,7 +557,7 @@ namespace eval punk::console { return restored } exec {*}$sttycmd -raw echo <@$channel - set is_raw 0 + tsv::set console is_raw 0 #do we really want to exec stty yet again to show final 'to' state? #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] @@ -634,7 +641,7 @@ namespace eval punk::console { puts -nonewline $output $query;flush $output #todo - test and save rawstate so we don't disableRaw if console was already raw - if {!$::punk::console::is_raw} { + if {![tsv::get console is_raw]} { set was_raw 0 punk::console::enableRaw } else { @@ -1378,7 +1385,7 @@ namespace eval punk::console { #todo - compare speed with get_cursor_pos - work out why the big difference proc test_cursor_pos {} { - if {!$::punk::console::is_raw} { + if {![tsv::get console is_raw]} { set was_raw 0 enableRaw } else { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm index 1e1986e6..9f74d2d5 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/du-0.1.0.tm @@ -1065,56 +1065,65 @@ namespace eval punk::du { #note - with this design, we can't glob for all except dotfiles - this is for cross-platform consistency and efficiency (Review). #dotfiles aren't considered hidden on all platforms #some sort of antiglob is a possible enhancement and more consistent with the view that leading dot should be treated as any other filename character in this context. - if {$opt_glob eq "*"} { - #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' - #set parent [lindex $folders $folderidx] - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] - #set hdirs {} - set dirs [glob -nocomplain -dir $folderpath -types d * .*] - - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] - #set hlinks {} - set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove (?) - #set links [lsort -unique [concat $hlinks $links[unset links]]] - - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] - #set hfiles {} - set files [glob -nocomplain -dir $folderpath -types f * .*] - #set files {} - } else { - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + if {"windows" eq $::tcl_platform(platform)} { + if {$opt_glob eq "*"} { + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #set parent [lindex $folders $folderidx] + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] + + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove (?) + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] + set files [glob -nocomplain -dir $folderpath -types f * .*] + } else { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } + } else { + set hdirs {} + set hfiles {} + set hlinks {} + if {$opt_glob eq "*"} { + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #set parent [lindex $folders $folderidx] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + set files [glob -nocomplain -dir $folderpath -types f * .*] + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #note struct::set difference produces unordered result #struct::set difference removes duplicates (but not always.. e.g if using tcl impl and 2nd element empty!) - #relying on struct::set to remove dupes is somewhat risky. It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets' + #relying on struct::set to remove dupes is somewhat risky. + #It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets' ie lists without dupes + #for this reason we must use the wrapper punk::lib::struct_set_diff_unique, which will use the well behaved critcl for speed if avail, but fall back to a deduping tcl version #remove links and . .. from directories, remove links from files #ideally we would like to classify links by whether they point to files vs dirs - but there are enough cross-platform differences that we will have to leave it to the caller to sort out for now. #struct::set will affect order: tcl vs critcl give different ordering! - set files [struct::set difference [concat $hfiles $files[unset files]] $links] - set dirs [struct::set difference [concat $hdirs $dirs[unset dirs]] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - #set links [lsort -unique [concat $links $hlinks]] + set files [punk::lib::struct_set_diff_unique [list {*}$hfiles {*}$files[unset files]] $links] + set dirs [punk::lib::struct_set_diff_unique [list {*}$hdirs {*}$dirs[unset dirs] ] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]] #---- set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] - - if {"windows" eq $::tcl_platform(platform)} { - set flaggedhidden [concat $hdirs $hfiles $hlinks] - } else { - #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden - #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden - set flaggedhidden {} - } + set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks] + #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden + #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden set vfsmounts [get_vfsmounts_in_folder $folderpath] @@ -1223,21 +1232,21 @@ namespace eval punk::du { #if {[punk::mix::base::lib::path_a_above_b $folderpath "//zipfs:/"]} {} - #zipfs files also reported as links by glob - review - should we preserve this in response? + #todo - hidden? not returned in attributes on windows at least. + #zipfs files also reported as links by glob - review - should we preserve this in response? (2024 unable to duplicate) if {$opt_glob eq "*"} { set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - #set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set links [list] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files } else { set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - #set links [glob -nocomplain -dir $folderpath -types l $opt_glob] - set links [list] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] #nested vfs mount.. REVIEW - does anything need special handling? @@ -1300,34 +1309,63 @@ namespace eval punk::du { } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + #at least some vfs on windows seem to support the -hidden attribute + #we are presuming glob will accept the -types hidden option for all vfs - even if it doesn't really apply REVIEW + #The extra globs aren't nice - but hopefully the vfs is reasonably performant (?) set errors [dict create] - if {$opt_glob eq "*"} { - set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? - set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + if {"windows" eq $::tcl_platform(platform)} { + if {$opt_glob eq "*"} { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set hfiles [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } } else { - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + #we leave it to the ui on unix to classify dotfiles as hidden + set hdirs {} + set hfiles {} + set hlinks {} + if {$opt_glob eq "*"} { + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] #nested vfs mount.. REVIEW - does anything need special handling? set vfsmounts [get_vfsmounts_in_folder $folderpath] set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] + set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks] set effective_opts $opts dict set effective_opts -with_times $timed_types dict set effective_opts -with_sizes $sized_types - return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden $flaggedhidden flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] } #we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files + #but we don't classify as such anyway. (leave for UI) proc du_dirlisting_unix {folderpath args} { set defaults [dict create\ -glob *\ @@ -1379,6 +1417,9 @@ namespace eval punk::du { } #this is not consistent with standard way * works for unix folders - but it is consistent with behaviour of this facility on windows + #we don't classify anything as 'flaggedhidden' on unix. + #it is a convention for dotfiles rather than a flag - and we'll leave the distinction for the display library + #This if {$opt_glob eq "*"} { set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove @@ -1389,8 +1430,9 @@ namespace eval punk::du { set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] set vfsmounts [get_vfsmounts_in_folder $folderpath] set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] @@ -1406,7 +1448,7 @@ namespace eval punk::du { #return fsizes,allsizes,alltimes metadata in same order as files,dirs,links lists - if specified in sized_types proc du_get_metadata_lists {sized_types timed_types files dirs links} { set meta_dict [dict create] - set meta_types [concat $sized_types $timed_types] + set meta_types [list {*}$sized_types {*}$timed_types] #known tcl stat keys 2023 - review set empty_stat_dict [dict create atime {} ctime {} dev {} gid {} ino {} mode {} mtime {} nlink {} size {} type {} uid {}] #make sure we call file stat only once per item @@ -1419,6 +1461,7 @@ namespace eval punk::du { if {![catch {file stat $path arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] } else { + puts stderr "du_get_metadata_lists: file stat $path error: $errM" dict lappend errors $path "file stat error: $errM" dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] } @@ -1437,6 +1480,9 @@ namespace eval punk::du { if {$ft eq "f"} { #subst with na if empty? lappend fsizes [dict get $pathinfo size] + if {[dict get $pathinfo size] eq ""} { + puts stderr "du_get_metadata_lists: fsize $path is empty!" + } } } if {$ft in $timed_types} { @@ -1446,7 +1492,7 @@ namespace eval punk::du { #todo - fix . The list lengths will presumably match but have empty values if failed to stat if {"f" in $sized_types} { if {[llength $fsizes] ne [llength $files]} { - dict lappend errors $folderpath "failed to retrieve all file sizes" + dict lappend errors general "failed to retrieve all file sizes" } } return [dict create fsizes $fsizes allsizes $allsizes alltimes $alltimes] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm index 7e1ee14c..22178177 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -290,7 +290,6 @@ namespace eval punk::fileline::class { -showconfig 0\ -boundaryheader {Boundary %i% at %b%}\ ] - set known_opts [dict keys $defaults] foreach {k v} $args { switch -- $k { -ansi - -offset - -displaybytes - -truncatedmark - -completemark - -moremark - -continuemark - -linemaxwidth - -linebase - -limit - -boundaries - -showconfig - -boundaryheader { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm index 8f51075e..070621bc 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -339,6 +339,144 @@ namespace eval punk::lib { set has_twapi [expr {![catch {package require twapi}]}] } + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - This is the primary source for tm_version... functions + # - certain packages script require these but without package dependency + # - 1 punk boot script + # - 2 packagetrace module + # - These should be updated to sync with this + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + 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 "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 {![tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {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 {![tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![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" + } + } + # end tm_version... functions + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + + # -- --- #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 @@ -1575,8 +1713,20 @@ namespace eval punk::lib { lremove $fromlist {*}$doomed } + #fix for tcl impl of struct::set::diff which doesn't dedupe + proc struct_set_diff_unique {A B} { + package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. + if {[struct::set::Loaded] eq "tcl"} { + return [punk::lib::setdiff $A $B] + } else { + #use (presumably critcl) implementation for speed + return [struct::set difference $A $B] + } + } + + #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B - #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference + #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) #also struct::set difference with critcl is faster proc setdiff {A B} { if {[llength $A] == 0} {return {}} @@ -2387,7 +2537,7 @@ namespace eval punk::lib { set stdin_state [fconfigure stdin] if {[catch { package require punk::console - set console_raw [set ::punk::console::is_raw] + set console_raw [tsv::get console is_raw] } err_console]} { #assume normal line mode set console_raw 0 @@ -3032,6 +3182,11 @@ namespace eval punk::lib { proc objclone {obj} { append obj2 $obj {} } + proc set_clone {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } @@ -3175,7 +3330,7 @@ tcl::namespace::eval punk::lib::system { #[para] Internal functions that are not part of the API #[list_begin definitions] - proc has_script_var_bug {} { + proc has_tclbug_script_var {} { set script {set j [list spud] ; list} append script \n uplevel #0 $script @@ -3194,7 +3349,15 @@ tcl::namespace::eval punk::lib::system { return false } } - proc has_safeinterp_compile_bug {{show 0}} { + + proc has_tclbug_list_quoting_emptyjoin {} { + #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 + set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases + set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" + return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + } + + proc has_tclbug_safeinterp_compile {{show 0}} { #ensemble calls within safe interp not compiled namespace eval [namespace current]::testcompile { proc ensembletest {} {string index a 0} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm index 806b172e..dfdc71f9 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -473,13 +473,26 @@ namespace eval punk::mix::base { #set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names zlib adler32 $data } - #zlib crc vie file-slurp + #zlib crc via file-slurp proc cksum_crc_file {filename} { package require zlib set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] zlib crc $data } + proc cksum_md5_data {data} { + if {[package vsatisfies [package present md5] 2-]} { + return [md5::md5 -hex $data] + } else { + return [md5::md5 $data] + } + } + #fallback md5 via file-slurp - shouldn't be needed if have md5 2- + proc cksum_md5_file {filename} { + set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] + cksum_md5_data $data + } + #required to be able to accept relative paths #for full cksum - using tar could reduce number of hashes to be made.. @@ -624,7 +637,11 @@ namespace eval punk::mix::base { } md5 { package require md5 - set cksum_command [list md5::md5 -hex -file] + if {[package vsatisfies [package present md5] 2- ] } { + set cksum_command [list md5::md5 -hex -file] + } else { + set cksum_comand [list cksum_md5_file] + } } cksum { package require cksum ;#tcllib @@ -637,7 +654,7 @@ namespace eval punk::mix::base { set cksum_command [list cksum_adler32_file] } sha3 - sha3-256 { - #todo - replace with something that doesn't call another process + #todo - replace with something that doesn't call another process - only if tcllibc not available! #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] set cksum_command [list $sha3_implementation 256] } @@ -684,7 +701,7 @@ namespace eval punk::mix::base { set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)" } set tsstart [clock millis] - puts -nonewline stdout "cksum_path: calculating cksum for $target $sizeinfo ... " + puts -nonewline stdout "cksum_path: calculating cksum using $opt_cksum_algorithm for $target $sizeinfo ... " set cksum [{*}$cksum_command $archivename] set tsend [clock millis] set ms [expr {$tsend - $tsstart}] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm index 856c9340..1d8d40e1 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm @@ -271,7 +271,12 @@ namespace eval punk::mix::commandset::doc { #this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. #review - if we're checking fname - should also test length of whole path and determine limits for tar package require md5 - set target_docname [md5::md5 -hex [encoding convertto utf-8 $fullpath]]_overlongfilename.man + if {[package vsatisfies [package present md5] 2- ] } { + set md5opt "-hex" + } else { + set md5opt "" + } + set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man puts stderr "WARNING - overlong file name - renaming $fullpath" puts stderr " to [file dirname $fullpath]/$target_docname" } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm index aca7eeed..d1459369 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -261,6 +261,8 @@ namespace eval punk::mix::util { return } + # review punk::lib::tm_version.. functions + proc is_valid_tm_version {versionpart} { #Needs to be suitable for use with Tcl's 'package vcompare' if {![catch [list package vcompare $versionpart $versionpart]]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 426271a7..9cf44529 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -821,9 +821,12 @@ tcl::namespace::eval punk::nav::fs { set match_contents $opt_tailglob } } - puts stdout "searchbase: $searchbase searchspec:$searchspec" + #puts stdout "searchbase: $searchbase searchspec:$searchspec" - set in_vfs 0 + + #file attr //cookit:/ returns {-vfs 1 -handle {}} + #we will treat it differently for now - use generic handler REVIEW + set in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit. if {[llength [package provide vfs]]} { foreach mount [vfs::filesystem info] { if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} { @@ -849,22 +852,45 @@ tcl::namespace::eval punk::nav::fs { set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } else { set in_zipfs 0 - if {[info commands ::tcl::zipfs::mount] ne ""} { - if {[string match //zipfs:/* $location]} { - set in_zipfs 1 + set in_cookit 1 + set in_other_pseudovol 1 + switch -glob -- $location { + //zipfs:/* { + if {[info commands ::tcl::zipfs::mount] ne ""} { + set in_zipfs 1 + } + } + //cookit:/* { + set in_cookit 1 + } + default { + #handle 'other/unknown' that mounts at a volume-like path //pseudovol:/ + if {[regexp {//((?:(?!:|/).)+):/.*} $location _match pseudovol]} { + #pseudovol probably more than one char long + #we don't really expect something like //c:/ , but anyway, it's not the same as c:/ and for all we know someone could use that as a volume name? + set in_other_pseudovol 1 ;#flag so we don't use twapi - hope generic can handle it (uses tcl glob) + } else { + #we could use 'file attr' here to test if {-vfs 1} + #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) + #instead for now we'll assume any reasonable vfs should have been found by vfs::filesystem::info or mounted as a pseudovolume + } + } - #dict for {zmount zpath} [zipfs mount] { - # if {[punk::mix::base::lib::path_a_atorbelow_b $location $zmount]} { - # set in_zipfs 1 - # break - # } - #} } + if {$in_zipfs} { #relative vs absolute? review - cwd valid for //zipfs:/ ?? - set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + } elseif {$in_cookit} { + #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ + #don't use twapi + #could possibly use du_dirlisting_tclvfs REVIEW + #files and folders are all returned with the -types hidden option for glob on windows + set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + } elseif {$in_other} { + set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } else { - set listing [punk::du::dirlisting $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + set listing [punk::du::dirlisting $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index d950eab4..e38c76c6 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -155,18 +155,26 @@ tcl::namespace::eval punk::packagepreference { if {[lindex $args 1] eq "-exact"} { set pkg [lindex $args 2] set vwant [lindex $args 3] - if {[set ver [package provide $pkg]] ne ""} { - if {$ver eq $vwant} { - return $vwant - } else { - #package already provided with a different version.. we will defer to underlying implementation to return the standard error - return [$COMMANDSTACKNEXT {*}$args] - } + if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { + #although we could shortcircuit using vsatisfies to return the ver + #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. + return [$COMMANDSTACKNEXT {*}$args] + + #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} { + # return $ver + #} else { + # #package already provided with a different version.. we will defer to underlying implementation to return the standard error + # return [$COMMANDSTACKNEXT {*}$args] + #} } } else { set pkg [lindex $args 1] - if {[set ver [package provide $pkg]] ne ""} { - return $ver + set vwant [lindex $args 2] + if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { + return [$COMMANDSTACKNEXT {*}$args] + #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} { + # return $ver + #} } } if {[regexp {[A-Z]} $pkg]} { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm index 09b8a0be..39b5bf78 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm @@ -20,12 +20,12 @@ #*** !doctools #[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] +#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] #[require punk::repl::codethread] -#[keywords module] +#[keywords module repl] #[description] -#[para] - +#[para] This is part of the infrastructure required for the punk::repl to operate # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -131,11 +131,14 @@ tcl::namespace::eval punk::repl::codethread { # return "ok" #} + variable run_command_cache + proc is_running {} { variable running return $running } proc runscript {script} { + #puts stderr "->runscript" variable replthread_cond variable output_stdout "" @@ -169,9 +172,18 @@ tcl::namespace::eval punk::repl::codethread { #set errhandle [shellfilter::stack::item_tophandle stderr] #interp transfer "" $errhandle code - set scope [interp eval code [list set ::punk::ns::ns_current]] set status [catch { - interp eval code [list tcl::namespace::inscope $scope $script] + #shennanigans to keep compiled script around after call. + #otherwise when $script goes out of scope - internal rep of vars set in script changes. + #The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible. + interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone + interp eval code { + lappend ::codeinterp::run_command_cache $::codeinterp::clonescript + if {[llength $::codeinterp::run_command_cache] > 2000} { + set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache] + } + tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript + } } result] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index 4e0217b0..bc93a9c3 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -27,6 +27,11 @@ # # path/repo functions # + +#REVIEW punk::repo required early by punk boot script to find projectdir +#todo - split off basic find_project chain of functions to a smaller package and import as necessary here +#Then we can reduce early dependencies in punk boot + if {$::tcl_platform(platform) eq "windows"} { package require punk::winpath } else { diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm index 96fb263d..b822b353 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textblock-0.1.1.tm @@ -5280,8 +5280,8 @@ tcl::namespace::eval textblock { It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" *values -min 1 -max 1 frametype -help "name from the predefined frametypes: - or an adhoc - }] + or an adhoc " + }] append spec \n "frametype -help \"A predefined \"" punk::args::get_dict $spec $args return @@ -6804,7 +6804,11 @@ tcl::namespace::eval textblock { if {$use_md5} { #package require md5 ;#already required at package load - set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review + if {[package vsatisfies [package present md5] 2- ] } { + set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review + } else { + set hash [md5::md5 [encoding convertto utf-8 $hashables]] + } } else { set hash $hashables } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textutil-0.9.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textutil-0.9.tm index 59258514..b18a5228 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textutil-0.9.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/textutil-0.9.tm @@ -16,7 +16,7 @@ # ### ### ### ######### ######### ######### ## Requirements -package require Tcl 8.2 +package require Tcl 8.2- namespace eval ::textutil {} diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl index 24206ba7..f6ade4c4 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl @@ -1,13 +1,19 @@ # tcl # -#make any tclkits and modules in src and place them and associated data files/scripts in the parent folder of src. +# punkboot - make any tclkits and modules in /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. - set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" puts $hashline -puts " punkshell make script " +puts " Punk Boot" puts $hashline\n -namespace eval ::punkmake { + +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] @@ -15,6 +21,139 @@ namespace eval ::punkmake { variable help_flags [list -help --help /?] variable known_commands [list project modules 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 @@ -23,30 +162,96 @@ if {"::try" ni [info commands ::try]} { #------------------------------------------------------------------------------ #Module loading from src/bootsupport or [pwd]/modules if pwd is a 'src' folder #------------------------------------------------------------------------------ -#If the there is a folder under the current directory /src/bootsupport/modules which contains .tm files +#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 make script +# 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]]} { - set bootsupport_mod [file join $startdir src bootsupport modules] - set bootsupport_lib [file join $startdir src bootsupport lib] + lappend bootsupport_module_paths [file join $startdir src bootsupport modules] + lappend bootsupport_library_paths [file join $startdir src bootsupport lib] } else { - set bootsupport_mod [file join $startdir bootsupport modules] - set bootsupport_lib [file join $startdir bootsupport lib] + lappend bootsupport_module_paths [file join $startdir bootsupport modules] + lappend bootsupport_library_paths [file join $startdir bootsupport lib] +} +set bootsupport_paths_exist 0 +foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] { + if {[file exists $p]} { + set bootsupport_paths_exist 1 ;#at least one exists + break + } } +# ------------------------------------------------------------------------------------- +# ------------------------------------------------------------------------------------- +set sourcesupport_module_paths [list] +set sourcesupport_library_paths [list] +set sourcesupport_paths_exist 0 +#we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir. +#The /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] { + if {[file exists $p]} { + lappend sourcesupport_module_paths $p + } + } + # -- -- -- + foreach p [list $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 /modules are the very modules we are building - and may be in a broken state, which make.tcl then can't fix. - if {[file tail $startdir] eq "src"} { - if {[file exists $startdir/modules]} { - #launch from .' (minbounded) as .- 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]\ + overtype [list version "1.6.5-"]\ + punkcheck [list]\ + 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}]\ +] + # ** *** *** *** *** *** *** *** *** *** *** *** -#*temporarily* hijack package command +# 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. # ** *** *** *** *** *** *** *** *** *** *** *** -try { - rename ::package ::punkmake::package_temp_aside - proc ::package {args} { - if {[lindex $args 0] eq "require"} { - lappend ::punkmake::pkg_requirements [lindex $args 1] +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 .. + 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] } } - package require punk::mix - package require punk::repo - package require punk::ansi - package require overtype -} finally { - catch {rename ::package ""} - catch {rename ::punkmake::package_temp_aside ::package} + + #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 } -# ** *** *** *** *** *** *** *** *** *** *** *** -foreach pkg $::punkmake::pkg_requirements { - if {[catch {package require $pkg} errM]} { - puts stderr "missing pkg: $pkg" - lappend ::punkmake::pkg_missing $pkg - } else { - lappend ::punkmake::pkg_loaded $pkg + + +#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)} ... -proc punkmake_gethelp {args} { set scriptname [file tail [info script]] append h "Usage:" \n append h "" \n @@ -138,12 +1028,15 @@ proc punkmake_gethelp {args} { 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 processes running as the executable being built (if applicable)" \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 /modules /lib etc." \n \n append h " $scriptname modules" \n - append h " - build modules from src/modules etc without scanning src/runtime and src/vfs folders to build kit/zipkit executables" \n \n + append h " - build modules from src/modules src/vendormodules etc to their corresponding locations under " \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//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 /modules /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 @@ -154,24 +1047,51 @@ proc punkmake_gethelp {args} { append h " $scriptname info" \n append h " - show the name and base folder of the project to be built" \n append h "" \n - if {[llength $::punkmake::pkg_missing]} { - append h "* ** NOTE ** ***" \n - append h " punkmake has detected that the following packages could not be loaded:" \n - append h " " [join $::punkmake::pkg_missing "\n "] \n - append h "* ** *** *** ***" \n - append h " These packages are required for punk make to function" \n \n - append h "* ** *** *** ***" \n\n - append h "Successfully Loaded packages:" \n - append h " " [join $::punkmake::pkg_loaded "\n "] \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 $::punkmake::help_flags { + foreach h $::punkboot::help_flags { if {[lsearch $scriptargs $h] >= 0} { set do_help 1 break @@ -183,23 +1103,32 @@ foreach a $scriptargs { if {![string match -* $a]} { lappend commands_found $a } else { - if {$a ni $::punkmake::non_help_flags} { + 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 $::punkmake::known_commands} { +} 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 stderr [punkmake_gethelp] + 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 ::punkmake::command [lindex $commands_found 0] +set ::punkboot::command [lindex $commands_found 0] if {[lsearch $::argv -k] >= 0} { @@ -210,7 +1139,7 @@ if {[lsearch $::argv -k] >= 0} { #puts stdout "::argv $::argv" # ---------------------------------------- -set scriptfolder $::punkmake::scriptfolder +set scriptfolder $::punkboot::scriptfolder @@ -218,21 +1147,25 @@ set scriptfolder $::punkmake::scriptfolder #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 "punkmake 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 "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 punkmake script operating in project space that is not under version control" + puts stderr "WARNING punkboot script operating in project space that is not under version control" } } else { } set sourcefolder $projectroot/src -if {$::punkmake::command eq "check"} { +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]} { @@ -249,25 +1182,87 @@ if {$::punkmake::command eq "check"} { 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] - puts stdout "punk::mix::base version $v\n[package ifneeded punk::mix::base $v]" - exit 0 -} + #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} { - #restore module paths and auto_path in addition to the bootsupport ones 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] + #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 {$::punkmake::command eq "info"} { +if {$::punkboot::command eq "info"} { puts stdout "- -- --- --- --- --- --- --- --- --- -- -" puts stdout "- -- info -- -" puts stdout "- -- --- --- --- --- --- --- --- --- -- -" @@ -318,16 +1313,23 @@ if {$::punkmake::command eq "info"} { exit 0 } -if {$::punkmake::command eq "shell"} { + + + +if {$::punkboot::command eq "shell"} { package require punk package require punk::repl - puts stderr "make shell not fully implemented - dropping into ordinary punk shell" + 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 {$::punkmake::command eq "vfscommonupdate"} { +if {$::punkboot::command eq "vfscommonupdate"} { puts "projectroot: $projectroot" puts "script: [info script]" puts stdout "Updating vfs/_vfscommon" @@ -362,7 +1364,7 @@ if {$::punkmake::command eq "vfscommonupdate"} { ::exit 0 } -if {$::punkmake::command eq "vendorupdate"} { +if {$::punkboot::command eq "vendorupdate"} { puts "projectroot: $projectroot" puts "script: [info script]" #puts "-- [tcl::tm::list] --" @@ -479,7 +1481,7 @@ if {$::punkmake::command eq "vendorupdate"} { ::exit 0 } -if {$::punkmake::command eq "bootsupport"} { +if {$::punkboot::command eq "bootsupport"} { puts "projectroot: $projectroot" puts "script: [info script]" #puts "-- [tcl::tm::list] --" @@ -635,8 +1637,8 @@ if {$::punkmake::command eq "bootsupport"} { -if {$::punkmake::command ni {project modules}} { - puts stderr "Command $::punkmake::command not implemented - aborting." +if {$::punkboot::command ni {project modules}} { + puts stderr "Command $::punkboot::command not implemented - aborting." flush stderr after 100 exit 1 @@ -874,7 +1876,7 @@ if {[punk::repo::is_fossil_root $projectroot]} { $installer destroy } -if {$::punkmake::command ne "project"} { +if {$::punkboot::command ne "project"} { #command = modules puts stdout "vfs folders not checked" puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into base vfs folder" @@ -1027,6 +2029,13 @@ foreach runtime [dict keys $runtime_vfs_map] { 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 } @@ -1092,7 +2101,7 @@ foreach runtimefile $runtimes { # -- --- --- --- --- --- puts stdout "Copying runtime from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" if {[catch { - file copy -force $rtfolder/$runtimefile $buildfolder/build_$runtimefile + 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 @@ -1101,7 +2110,7 @@ foreach runtimefile $runtimes { } # -- --- --- --- --- --- } else { - puts stderr "." + puts stderr "unchanged: $runtimefile" $event targetset_end SKIPPED } $event end @@ -1119,7 +2128,8 @@ proc ::make_file_traversal_error {args} { } proc merge_over {sourcedir targetdir} { package require fileutil - package require fileutil::traverse + set ver [package require fileutil::traverse] + puts stdout "using fileutil::traverse $ver\n[package ifneeded fileutil::traverse $ver]" package require control if {![file exists $sourcedir]} { @@ -1150,6 +2160,11 @@ proc merge_over {sourcedir targetdir} { if {![file exists $target]} { #puts stdout "-- mkdir $target" puts stdout "$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 { @@ -1293,11 +2308,13 @@ foreach vfstail $vfs_tails { $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon $vfs_event targetset_addsource $sourcefolder/vfs/$vfstail if {$rtname ne "-"} { - $vfs_event targetset_addsource $buildfolder/build_$runtime_fullname ;#working copy of runtime executable + set building_runtime $buildfolder/build_$runtime_fullname ;#working copy of runtime executable + $vfs_event targetset_addsource $building_runtime + } else { + set building_runtime "-" ;#REVIEW } # -- ---------- - set rtmountpoint //zipfs:/rtmounts/$runtime_fullname 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]]}] @@ -1319,18 +2336,31 @@ foreach vfstail $vfs_tails { set targetvfs $buildfolder/buildvfs_$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 { #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 $buildfolder/build_$runtime_fullname rtmounts/$runtime_fullname + tcl::zipfs::mount $building_runtime rtmounts/$runtime_fullname } errM]} { - tcl::zipfs::mount rtmounts/$runtime_fullname $buildfolder/build_$runtime_fullname + 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?" + } } } @@ -1341,6 +2371,34 @@ foreach vfstail $vfs_tails { merge_over $sourcefolder/vfs/_vfscommon $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 /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 $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. @@ -1358,9 +2416,14 @@ foreach vfstail $vfs_tails { merge_over $sourcevfs $targetvfs #set wrapvfs $sourcefolder/$vfs + set wrapvfs $targetvfs switch -- $kit_type { zip { + 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} { @@ -1373,8 +2436,8 @@ foreach vfstail $vfs_tails { } } #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 \"\" $buildfolder/build_$runtime_fullname" - tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $buildfolder/build_$runtime_fullname + puts stderr "calling: tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs \"\" $building_runtime" + tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $building_runtime } result ]} { set failmsg "zipfs mkimg failed with msg: $result" puts stderr "tcl::zipfs::mkimg $targetkit failed" @@ -1391,6 +2454,52 @@ foreach vfstail $vfs_tails { 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" @@ -1402,7 +2511,7 @@ foreach vfstail $vfs_tails { } else { if {[catch { if {$rtname ne "-"} { - exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose + exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $building_runtime -verbose } else { exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose } @@ -1560,7 +2669,7 @@ foreach vfstail $vfs_tails { if {$built_or_installed_kit_changed} { if {[file exists $deployment_folder/$targetkit]} { - puts stderr "deleting existing deployed at $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]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm index 8424ce07..d0fdc8ec 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/fauxlink-0.1.0.tm @@ -66,6 +66,16 @@ # "my-program-files#++server+c+Program%20Files.fxlnk" #If we needed the old-style literal %20 it would become # "my-program-files#++server+c+Program%2520Files.fxlnk" +# +# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) +# e.g +# pfiles#file%3a++++localhost+c+Program%2520files +# The browser will work with literal spaces too though - so it could just as well be: +# pfiles#file%3a++++localhost+c+Program%20files +#windows may default to using explorer.exe instead of a browser for file:// urls though +#and explorer doesn't want the literal %20. It probably depends what API the file:// url is to be passed to? +#in a .url shortcut either literal space or %20 will work ie %xx values are decoded + #*** !doctools diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config index 922ff786..17b5192a 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/include_modules.config @@ -14,7 +14,6 @@ set bootsupport_modules [list\ src/vendormodules debug\ src/vendormodules dictutils\ src/vendormodules fauxlink\ - src/vendormodules fileutil\ src/vendormodules http\ src/vendormodules md5\ src/vendormodules metaface\ diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm index 2d6e61da..4bd8aae0 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm @@ -213,6 +213,13 @@ namespace eval punk { proc objclone {obj} { append obj2 $obj {} } + proc set_clone {varname obj} { + #maintenance: also punk::lib::set_clone + #e.g used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } + interp alias "" strlen "" ::punk::strlen interp alias "" str_len "" ::punk::strlen interp alias "" objclone "" ::punk::objclone @@ -2121,8 +2128,8 @@ namespace eval punk { set level_script_complete 1 } {@V\*@*} - {@v\*@*} { - #dict value glob - return values - set active_key_type "dict" + #dict value glob - return values + set active_key_type dict set keyglob [string range $index 4 end] append script [tstr -return string -allowcommands { if {[catch {dict size $leveldata}]} { @@ -2132,7 +2139,7 @@ namespace eval punk { if {$get_not} { lappend INDEX_OPERATIONS globvalue-get-values-not append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operation: globvalue-get-values-not" + # set active_key_type "dict" ;# index_operation: globvalue-get-values-not set assigned [list] tcl::dict::for {k v} $leveldata { if {![string match $v]} { @@ -2144,7 +2151,7 @@ namespace eval punk { } else { lappend INDEX_OPERATIONS globvalue-get-values append script \n [string map [list $keyglob] { - # set active_key_type "dict" index_operation: globvalue-get-value + # set active_key_type "dict" ;#index_operation: globvalue-get-value set assigned [dict values $leveldata ] }] } @@ -2166,7 +2173,7 @@ namespace eval punk { } else { lappend INDEX_OPERATIONS globkeyvalue-get-pairs append script \n [string map [list $keyvalglob] { - # set active_key_type "dict" index_operation: globkeyvalue-get-pairs-not" + # set active_key_type "dict" ;# index_operation: globkeyvalue-get-pairs-not set assigned [dict create] tcl::dict::for {k v} $leveldata { if {[string match $k] || [string match $v]} { @@ -4952,17 +4959,14 @@ namespace eval punk { } else { #tags ? #debug.punk.pipe {>>raw commandline: [concat $rhs $segment_members_filled]} 5 - if 0 { - - - + if {false} { #set s [list uplevel 1 [concat $rhs $segment_members_filled]] if {![info exists pscript]} { upvar ::_pipescript pscript } if {![info exists pscript]} { #set pscript $s - set pscript [funcl::o_of_n 1 $segment_members] + set pscript [funcl::o_of_n 1 $segment_members] } else { #set pscript [string map [list

$pscript] {uplevel 1 [concat $rhs $segment_members_filled [

]]}] #set snew "set pipe_$i \[uplevel 1 \[list $rhs $segment_members_filled " @@ -4972,6 +4976,7 @@ namespace eval punk { } } + set cmdlist_result [uplevel 1 $segment_members_filled] #set d [_multi_bind_result $returnvarspec [punk::K $segment_members_filled [unset segment_members_filled]]] set d [_multi_bind_result $returnvarspec [lindex [list $cmdlist_result [unset cmdlist_result]] 0 ]] @@ -7321,16 +7326,22 @@ namespace eval punk { if {$topic in [list tcl]} { - if {[punk::lib::system::has_script_var_bug]} { - append warningblock \n "minor warning: punk::lib::system::has_script_var_bug returned true! (string rep for list variable in script generated when script changed)" + if {[punk::lib::system::has_tclbug_script_var]} { + append warningblock \n "minor warning: punk::lib::system::has_tclbug_script_var returned true! (string rep for list variable in script generated when script changed)" } - if {[punk::lib::system::has_safeinterp_compile_bug]} { + if {[punk::lib::system::has_tclbug_safeinterp_compile]} { set indent " " - append warningblock \n "[a+ web-red]warning: punk::lib::system::has_safeinterp_compile_bug returned true!" \n + append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_safeinterp returned true!" \n append warningblock "${indent}(ensemble commands not compiled in safe interps - heavy performance impact in safe interps)" \n append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/1095bf7f75" append warningblock [a] } + if {[punk::lib::system::has_tclbug_list_quoting_emptyjoin]} { + set indent " " + append warningblock \n "[a+ web-red]warning: punk::lib::system::has_tclbug_list_quoting returned true!" \n + append warningblock "${indent}lists elements not properly quoted in some cases. e.g 'list {*}[lindex {etc #foo} 1] {*}[list]' (#foo not braced)" \n + append warningblock "${indent}see https://core.tcl-lang.org/tcl/tktview/e38dce74e2" + } } set text "" diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm index 5e270ac8..c8a6ec84 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/args-0.1.0.tm @@ -201,6 +201,7 @@ #[para] packages used by punk::args #[list_begin itemized] package require Tcl 8.6- +#optional? punk::trie #*** !doctools #[item] [package {Tcl 8.6-}] @@ -293,6 +294,7 @@ tcl::namespace::eval punk::args { -validate_without_ansi 0\ -strip_ansi 0\ -nocase 0\ + -choiceprefix 1\ -multiple 0\ ] set valspec_defaults [tcl::dict::create\ @@ -301,8 +303,12 @@ tcl::namespace::eval punk::args { -allow_ansi 1\ -validate_without_ansi 0\ -strip_ansi 0\ + -nocase 0\ + -choiceprefix 1\ -multiple 0\ ] + #we need a -choiceprefix default even though it often doesn't apply so we can look it up to display in Help if there are -choices + #default to 1 for convenience #checks with no default #-minlen -maxlen -range @@ -415,11 +421,11 @@ tcl::namespace::eval punk::args { -anyopts { set opt_any $v } - -minlen - -maxlen - -range - -choices - -choicelabels { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix { #review - only apply to certain types? tcl::dict::set optspec_defaults $k $v } - -nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels { + -nominlen - -nomaxlen - -norange - -nochoices - -nochoicelabels - -nocase { if {$v} { tcl::dict::unset optspec_defaults $k } @@ -459,7 +465,7 @@ tcl::namespace::eval punk::args { tcl::dict::set optspec_defaults $k $v } default { - set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels\ + set known { -any -anyopts -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ } @@ -479,7 +485,7 @@ tcl::namespace::eval punk::args { -maxvalues { set val_max $v } - -minlen - -maxlen - -range - -choices - -choicelabels { + -minlen - -maxlen - -range - -choices - -choicelabels - -choiceprefix - -nocase { #review - only apply to certain types? tcl::dict::set valspec_defaults $k $v } @@ -520,7 +526,7 @@ tcl::namespace::eval punk::args { } default { set known { -min -minvalues -max -maxvalues\ - -minlen -maxlen -range -choices -choicelabels\ + -minlen -maxlen -range -choices -choicelabels -choiceprefix -nocase\ -nominlen -nomaxlen -norange -nochoices -nochoicelabels\ -type -optional -allow_ansi -validate_without_ansi -strip_ansi -multiple\ } @@ -596,12 +602,12 @@ tcl::namespace::eval punk::args { } } } - -default - -solo - -range - -choices - -choicelabels - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { + -default - -solo - -range - -choices - -choiceprefix - -choicelabels - -choiceprefix - -minlen - -maxlen - -nocase - -optional - -multiple - -validate_without_ansi - -allow_ansi - -strip_ansi - -help - -ARGTYPE { #review -solo 1 vs -type none ? tcl::dict::set spec_merged $spec $specval } default { - set known_argspecs [list -default -type -range -choices -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help] + set known_argspecs [list -default -type -range -choices -choiceprefix -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -help] error "punk::args::get_dict - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs" } } @@ -752,7 +758,28 @@ tcl::namespace::eval punk::args { #set greencheck [a+ web-limegreen]\u2713[a] set greencheck [a+ brightgreen]\u2713[a] - foreach arg [dict get $spec_dict opt_names] { + if {![catch {package require punk::trie}]} { + set opt_names_display [list] + set trie [punk::trie::trieclass new {*}[dict get $spec_dict opt_names]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $spec_dict opt_names] { + set id [dict get $idents $c] + if {$id eq $c} { + lappend opt_names_display $M$c$RST + } else { + set idlen [string length $id] + lappend opt_names_display "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" + } + } + } else { + set opt_names_display [dict get $spec_dict opt_names] + } + + + foreach argshow $opt_names_display arg [dict get $spec_dict opt_names] { set arginfo [dict get $spec_dict arg_info $arg] if {[dict exists $arginfo -default]} { #set default $c_default[dict get $arginfo -default] @@ -763,14 +790,47 @@ tcl::namespace::eval punk::args { set help [punk::lib::dict_getdef $arginfo -help ""] if {[dict exists $arginfo -choices]} { if {$help ne ""} {append help \n} - append help "Choices: [dict get $arginfo -choices]" + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + } else { + set casemsg " (case sensitive)" + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + append help "Choices$prefixmsg$casemsg" + if {[catch {package require punk::trie}]} { + append help "\n " [join [dict get $arginfo -choices] "\n "] + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $arginfo -choices] { + set id [dict get $idents $c] + if {$id eq $c} { + append help "\n " "$M$c$RST" + } else { + set idlen [string length $id] + append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" + } + } + } errM]} { + puts stderr "prefix marking failed\n$errM" + append help "\n " [join [dict get $arginfo -choices] "\n "] + } + } } if {[punk::lib::dict_getdef $arginfo -multiple 0]} { set multiple $greencheck } else { set multiple "" } - $t add_row [list $arg [dict get $arginfo -type] $default $multiple $help] + $t add_row [list $argshow [dict get $arginfo -type] $default $multiple $help] if {$arg eq $badarg} { $t configure_row [expr {[$t row_count]-1}] -ansibase $c_badarg } @@ -785,7 +845,40 @@ tcl::namespace::eval punk::args { set help [punk::lib::dict_getdef $arginfo -help ""] if {[dict exists $arginfo -choices]} { if {$help ne ""} {append help \n} - append help "Choices: [dict get $arginfo -choices]" + if {[dict get $arginfo -nocase]} { + set casemsg " (case insensitive)" + } else { + set casemsg " (case sensitive)" + } + if {[dict get $arginfo -choiceprefix]} { + set prefixmsg " (choice prefix allowed)" + } else { + set prefixmsg "" + } + append help "Choices$prefixmsg$casemsg" + if {[catch {package require punk::trie}]} { + append help "\n " [join [dict get $arginfo -choices] "\n "] + } else { + if {[catch { + set trie [punk::trie::trieclass new {*}[dict get $arginfo -choices]] + set idents [dict get [$trie shortest_idents ""] scanned] + $trie destroy + set M "\x1b\[32m" ;#mark in green + set RST "\x1b\[m" + foreach c [dict get $arginfo -choices] { + set id [dict get $idents $c] + if {$id eq $c} { + append help "\n " "$M$c$RST" + } else { + set idlen [string length $id] + append help "\n " "$M[string range $c 0 $idlen-1]$RST[string range $c $idlen end]" + } + } + } errM]} { + puts stderr "prefix marking failed\n$errM" + append help "\n " [join [dict get $arginfo -choices] "\n "] + } + } } if {[punk::lib::dict_getdef $arginfo -multiple 0]} { set multiple $greencheck @@ -1429,20 +1522,38 @@ tcl::namespace::eval punk::args { } if {$has_choices} { #todo -choicelabels - set choices [tcl::dict::get $thisarg -choices] - set nocase [tcl::dict::get $thisarg -nocase] + set choices [tcl::dict::get $thisarg -choices] + set choiceprefix [tcl::dict::get $thisarg -choiceprefix] + set nocase [tcl::dict::get $thisarg -nocase] foreach e $vlist e_check $vlist_check { if {$nocase} { - set casemsg "(case insensitive)" + set casemsg " (case insensitive)" set choices_test [tcl::string::tolower $choices] set v_test [tcl::string::tolower $e_check] } else { - set casemsg "(case sensitive)" + set casemsg " (case sensitive)" set v_test $e_check set choices_test $choices } - if {$v_test ni $choices_test} { - arg_error "Option $argname for [Get_caller] must be one of the listed values $choices $casemsg. Received: '$e'" $argspecs $argname + set choice_ok 0 + if {$choiceprefix} { + if {![catch {tcl::prefix::match $choices_test $v_test} chosen]} { + set choice_ok 1 + #can we handle empty string as a choice? It should just work - REVIEW/test + set choice [lsearch -inline -nocase $choices $chosen] ;#map possibly lcased choice back to original case in choices list + if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { + tcl::dict::set opts $argname $choice + } else { + tcl::dict::set values_dict $argname $choice + } + } + set prefixmsg " (or a unique prefix of a value)" + } else { + set prefixmsg "" + set choice_ok [expr {$v_test in $choices_test}] + } + if {!$choice_ok} { + arg_error "Option $argname for [Get_caller] must be one of the listed values:\n [join $choices "\n "]\n$casemsg$prefixmsg. Received: '$e'" $argspecs $argname } } } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm index 206b560b..1e4de9ec 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/config-0.1.tm @@ -362,10 +362,11 @@ tcl::namespace::eval punk::config { proc configure {args} { set argd [punk::args::get_dict { - - whichconfig -type string -choices {startup running} + *values -min 1 -max 1 + whichconfig -type string -choices {startup running stop} } $args] + return "unimplemented - $argd" } proc show {whichconfig {globfor *}} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm index 95ecb27d..001a7653 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm @@ -44,6 +44,7 @@ #[list_begin itemized] package require Tcl 8.6- +package require Thread ;#tsv required to sync is_raw package require punk::ansi #*** !doctools #[item] [package {Tcl 8.6-}] @@ -84,7 +85,12 @@ namespace eval punk::console { variable previous_stty_state_stdin "" variable previous_stty_state_stdout "" variable previous_stty_state_stderr "" - variable is_raw 0 + + #variable is_raw 0 + if {![tsv::exists console is_raw]} { + tsv::set console is_raw 0 + } + variable input_chunks_waiting if {![info exists input_chunks_waiting(stdin)]} { set input_chunks_waiting(stdin) [list] @@ -183,7 +189,8 @@ namespace eval punk::console { #NOTE - the is_raw is only being set in current interp - but the channel is shared. #this is problematic with the repl thread being separate. - must be a tsv? REVIEW proc enableRaw {{channel stdin}} { - variable is_raw + #variable is_raw + variable previous_stty_state_$channel set sttycmd [auto_execok stty] if {[set previous_stty_state_$channel] eq ""} { @@ -193,21 +200,21 @@ namespace eval punk::console { } exec {*}$sttycmd raw -echo <@$channel - set is_raw 1 + tsv::set console is_raw 1 return [dict create previous [set previous_stty_state_$channel]] } proc disableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel set sttycmd [auto_execok stty] if {[set previous_stty_state_$channel] ne ""} { exec {*}$sttycmd [set previous_stty_state_$channel] set previous_stty_state_$channel "" - set is_raw 0 + tsv::set console is_raw 0 return restored } exec {*}$sttycmd -raw echo <@$channel - set is_raw 0 + tsv::set console is_raw 0 return done } proc enableVirtualTerminal {{channels {input output}}} { @@ -249,11 +256,11 @@ namespace eval punk::console { } proc mode {{raw_or_line query}} { - variable is_raw + #variable is_raw variable ansi_available set raw_or_line [string tolower $raw_or_line] if {$raw_or_line eq "query"} { - if {$is_raw} { + if {[tsv::get console is_raw]} { return "raw" } else { return "line" @@ -493,7 +500,7 @@ namespace eval punk::console { } proc [namespace parent]::enableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel if {[package provide twapi] ne ""} { @@ -506,7 +513,7 @@ namespace eval punk::console { #set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]] set newmode [twapi::get_console_input_mode] - set is_raw 1 + tsv::set console is_raw 1 #don't disable handler - it will detect is_raw ### twapi::set_console_control_handler {} return [list stdin [list from $oldmode to $newmode]] @@ -516,7 +523,7 @@ namespace eval punk::console { } exec {*}$sttycmd raw -echo <@$channel - set is_raw 1 + tsv::set console is_raw 1 #review - inconsistent return dict return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]] } else { @@ -528,7 +535,7 @@ namespace eval punk::console { #could be we were missing a step in reopening stdin and console configuration? proc [namespace parent]::disableRaw {{channel stdin}} { - variable is_raw + #variable is_raw variable previous_stty_state_$channel if {[package provide twapi] ne ""} { @@ -537,7 +544,7 @@ namespace eval punk::console { # Turn on the echo and line-editing bits twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1 set newmode [twapi::get_console_input_mode] - set is_raw 0 + tsv::set console is_raw 0 return [list stdin [list from $oldmode to $newmode]] } elseif {[set sttycmd [auto_execok stty]] ne ""} { #stty can return info on windows - but doesn't seem to be able to set anything. @@ -550,7 +557,7 @@ namespace eval punk::console { return restored } exec {*}$sttycmd -raw echo <@$channel - set is_raw 0 + tsv::set console is_raw 0 #do we really want to exec stty yet again to show final 'to' state? #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states. return [list stdin [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]] @@ -634,7 +641,7 @@ namespace eval punk::console { puts -nonewline $output $query;flush $output #todo - test and save rawstate so we don't disableRaw if console was already raw - if {!$::punk::console::is_raw} { + if {![tsv::get console is_raw]} { set was_raw 0 punk::console::enableRaw } else { @@ -1378,7 +1385,7 @@ namespace eval punk::console { #todo - compare speed with get_cursor_pos - work out why the big difference proc test_cursor_pos {} { - if {!$::punk::console::is_raw} { + if {![tsv::get console is_raw]} { set was_raw 0 enableRaw } else { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm index 1e1986e6..9f74d2d5 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/du-0.1.0.tm @@ -1065,56 +1065,65 @@ namespace eval punk::du { #note - with this design, we can't glob for all except dotfiles - this is for cross-platform consistency and efficiency (Review). #dotfiles aren't considered hidden on all platforms #some sort of antiglob is a possible enhancement and more consistent with the view that leading dot should be treated as any other filename character in this context. - if {$opt_glob eq "*"} { - #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' - #set parent [lindex $folders $folderidx] - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] - #set hdirs {} - set dirs [glob -nocomplain -dir $folderpath -types d * .*] - - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] - #set hlinks {} - set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. struct::set difference will remove (?) - #set links [lsort -unique [concat $hlinks $links[unset links]]] - - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] - #set hfiles {} - set files [glob -nocomplain -dir $folderpath -types f * .*] - #set files {} - } else { - set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + if {"windows" eq $::tcl_platform(platform)} { + if {$opt_glob eq "*"} { + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #set parent [lindex $folders $folderidx] + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] + + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique - set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove (?) + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} * .*] + set files [glob -nocomplain -dir $folderpath -types f * .*] + } else { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } + } else { + set hdirs {} + set hfiles {} + set hlinks {} + if {$opt_glob eq "*"} { + #Note - glob operations seem to be faster than looped tests like 'file isdirectory' & 'file readlink' + #set parent [lindex $folders $folderidx] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + set files [glob -nocomplain -dir $folderpath -types f * .*] + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. punk::lib::struct_set_diff_unique + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } - set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #note struct::set difference produces unordered result #struct::set difference removes duplicates (but not always.. e.g if using tcl impl and 2nd element empty!) - #relying on struct::set to remove dupes is somewhat risky. It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets' + #relying on struct::set to remove dupes is somewhat risky. + #It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets' ie lists without dupes + #for this reason we must use the wrapper punk::lib::struct_set_diff_unique, which will use the well behaved critcl for speed if avail, but fall back to a deduping tcl version #remove links and . .. from directories, remove links from files #ideally we would like to classify links by whether they point to files vs dirs - but there are enough cross-platform differences that we will have to leave it to the caller to sort out for now. #struct::set will affect order: tcl vs critcl give different ordering! - set files [struct::set difference [concat $hfiles $files[unset files]] $links] - set dirs [struct::set difference [concat $hdirs $dirs[unset dirs]] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - #set links [lsort -unique [concat $links $hlinks]] + set files [punk::lib::struct_set_diff_unique [list {*}$hfiles {*}$files[unset files]] $links] + set dirs [punk::lib::struct_set_diff_unique [list {*}$hdirs {*}$dirs[unset dirs] ] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]] #---- set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] - - if {"windows" eq $::tcl_platform(platform)} { - set flaggedhidden [concat $hdirs $hfiles $hlinks] - } else { - #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden - #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden - set flaggedhidden {} - } + set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks] + #unix dotted files/folders are not 'flagged' as such - it's a convention - so the client can use the same convention to decide if something is hidden + #this allows us to return less data - but more importantly - reserve flaggedhidden for systems where such a flag exists and avoid conflating the different concepts of what is hidden set vfsmounts [get_vfsmounts_in_folder $folderpath] @@ -1223,21 +1232,21 @@ namespace eval punk::du { #if {[punk::mix::base::lib::path_a_above_b $folderpath "//zipfs:/"]} {} - #zipfs files also reported as links by glob - review - should we preserve this in response? + #todo - hidden? not returned in attributes on windows at least. + #zipfs files also reported as links by glob - review - should we preserve this in response? (2024 unable to duplicate) if {$opt_glob eq "*"} { set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - #set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set links [list] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files } else { set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - #set links [glob -nocomplain -dir $folderpath -types l $opt_glob] - set links [list] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..]]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] #nested vfs mount.. REVIEW - does anything need special handling? @@ -1300,34 +1309,63 @@ namespace eval punk::du { } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + #at least some vfs on windows seem to support the -hidden attribute + #we are presuming glob will accept the -types hidden option for all vfs - even if it doesn't really apply REVIEW + #The extra globs aren't nice - but hopefully the vfs is reasonably performant (?) set errors [dict create] - if {$opt_glob eq "*"} { - set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs - #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? - set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove - set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + if {"windows" eq $::tcl_platform(platform)} { + if {$opt_glob eq "*"} { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} * .*] + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set hfiles [glob -nocomplain -dir $folderpath -types {hidden l} * .*] + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set hdirs [glob -nocomplain -dir $folderpath -types {hidden d} $opt_glob] + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } } else { - set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] - set links [glob -nocomplain -dir $folderpath -types l $opt_glob] - set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + #we leave it to the ui on unix to classify dotfiles as hidden + set hdirs {} + set hfiles {} + set hlinks {} + if {$opt_glob eq "*"} { + set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs + #review - how are links handled in vfs? presumably if the vfs is a full implementation they should work at least within the vfs? + set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove + set files [glob -nocomplain -dir $folderpath -types f * .*] ;# also returns links to files + } else { + set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob] + set links [glob -nocomplain -dir $folderpath -types l $opt_glob] + set files [glob -nocomplain -dir $folderpath -types f $opt_glob] + } } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] #nested vfs mount.. REVIEW - does anything need special handling? set vfsmounts [get_vfsmounts_in_folder $folderpath] set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] + set flaggedhidden [list {*}$hdirs {*}$hfiles {*}$hlinks] set effective_opts $opts dict set effective_opts -with_times $timed_types dict set effective_opts -with_sizes $sized_types - return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden {} flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] + return [list dirs $dirs vfsmounts $vfsmounts links $links files $files filesizes [dict get $mdata_lists fsizes] sizes [dict get $mdata_lists allsizes] times [dict get $mdata_lists alltimes] flaggedhidden $flaggedhidden flaggedsystem {} flaggedreadonly {} altname {} opts $effective_opts errors $errors] } #we can halve the number of round trips on unix-like systems, where 'hidden' always corresponds to dotted files + #but we don't classify as such anyway. (leave for UI) proc du_dirlisting_unix {folderpath args} { set defaults [dict create\ -glob *\ @@ -1379,6 +1417,9 @@ namespace eval punk::du { } #this is not consistent with standard way * works for unix folders - but it is consistent with behaviour of this facility on windows + #we don't classify anything as 'flaggedhidden' on unix. + #it is a convention for dotfiles rather than a flag - and we'll leave the distinction for the display library + #This if {$opt_glob eq "*"} { set dirs [glob -nocomplain -dir $folderpath -types d * .*] ;# also returns links to dirs set links [glob -nocomplain -dir $folderpath -types l * .*] ;# links may have dupes - we don't care. struct::set difference will remove @@ -1389,8 +1430,9 @@ namespace eval punk::du { set files [glob -nocomplain -dir $folderpath -types f $opt_glob] } #remove any links from our dirs and files collections - set dirs [struct::set difference $dirs[unset dirs] [concat $links [list [file join $folderpath .] [file join $folderpath ..] ]]] - set files [struct::set difference $files[unset files] $links] + #see du_dirlisting_generic re struct::set difference issues + set dirs [punk::lib::struct_set_diff_unique $dirs[unset dirs] [list {*}$links [file join $folderpath .] [file join $folderpath ..] ]] + set files [punk::lib::struct_set_diff_unique $files[unset files] $links] set vfsmounts [get_vfsmounts_in_folder $folderpath] set mdata_lists [du_get_metadata_lists $sized_types $timed_types $files $dirs $links] @@ -1406,7 +1448,7 @@ namespace eval punk::du { #return fsizes,allsizes,alltimes metadata in same order as files,dirs,links lists - if specified in sized_types proc du_get_metadata_lists {sized_types timed_types files dirs links} { set meta_dict [dict create] - set meta_types [concat $sized_types $timed_types] + set meta_types [list {*}$sized_types {*}$timed_types] #known tcl stat keys 2023 - review set empty_stat_dict [dict create atime {} ctime {} dev {} gid {} ino {} mode {} mtime {} nlink {} size {} type {} uid {}] #make sure we call file stat only once per item @@ -1419,6 +1461,7 @@ namespace eval punk::du { if {![catch {file stat $path arrstat} errM]} { dict set meta_dict $path [dict create shorttype $ft {*}[array get arrstat]] } else { + puts stderr "du_get_metadata_lists: file stat $path error: $errM" dict lappend errors $path "file stat error: $errM" dict set meta_dict $path [dict create shorttype $ft {*}$empty_stat_dict] } @@ -1437,6 +1480,9 @@ namespace eval punk::du { if {$ft eq "f"} { #subst with na if empty? lappend fsizes [dict get $pathinfo size] + if {[dict get $pathinfo size] eq ""} { + puts stderr "du_get_metadata_lists: fsize $path is empty!" + } } } if {$ft in $timed_types} { @@ -1446,7 +1492,7 @@ namespace eval punk::du { #todo - fix . The list lengths will presumably match but have empty values if failed to stat if {"f" in $sized_types} { if {[llength $fsizes] ne [llength $files]} { - dict lappend errors $folderpath "failed to retrieve all file sizes" + dict lappend errors general "failed to retrieve all file sizes" } } return [dict create fsizes $fsizes allsizes $allsizes alltimes $alltimes] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm index 7e1ee14c..22178177 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -290,7 +290,6 @@ namespace eval punk::fileline::class { -showconfig 0\ -boundaryheader {Boundary %i% at %b%}\ ] - set known_opts [dict keys $defaults] foreach {k v} $args { switch -- $k { -ansi - -offset - -displaybytes - -truncatedmark - -completemark - -moremark - -continuemark - -linemaxwidth - -linebase - -limit - -boundaries - -showconfig - -boundaryheader { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm index 8f51075e..070621bc 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -339,6 +339,144 @@ namespace eval punk::lib { set has_twapi [expr {![catch {package require twapi}]}] } + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + # Maintenance - This is the primary source for tm_version... functions + # - certain packages script require these but without package dependency + # - 1 punk boot script + # - 2 packagetrace module + # - These should be updated to sync with this + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + 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 "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 {![tm_version_isvalid $from]} { + error "$errmsg '$versionpec'" + } + if {![catch {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 {![tm_version_isvalid $from]} { + error "$errmsg '$versionspec'" + } + set from [tm_version_canonical $from] + if {[llength $parts] == 2} { + if {$to ne ""} { + if {![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" + } + } + # end tm_version... functions + # == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == == + + + # -- --- #https://stackoverflow.com/questions/17631269/whats-the-best-way-to-join-two-lists #DKF's 2013 recommendation of using list {*}$first {*}$second seems not to apply in 2024 @@ -1575,8 +1713,20 @@ namespace eval punk::lib { lremove $fromlist {*}$doomed } + #fix for tcl impl of struct::set::diff which doesn't dedupe + proc struct_set_diff_unique {A B} { + package require struct::set ;#require even if tcl impl - so the dependency isn't missed accidentally due to Loaded state of programmers machine. + if {[struct::set::Loaded] eq "tcl"} { + return [punk::lib::setdiff $A $B] + } else { + #use (presumably critcl) implementation for speed + return [struct::set difference $A $B] + } + } + + #non-dupe preserving - for consistency in dedupe behaviour we don't shortcircuit empty B - #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference + #consistent dedupe and order-maintenance of remaining items in A differentiate this from struct::set difference (dedupes with critcl, doesn't with tcl implementation 2024) #also struct::set difference with critcl is faster proc setdiff {A B} { if {[llength $A] == 0} {return {}} @@ -2387,7 +2537,7 @@ namespace eval punk::lib { set stdin_state [fconfigure stdin] if {[catch { package require punk::console - set console_raw [set ::punk::console::is_raw] + set console_raw [tsv::get console is_raw] } err_console]} { #assume normal line mode set console_raw 0 @@ -3032,6 +3182,11 @@ namespace eval punk::lib { proc objclone {obj} { append obj2 $obj {} } + proc set_clone {varname obj} { + #used by repl's codeinterp. Maintains internal rep, easier to call e.g interp eval code [list punk::set_clone varnmame $val] + append obj2 $obj {} + uplevel 1 [list set $varname $obj2] + } @@ -3175,7 +3330,7 @@ tcl::namespace::eval punk::lib::system { #[para] Internal functions that are not part of the API #[list_begin definitions] - proc has_script_var_bug {} { + proc has_tclbug_script_var {} { set script {set j [list spud] ; list} append script \n uplevel #0 $script @@ -3194,7 +3349,15 @@ tcl::namespace::eval punk::lib::system { return false } } - proc has_safeinterp_compile_bug {{show 0}} { + + proc has_tclbug_list_quoting_emptyjoin {} { + #https://core.tcl-lang.org/tcl/tktview/e38dce74e2 + set v1 [list {*}[lindex #foo] {*}[]] ;#can return "#foo" instead of "{#foo}" under some beta 9 releases + set v2 [list #foo] ;#normal tcl list quoting for 1st element that looks like a comment -> "{#foo}" + return [expr {![string equal $v1 $v2]}] ;#if they're not equal - we have the bug. + } + + proc has_tclbug_safeinterp_compile {{show 0}} { #ensemble calls within safe interp not compiled namespace eval [namespace current]::testcompile { proc ensembletest {} {string index a 0} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm index 806b172e..dfdc71f9 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -473,13 +473,26 @@ namespace eval punk::mix::base { #set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names zlib adler32 $data } - #zlib crc vie file-slurp + #zlib crc via file-slurp proc cksum_crc_file {filename} { package require zlib set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] zlib crc $data } + proc cksum_md5_data {data} { + if {[package vsatisfies [package present md5] 2-]} { + return [md5::md5 -hex $data] + } else { + return [md5::md5 $data] + } + } + #fallback md5 via file-slurp - shouldn't be needed if have md5 2- + proc cksum_md5_file {filename} { + set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] + cksum_md5_data $data + } + #required to be able to accept relative paths #for full cksum - using tar could reduce number of hashes to be made.. @@ -624,7 +637,11 @@ namespace eval punk::mix::base { } md5 { package require md5 - set cksum_command [list md5::md5 -hex -file] + if {[package vsatisfies [package present md5] 2- ] } { + set cksum_command [list md5::md5 -hex -file] + } else { + set cksum_comand [list cksum_md5_file] + } } cksum { package require cksum ;#tcllib @@ -637,7 +654,7 @@ namespace eval punk::mix::base { set cksum_command [list cksum_adler32_file] } sha3 - sha3-256 { - #todo - replace with something that doesn't call another process + #todo - replace with something that doesn't call another process - only if tcllibc not available! #set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] set cksum_command [list $sha3_implementation 256] } @@ -684,7 +701,7 @@ namespace eval punk::mix::base { set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)" } set tsstart [clock millis] - puts -nonewline stdout "cksum_path: calculating cksum for $target $sizeinfo ... " + puts -nonewline stdout "cksum_path: calculating cksum using $opt_cksum_algorithm for $target $sizeinfo ... " set cksum [{*}$cksum_command $archivename] set tsend [clock millis] set ms [expr {$tsend - $tsstart}] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm index 856c9340..1d8d40e1 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/doc-0.1.0.tm @@ -271,7 +271,12 @@ namespace eval punk::mix::commandset::doc { #this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. #review - if we're checking fname - should also test length of whole path and determine limits for tar package require md5 - set target_docname [md5::md5 -hex [encoding convertto utf-8 $fullpath]]_overlongfilename.man + if {[package vsatisfies [package present md5] 2- ] } { + set md5opt "-hex" + } else { + set md5opt "" + } + set target_docname [md5::md5 {*}$md5opt [encoding convertto utf-8 $fullpath]]_overlongfilename.man puts stderr "WARNING - overlong file name - renaming $fullpath" puts stderr " to [file dirname $fullpath]/$target_docname" } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm index aca7eeed..d1459369 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/util-0.1.0.tm @@ -261,6 +261,8 @@ namespace eval punk::mix::util { return } + # review punk::lib::tm_version.. functions + proc is_valid_tm_version {versionpart} { #Needs to be suitable for use with Tcl's 'package vcompare' if {![catch [list package vcompare $versionpart $versionpart]]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm index 426271a7..9cf44529 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/nav/fs-0.1.0.tm @@ -821,9 +821,12 @@ tcl::namespace::eval punk::nav::fs { set match_contents $opt_tailglob } } - puts stdout "searchbase: $searchbase searchspec:$searchspec" + #puts stdout "searchbase: $searchbase searchspec:$searchspec" - set in_vfs 0 + + #file attr //cookit:/ returns {-vfs 1 -handle {}} + #we will treat it differently for now - use generic handler REVIEW + set in_vfs 0 ;#we use this only for a vfs which is reported to have a mountpoint by vfs::filesystem info - not all that have -vfs 1 attr like cookit. if {[llength [package provide vfs]]} { foreach mount [vfs::filesystem info] { if {[punk::mix::base::lib::path_a_atorbelow_b $location $mount]} { @@ -849,22 +852,45 @@ tcl::namespace::eval punk::nav::fs { set listing [punk::du::lib::du_dirlisting_tclvfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } else { set in_zipfs 0 - if {[info commands ::tcl::zipfs::mount] ne ""} { - if {[string match //zipfs:/* $location]} { - set in_zipfs 1 + set in_cookit 1 + set in_other_pseudovol 1 + switch -glob -- $location { + //zipfs:/* { + if {[info commands ::tcl::zipfs::mount] ne ""} { + set in_zipfs 1 + } + } + //cookit:/* { + set in_cookit 1 + } + default { + #handle 'other/unknown' that mounts at a volume-like path //pseudovol:/ + if {[regexp {//((?:(?!:|/).)+):/.*} $location _match pseudovol]} { + #pseudovol probably more than one char long + #we don't really expect something like //c:/ , but anyway, it's not the same as c:/ and for all we know someone could use that as a volume name? + set in_other_pseudovol 1 ;#flag so we don't use twapi - hope generic can handle it (uses tcl glob) + } else { + #we could use 'file attr' here to test if {-vfs 1} + #but it's an extra filesystem hit on all normal paths too (which can be expensive on some systems) + #instead for now we'll assume any reasonable vfs should have been found by vfs::filesystem::info or mounted as a pseudovolume + } + } - #dict for {zmount zpath} [zipfs mount] { - # if {[punk::mix::base::lib::path_a_atorbelow_b $location $zmount]} { - # set in_zipfs 1 - # break - # } - #} } + if {$in_zipfs} { #relative vs absolute? review - cwd valid for //zipfs:/ ?? - set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + set listing [punk::du::lib::du_dirlisting_zipfs $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + } elseif {$in_cookit} { + #seems to be a vfs - except it mounts on a pseudo-volume path //cookit:/ + #don't use twapi + #could possibly use du_dirlisting_tclvfs REVIEW + #files and folders are all returned with the -types hidden option for glob on windows + set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + } elseif {$in_other} { + set listing [punk::du::lib::du_dirlisting_generic $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } else { - set listing [punk::du::dirlisting $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] + set listing [punk::du::dirlisting $location -glob $match_contents {*}$next_opt_with_sizes {*}$next_opt_with_times] } } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm index d950eab4..e38c76c6 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/packagepreference-0.1.0.tm @@ -155,18 +155,26 @@ tcl::namespace::eval punk::packagepreference { if {[lindex $args 1] eq "-exact"} { set pkg [lindex $args 2] set vwant [lindex $args 3] - if {[set ver [package provide $pkg]] ne ""} { - if {$ver eq $vwant} { - return $vwant - } else { - #package already provided with a different version.. we will defer to underlying implementation to return the standard error - return [$COMMANDSTACKNEXT {*}$args] - } + if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { + #although we could shortcircuit using vsatisfies to return the ver + #we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. + return [$COMMANDSTACKNEXT {*}$args] + + #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} { + # return $ver + #} else { + # #package already provided with a different version.. we will defer to underlying implementation to return the standard error + # return [$COMMANDSTACKNEXT {*}$args] + #} } } else { set pkg [lindex $args 1] - if {[set ver [package provide $pkg]] ne ""} { - return $ver + set vwant [lindex $args 2] + if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { + return [$COMMANDSTACKNEXT {*}$args] + #if {$vwant eq "" || [$COMMANDSTACKNEXT vsatisfies $ver $vwant]} { + # return $ver + #} } } if {[regexp {[A-Z]} $pkg]} { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm index 09b8a0be..39b5bf78 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repl/codethread-0.1.0.tm @@ -20,12 +20,12 @@ #*** !doctools #[manpage_begin shellspy_module_punk::repl::codethread 0 0.1.0] #[copyright "2024"] -#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] -#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[titledesc {Module repl codethread}] [comment {-- Name section and table of contents description --}] +#[moddesc {codethread for repl - root interpreter}] [comment {-- Description at end of page heading --}] #[require punk::repl::codethread] -#[keywords module] +#[keywords module repl] #[description] -#[para] - +#[para] This is part of the infrastructure required for the punk::repl to operate # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -131,11 +131,14 @@ tcl::namespace::eval punk::repl::codethread { # return "ok" #} + variable run_command_cache + proc is_running {} { variable running return $running } proc runscript {script} { + #puts stderr "->runscript" variable replthread_cond variable output_stdout "" @@ -169,9 +172,18 @@ tcl::namespace::eval punk::repl::codethread { #set errhandle [shellfilter::stack::item_tophandle stderr] #interp transfer "" $errhandle code - set scope [interp eval code [list set ::punk::ns::ns_current]] set status [catch { - interp eval code [list tcl::namespace::inscope $scope $script] + #shennanigans to keep compiled script around after call. + #otherwise when $script goes out of scope - internal rep of vars set in script changes. + #The shimmering may be no big deal(?) - but debug/analysis using tcl::unsupported::representation becomes impossible. + interp eval code [list ::punk::lib::set_clone ::codeinterp::clonescript $script] ;#like objclone + interp eval code { + lappend ::codeinterp::run_command_cache $::codeinterp::clonescript + if {[llength $::codeinterp::run_command_cache] > 2000} { + set ::codeinterp::run_command_cache [lrange $::codeinterp::run_command_cache 1750 end][unset ::codeinterp::run_command_cache] + } + tcl::namespace::inscope $::punk::ns::ns_current $::codeinterp::clonescript + } } result] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm index 4e0217b0..bc93a9c3 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -27,6 +27,11 @@ # # path/repo functions # + +#REVIEW punk::repo required early by punk boot script to find projectdir +#todo - split off basic find_project chain of functions to a smaller package and import as necessary here +#Then we can reduce early dependencies in punk boot + if {$::tcl_platform(platform) eq "windows"} { package require punk::winpath } else { diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm index 96fb263d..b822b353 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textblock-0.1.1.tm @@ -5280,8 +5280,8 @@ tcl::namespace::eval textblock { It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" *values -min 1 -max 1 frametype -help "name from the predefined frametypes: - or an adhoc - }] + or an adhoc " + }] append spec \n "frametype -help \"A predefined \"" punk::args::get_dict $spec $args return @@ -6804,7 +6804,11 @@ tcl::namespace::eval textblock { if {$use_md5} { #package require md5 ;#already required at package load - set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review + if {[package vsatisfies [package present md5] 2- ] } { + set hash [md5::md5 -hex [encoding convertto utf-8 $hashables]] ;#need fast and unique to content - not cryptographic - review + } else { + set hash [md5::md5 [encoding convertto utf-8 $hashables]] + } } else { set hash $hashables } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textutil-0.9.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textutil-0.9.tm index 59258514..b18a5228 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textutil-0.9.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/textutil-0.9.tm @@ -16,7 +16,7 @@ # ### ### ### ######### ######### ######### ## Requirements -package require Tcl 8.2 +package require Tcl 8.2- namespace eval ::textutil {} diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl index 24206ba7..f6ade4c4 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl @@ -1,13 +1,19 @@ # tcl # -#make any tclkits and modules in src and place them and associated data files/scripts in the parent folder of src. +# punkboot - make any tclkits and modules in /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. - set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" puts $hashline -puts " punkshell make script " +puts " Punk Boot" puts $hashline\n -namespace eval ::punkmake { + +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] @@ -15,6 +21,139 @@ namespace eval ::punkmake { variable help_flags [list -help --help /?] variable known_commands [list project modules 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 @@ -23,30 +162,96 @@ if {"::try" ni [info commands ::try]} { #------------------------------------------------------------------------------ #Module loading from src/bootsupport or [pwd]/modules if pwd is a 'src' folder #------------------------------------------------------------------------------ -#If the there is a folder under the current directory /src/bootsupport/modules which contains .tm files +#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 make script +# 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]]} { - set bootsupport_mod [file join $startdir src bootsupport modules] - set bootsupport_lib [file join $startdir src bootsupport lib] + lappend bootsupport_module_paths [file join $startdir src bootsupport modules] + lappend bootsupport_library_paths [file join $startdir src bootsupport lib] } else { - set bootsupport_mod [file join $startdir bootsupport modules] - set bootsupport_lib [file join $startdir bootsupport lib] + lappend bootsupport_module_paths [file join $startdir bootsupport modules] + lappend bootsupport_library_paths [file join $startdir bootsupport lib] +} +set bootsupport_paths_exist 0 +foreach p [list {*}$bootsupport_module_paths {*}$bootsupport_library_paths] { + if {[file exists $p]} { + set bootsupport_paths_exist 1 ;#at least one exists + break + } } +# ------------------------------------------------------------------------------------- +# ------------------------------------------------------------------------------------- +set sourcesupport_module_paths [list] +set sourcesupport_library_paths [list] +set sourcesupport_paths_exist 0 +#we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir. +#The /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] { + if {[file exists $p]} { + lappend sourcesupport_module_paths $p + } + } + # -- -- -- + foreach p [list $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 /modules are the very modules we are building - and may be in a broken state, which make.tcl then can't fix. - if {[file tail $startdir] eq "src"} { - if {[file exists $startdir/modules]} { - #launch from .' (minbounded) as .- 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]\ + overtype [list version "1.6.5-"]\ + punkcheck [list]\ + 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}]\ +] + # ** *** *** *** *** *** *** *** *** *** *** *** -#*temporarily* hijack package command +# 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. # ** *** *** *** *** *** *** *** *** *** *** *** -try { - rename ::package ::punkmake::package_temp_aside - proc ::package {args} { - if {[lindex $args 0] eq "require"} { - lappend ::punkmake::pkg_requirements [lindex $args 1] +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 .. + 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] } } - package require punk::mix - package require punk::repo - package require punk::ansi - package require overtype -} finally { - catch {rename ::package ""} - catch {rename ::punkmake::package_temp_aside ::package} + + #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 } -# ** *** *** *** *** *** *** *** *** *** *** *** -foreach pkg $::punkmake::pkg_requirements { - if {[catch {package require $pkg} errM]} { - puts stderr "missing pkg: $pkg" - lappend ::punkmake::pkg_missing $pkg - } else { - lappend ::punkmake::pkg_loaded $pkg + + +#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)} ... -proc punkmake_gethelp {args} { set scriptname [file tail [info script]] append h "Usage:" \n append h "" \n @@ -138,12 +1028,15 @@ proc punkmake_gethelp {args} { 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 processes running as the executable being built (if applicable)" \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 /modules /lib etc." \n \n append h " $scriptname modules" \n - append h " - build modules from src/modules etc without scanning src/runtime and src/vfs folders to build kit/zipkit executables" \n \n + append h " - build modules from src/modules src/vendormodules etc to their corresponding locations under " \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//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 /modules /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 @@ -154,24 +1047,51 @@ proc punkmake_gethelp {args} { append h " $scriptname info" \n append h " - show the name and base folder of the project to be built" \n append h "" \n - if {[llength $::punkmake::pkg_missing]} { - append h "* ** NOTE ** ***" \n - append h " punkmake has detected that the following packages could not be loaded:" \n - append h " " [join $::punkmake::pkg_missing "\n "] \n - append h "* ** *** *** ***" \n - append h " These packages are required for punk make to function" \n \n - append h "* ** *** *** ***" \n\n - append h "Successfully Loaded packages:" \n - append h " " [join $::punkmake::pkg_loaded "\n "] \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 $::punkmake::help_flags { + foreach h $::punkboot::help_flags { if {[lsearch $scriptargs $h] >= 0} { set do_help 1 break @@ -183,23 +1103,32 @@ foreach a $scriptargs { if {![string match -* $a]} { lappend commands_found $a } else { - if {$a ni $::punkmake::non_help_flags} { + 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 $::punkmake::known_commands} { +} 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 stderr [punkmake_gethelp] + 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 ::punkmake::command [lindex $commands_found 0] +set ::punkboot::command [lindex $commands_found 0] if {[lsearch $::argv -k] >= 0} { @@ -210,7 +1139,7 @@ if {[lsearch $::argv -k] >= 0} { #puts stdout "::argv $::argv" # ---------------------------------------- -set scriptfolder $::punkmake::scriptfolder +set scriptfolder $::punkboot::scriptfolder @@ -218,21 +1147,25 @@ set scriptfolder $::punkmake::scriptfolder #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 "punkmake 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 "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 punkmake script operating in project space that is not under version control" + puts stderr "WARNING punkboot script operating in project space that is not under version control" } } else { } set sourcefolder $projectroot/src -if {$::punkmake::command eq "check"} { +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]} { @@ -249,25 +1182,87 @@ if {$::punkmake::command eq "check"} { 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] - puts stdout "punk::mix::base version $v\n[package ifneeded punk::mix::base $v]" - exit 0 -} + #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} { - #restore module paths and auto_path in addition to the bootsupport ones 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] + #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 {$::punkmake::command eq "info"} { +if {$::punkboot::command eq "info"} { puts stdout "- -- --- --- --- --- --- --- --- --- -- -" puts stdout "- -- info -- -" puts stdout "- -- --- --- --- --- --- --- --- --- -- -" @@ -318,16 +1313,23 @@ if {$::punkmake::command eq "info"} { exit 0 } -if {$::punkmake::command eq "shell"} { + + + +if {$::punkboot::command eq "shell"} { package require punk package require punk::repl - puts stderr "make shell not fully implemented - dropping into ordinary punk shell" + 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 {$::punkmake::command eq "vfscommonupdate"} { +if {$::punkboot::command eq "vfscommonupdate"} { puts "projectroot: $projectroot" puts "script: [info script]" puts stdout "Updating vfs/_vfscommon" @@ -362,7 +1364,7 @@ if {$::punkmake::command eq "vfscommonupdate"} { ::exit 0 } -if {$::punkmake::command eq "vendorupdate"} { +if {$::punkboot::command eq "vendorupdate"} { puts "projectroot: $projectroot" puts "script: [info script]" #puts "-- [tcl::tm::list] --" @@ -479,7 +1481,7 @@ if {$::punkmake::command eq "vendorupdate"} { ::exit 0 } -if {$::punkmake::command eq "bootsupport"} { +if {$::punkboot::command eq "bootsupport"} { puts "projectroot: $projectroot" puts "script: [info script]" #puts "-- [tcl::tm::list] --" @@ -635,8 +1637,8 @@ if {$::punkmake::command eq "bootsupport"} { -if {$::punkmake::command ni {project modules}} { - puts stderr "Command $::punkmake::command not implemented - aborting." +if {$::punkboot::command ni {project modules}} { + puts stderr "Command $::punkboot::command not implemented - aborting." flush stderr after 100 exit 1 @@ -874,7 +1876,7 @@ if {[punk::repo::is_fossil_root $projectroot]} { $installer destroy } -if {$::punkmake::command ne "project"} { +if {$::punkboot::command ne "project"} { #command = modules puts stdout "vfs folders not checked" puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into base vfs folder" @@ -1027,6 +2029,13 @@ foreach runtime [dict keys $runtime_vfs_map] { 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 } @@ -1092,7 +2101,7 @@ foreach runtimefile $runtimes { # -- --- --- --- --- --- puts stdout "Copying runtime from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" if {[catch { - file copy -force $rtfolder/$runtimefile $buildfolder/build_$runtimefile + 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 @@ -1101,7 +2110,7 @@ foreach runtimefile $runtimes { } # -- --- --- --- --- --- } else { - puts stderr "." + puts stderr "unchanged: $runtimefile" $event targetset_end SKIPPED } $event end @@ -1119,7 +2128,8 @@ proc ::make_file_traversal_error {args} { } proc merge_over {sourcedir targetdir} { package require fileutil - package require fileutil::traverse + set ver [package require fileutil::traverse] + puts stdout "using fileutil::traverse $ver\n[package ifneeded fileutil::traverse $ver]" package require control if {![file exists $sourcedir]} { @@ -1150,6 +2160,11 @@ proc merge_over {sourcedir targetdir} { if {![file exists $target]} { #puts stdout "-- mkdir $target" puts stdout "$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 { @@ -1293,11 +2308,13 @@ foreach vfstail $vfs_tails { $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon $vfs_event targetset_addsource $sourcefolder/vfs/$vfstail if {$rtname ne "-"} { - $vfs_event targetset_addsource $buildfolder/build_$runtime_fullname ;#working copy of runtime executable + set building_runtime $buildfolder/build_$runtime_fullname ;#working copy of runtime executable + $vfs_event targetset_addsource $building_runtime + } else { + set building_runtime "-" ;#REVIEW } # -- ---------- - set rtmountpoint //zipfs:/rtmounts/$runtime_fullname 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]]}] @@ -1319,18 +2336,31 @@ foreach vfstail $vfs_tails { set targetvfs $buildfolder/buildvfs_$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 { #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 $buildfolder/build_$runtime_fullname rtmounts/$runtime_fullname + tcl::zipfs::mount $building_runtime rtmounts/$runtime_fullname } errM]} { - tcl::zipfs::mount rtmounts/$runtime_fullname $buildfolder/build_$runtime_fullname + 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?" + } } } @@ -1341,6 +2371,34 @@ foreach vfstail $vfs_tails { merge_over $sourcefolder/vfs/_vfscommon $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 /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 $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. @@ -1358,9 +2416,14 @@ foreach vfstail $vfs_tails { merge_over $sourcevfs $targetvfs #set wrapvfs $sourcefolder/$vfs + set wrapvfs $targetvfs switch -- $kit_type { zip { + 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} { @@ -1373,8 +2436,8 @@ foreach vfstail $vfs_tails { } } #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 \"\" $buildfolder/build_$runtime_fullname" - tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $buildfolder/build_$runtime_fullname + puts stderr "calling: tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs \"\" $building_runtime" + tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $building_runtime } result ]} { set failmsg "zipfs mkimg failed with msg: $result" puts stderr "tcl::zipfs::mkimg $targetkit failed" @@ -1391,6 +2454,52 @@ foreach vfstail $vfs_tails { 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" @@ -1402,7 +2511,7 @@ foreach vfstail $vfs_tails { } else { if {[catch { if {$rtname ne "-"} { - exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose + exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $building_runtime -verbose } else { exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose } @@ -1560,7 +2669,7 @@ foreach vfstail $vfs_tails { if {$built_or_installed_kit_changed} { if {[file exists $deployment_folder/$targetkit]} { - puts stderr "deleting existing deployed at $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]} {