From 3bb49e9f40b7a7b413fcb4f243a8007e764f6dda Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Thu, 3 Oct 2024 05:34:46 +1000 Subject: [PATCH] make.tcl add support cookfs and more pkg diagnosis, modules - add punk::trie - error option prefix display, more fixes --- src/make.tcl | 1299 +++++++++++++++-- src/modules/punk-0.1.tm | 39 +- src/modules/punk/args-999999.0a1.0.tm | 145 +- src/modules/punk/config-0.1.tm | 5 +- src/modules/punk/du-999999.0a1.0.tm | 160 +- src/modules/punk/fileline-999999.0a1.0.tm | 1 - src/modules/punk/lib-999999.0a1.0.tm | 169 ++- src/modules/punk/mix/base-0.1.tm | 25 +- .../punk/mix/commandset/doc-999999.0a1.0.tm | 7 +- .../utility/scriptappwrappers/multishell.cmd | 6 +- src/modules/punk/mix/util-999999.0a1.0.tm | 2 + src/modules/punk/nav/fs-999999.0a1.0.tm | 52 +- .../punk/packagepreference-999999.0a1.0.tm | 26 +- src/modules/punk/repl-0.1.tm | 31 +- .../punk/repl/codethread-999999.0a1.0.tm | 24 +- src/modules/punk/repo-999999.0a1.0.tm | 5 + src/modules/punk/trie-999999.0a1.0.tm | 600 ++++++++ src/modules/punk/trie-buildversion.txt | 3 + src/modules/textblock-999999.0a1.0.tm | 10 +- 19 files changed, 2369 insertions(+), 240 deletions(-) create mode 100644 src/modules/punk/trie-999999.0a1.0.tm create mode 100644 src/modules/punk/trie-buildversion.txt diff --git a/src/make.tcl b/src/make.tcl index 24206ba7..f6ade4c4 100644 --- a/src/make.tcl +++ b/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/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 2d6e61da..4bd8aae0 100644 --- a/src/modules/punk-0.1.tm +++ b/src/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/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index b41c9fb5..f65edd8d 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.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/modules/punk/config-0.1.tm b/src/modules/punk/config-0.1.tm index 206b560b..1e4de9ec 100644 --- a/src/modules/punk/config-0.1.tm +++ b/src/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/modules/punk/du-999999.0a1.0.tm b/src/modules/punk/du-999999.0a1.0.tm index 80bd9ed8..18f75757 100644 --- a/src/modules/punk/du-999999.0a1.0.tm +++ b/src/modules/punk/du-999999.0a1.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/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index 254cea84..f56fd7a2 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/src/modules/punk/fileline-999999.0a1.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/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 2943af5a..eed4de73 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.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 {}} @@ -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/modules/punk/mix/base-0.1.tm b/src/modules/punk/mix/base-0.1.tm index 806b172e..dfdc71f9 100644 --- a/src/modules/punk/mix/base-0.1.tm +++ b/src/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/modules/punk/mix/commandset/doc-999999.0a1.0.tm b/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm index 022f8a9f..62c7edfc 100644 --- a/src/modules/punk/mix/commandset/doc-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/doc-999999.0a1.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/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd index 9de4c125..2975975d 100644 --- a/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd +++ b/src/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd @@ -417,9 +417,9 @@ set -- "$@" "a=[Hide <#;Hide set;s 1 list]"; set -- : "$@";$1 = @' rename set ""; rename s set; set k {-- "$@" "a}; if {[info exists ::env($k)]} {unset ::env($k)} ;# tidyup and restore Hide :exit_multishell;Hide {<#};Hide '@ namespace eval ::punk::multishell { - set last_script_root [file dirname [file normalize ${argv0}/__]] + set last_script_root [file dirname [file normalize ${::argv0}/__]] set last_script [file dirname [file normalize [info script]/__]] - if {[info exists argv0] && + if {[info exists ::argv0] && $last_script eq $last_script_root } { set ::punk::multishell::is_main($last_script) 1 ;#run as executable/script - likely desirable to launch application and return an exitcode @@ -434,7 +434,7 @@ namespace eval ::punk::multishell { if {![info exists ::punk::multishell::is_main($script_name)]} { #e.g a .dll or something else unanticipated puts stderr "Warning punk::multishell didn't recognize info script result: $script_name - will treat as if sourced and return instead of exiting" - puts stderr "Info: script_root: [file dirname [file normalize ${argv0}/__]]" + puts stderr "Info: script_root: [file dirname [file normalize ${::argv0}/__]]" return 0 } return [set ::punk::multishell::is_main($script_name)] diff --git a/src/modules/punk/mix/util-999999.0a1.0.tm b/src/modules/punk/mix/util-999999.0a1.0.tm index 09707d98..4b173831 100644 --- a/src/modules/punk/mix/util-999999.0a1.0.tm +++ b/src/modules/punk/mix/util-999999.0a1.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/modules/punk/nav/fs-999999.0a1.0.tm b/src/modules/punk/nav/fs-999999.0a1.0.tm index fb4fb045..d0af87cc 100644 --- a/src/modules/punk/nav/fs-999999.0a1.0.tm +++ b/src/modules/punk/nav/fs-999999.0a1.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/modules/punk/packagepreference-999999.0a1.0.tm b/src/modules/punk/packagepreference-999999.0a1.0.tm index b2c41970..c51af490 100644 --- a/src/modules/punk/packagepreference-999999.0a1.0.tm +++ b/src/modules/punk/packagepreference-999999.0a1.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/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index 6ad08717..fe55bfd6 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -2062,6 +2062,10 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #/scriptlib/tests/listrep_bug.tcl #after the uplevel #0 $commandstr call # vars within the script that were set to a list, and have no string-rep, will generate a string-rep once the script (commandstr) is unset, or set to another value + #review - although the rep change is weird - what actual problem was caused aside from an unexpected shimmer? + #probably just that the repl can't then be used to debug representation issues and possibly that the performance is not ideal for list pipeline commands(?) + #now that we eval in another thread and interp - we seem to lose the list rep anyway. + #(unless we also save the script in that interp too in a run_command_cache) global run_command_string set run_command_string "$commandstr\n" ;#add anything that won't affect script. global run_command_cache @@ -2151,7 +2155,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #----------------------------------------- #list/string-rep bug workaround part 2 - #todo - set flag based on punk::lib::system::has_script_var_bug + #todo - set flag based on punk::lib::system::has_tclbug_script_var lappend run_command_cache $run_command_string #puts stderr "run_command_string rep: [rep $run_command_string]" if {[llength $run_command_cache] > 2000} { @@ -2576,15 +2580,15 @@ namespace eval repl { set codethread_cond [thread::cond create] ;#repl::codethread_cond held by parent(repl) vs punk::repl::codethread::replthread_cond held by child(codethread) set codethread_mutex [thread::mutex create] - thread::send $codethread [string map [list %args% [list $opts]\ - %argv0% [list $::argv0]\ - %argv% [list $::argv]\ - %argc% [list $::argc]\ - %replthread% [thread::id]\ - %replthread_cond% $codethread_cond\ - %replthread_interp% [list $opt_callback_interp]\ - %tmlist% [list [tcl::tm::list]]\ - %autopath% [list $::auto_path]\ + thread::send $codethread [string map [list %args% [list $opts]\ + %argv0% [list $::argv0]\ + %argv% [list $::argv]\ + %argc% [list $::argc]\ + %replthread% [thread::id]\ + %replthread_cond% $codethread_cond\ + %replthread_interp% [list $opt_callback_interp]\ + %tmlist% [list [tcl::tm::list]]\ + %autopath% [list $::auto_path]\ ] { set ::argv0 %argv0% set ::argv %argv% @@ -2699,8 +2703,10 @@ namespace eval repl { #todo - add/remove shellfilter stacked ansiwrap } proc mode args { - thread::send %replthread% [list punk::console::mode {*}$args] + #with tsv::set console is_raw we don't need to call mode in both the replthread and the codethread + # REVIEW - call in local interp? how about if codethread is safe interp? #interp eval code [list ::punk::console::mode {*}$args] + thread::send %replthread% [list punk::console::mode {*}$args] } proc cmdtype cmd { code invokehidden tcl:info:cmdtype $cmd @@ -2831,6 +2837,7 @@ namespace eval repl { code alias ::md5::md5 ::repl::interphelpers::md5 code alias exit ::repl::interphelpers::quit } elseif {$safe == 2} { + #safebase safe::interpCreate code -nested 1 #safe::setLogCmd ::repl::interpextras::safe_msg ;#using setLogcmd early will show the auto_path notice - which is *verbose* #while it may conceivably be useful in debugging safe itself - auto_path and tcl::tm::list can be inspected to show these values in the safe interp itself anyway - so early logging is of limited utility here. @@ -2906,6 +2913,7 @@ namespace eval repl { namespace eval ::codeinterp { variable errstack {} variable outstack {} + variable run_command_cache } # -- --- @@ -2936,7 +2944,6 @@ namespace eval repl { #catch {package require packageTrace} package require punk package require shellrun - package require shellfilter set running_config $::punk::config::running if {[string length [dict get $running_config color_stderr]] && [punk::console::colour]} { diff --git a/src/modules/punk/repl/codethread-999999.0a1.0.tm b/src/modules/punk/repl/codethread-999999.0a1.0.tm index 02265946..6bc3e0bc 100644 --- a/src/modules/punk/repl/codethread-999999.0a1.0.tm +++ b/src/modules/punk/repl/codethread-999999.0a1.0.tm @@ -20,12 +20,12 @@ #*** !doctools #[manpage_begin shellspy_module_punk::repl::codethread 0 999999.0a1.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/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index 3700df66..34dbd40d 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.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/modules/punk/trie-999999.0a1.0.tm b/src/modules/punk/trie-999999.0a1.0.tm new file mode 100644 index 00000000..06d086fc --- /dev/null +++ b/src/modules/punk/trie-999999.0a1.0.tm @@ -0,0 +1,600 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. +# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# (C) CMcC 2010 +# +# @@ Meta Begin +# Application punk::trie 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::trie 0 999999.0a1.0] +#[copyright "2010"] +#[titledesc {punk::trie API}] [comment {-- Name section and table of contents description --}] +#[moddesc {punk::trie}] [comment {-- Description at end of page heading --}] +#[require punk::trie] +#[keywords module datastructure trie] +#[description] tcl trie implementation courtesy of CmcC (tcl wiki) +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::trie +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::trie +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::trie::class { + #*** !doctools + #[subsection {Namespace punk::trie::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::trie { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + proc Dolog {lvl txt} { + #return "$lvl -- $txt" + #logger calls this in such a way that a straight uplevel can get us the vars/commands in messages substituted + set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] punk::trie '[uplevel [list subst $txt]]'" + puts stderr $msg + } + package require logger + logger::initNamespace ::punk::trie + foreach lvl [logger::levels] { + interp alias {} ::punk::trie::Log_$lvl {} ::punk::trie::Dolog $lvl + log::logproc $lvl ::punk::trie::Log_$lvl + } + #namespace path ::punk::trie::log + + #[para] class definitions + if {[tcl::info::commands [tcl::namespace::current]::trieclass] eq ""} { + #*** !doctools + #[list_begin enumerated] + oo::class create [tcl::namespace::current]::trieclass { + variable trie id + + method matches {t what} { + #*** !doctools + #[call class::trieclass [method matches] [arg t] [arg what]] + #[para] search for longest prefix, return matching prefix, element and suffix + + set matches {} + set wlen [string length $what] + foreach k [lsort -decreasing -dictionary [dict keys $t]] { + set klen [string length $k] + set match "" + for {set i 0} {$i < $klen + && $i < $wlen + && [string index $k $i] eq [string index $what $i] + } {incr i} { + append match [string index $k $i] + } + if {$match ne ""} { + lappend matches $match $k + } + } + #Debug.trie {matches: $what -> $matches} + ::punk::trie::log::debug {matches: $what -> $matches} + + if {[dict size $matches]} { + # find the longest matching prefix + set match [lindex [lsort -dictionary [dict keys $matches]] end] + set mel [dict get $matches $match] + set suffix [string range $what [string length $match] end] + + return [list $match $mel $suffix] + } else { + return {} ;# no matches + } + } + + # return next unique id if there's no proffered value + method id {value} { + if {$value} { + return $value + } else { + return [incr id] + } + } + + # insert an element with a given optional value into trie + # along path given by $args (no need to specify) + method insert {what {value 0} args} { + if {[llength $args]} { + set t [dict get $trie {*}$args] + } else { + set t $trie + } + + if {[dict exists $t $what]} { + #Debug.trie {$what is an exact match on path ($args $what)} + ::punk::trie::log::debug {$what is an exact match on path ($args $what)} + if {[catch {dict size [dict get $trie {*}$args $what]} size]} { + # the match is a leaf - we're done + } else { + # the match is a dict - we have to add a null + dict set trie {*}$args $what "" [my id $value] + } + + return ;# exact match - no change + } + + # search for longest prefix + set match [my matches $t $what] + + if {![llength $match]} { + ;# no matching prefix - new element + #Debug.trie {no matching prefix of '$what' in $t - add it on path ($args $what)} + ::punk::trie::log::debug {no matching prefix of '$what' in $t add it on path ($args $what)} + dict set trie {*}$args $what [my id $value] + return + } + + lassign $match match mel suffix ;# prefix, element of match, suffix + + if {$match ne $mel} { + # the matching element shares a prefix, but has a variant suffix + # it must be split + #Debug.trie {splitting '$mel' along '$match'} + ::punk::trie::log::debug {splitting '$mel' along '$match'} + + set melC [dict get $t $mel] + dict unset trie {*}$args $mel + dict set trie {*}$args $match [string range $mel [string length $match] end] $melC + } + + if {[catch {dict size [dict get $trie {*}$args $match]} size]} { + # the match is a leaf - must be split + if {$match eq $mel} { + # the matching element shares a prefix, but has a variant suffix + # it must be split + #Debug.trie {splitting '$mel' along '$match'} + ::punk::trie::log::debug {splitting '$mel' along '$match'} + set melC [dict get $t $mel] + dict unset trie {*}$args $mel + dict set trie {*}$args $match "" $melC + } + #Debug.trie {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} + ::punk::trie::log::debug {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} + set melid [dict get $t $mel] + dict set trie {*}$args $match $suffix [my id $value] + } else { + # it's a dict - keep searching + #Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} + ::punk::trie::log::debug {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} + my insert $suffix $value {*}$args $match + } + return + } + + # find a path matching an element $what + # if the element's not found, return the nearest path + method find_path {what args} { + if {[llength $args]} { + set t [dict get $trie {*}$args] + } else { + set t $trie + } + + if {[dict exists $t $what]} { + #Debug.trie {$what is an exact match on path ($args $what)} + return [list {*}$args $what] ;# exact match - no change + } + + # search for longest prefix + set match [my matches $t $what] + + if {![llength $match]} { + return $args + } + + lassign $match match mel suffix ;# prefix, element of match, suffix + + if {$match ne $mel} { + # the matching element shares a prefix, but has a variant suffix + # no match + return $args + } + + if {[catch {dict size [dict get $trie {*}$args $match]} size] || $size == 0} { + # got to a non-matching leaf - no match + return $args + } else { + # it's a dict - keep searching + #Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} + return [my find_path $suffix {*}$args $match] + } + } + + # given a trie, which may have been modified by deletion, + # optimize it by removing empty nodes and coalescing singleton nodes + method optimize {args} { + if {[llength $args]} { + set t [dict get $trie {*}$args] + } else { + set t $trie + } + + if {[catch {dict size $t} size]} { + #Debug.trie {optimize leaf '$t' along '$args'} + ::punk::trie::log::debug {optimize leaf '$t' along '$args'} + # leaf - leave it + } else { + switch -- $size { + 0 { + #Debug.trie {optimize empty dict ($t) along '$args'} + ::punk::trie::log::debug {optimize empty dict ($t) along '$args'} + if {[llength $args]} { + dict unset trie {*}$args + } + } + 1 { + #Debug.trie {optimize singleton dict ($t) along '$args'} + ::punk::trie::log::debug {optimize singleton dict ($t) along '$args'} + lassign $t k v + if {[llength $args]} { + dict unset trie {*}$args + } + append args $k + if {[llength $v]} { + dict set trie {*}$args $v + } + my optimize {*}$args + } + default { + #Debug.trie {optimize dict ($t) along '$args'} + ::punk::trie::log::debug {optimize dict ($t) along '$args'} + dict for {k v} $t { + my optimize {*}$args $k + } + } + } + } + } + + # delete element $what from trie + method delete {what} { + set path [my find_path $what] + if {[join $path ""] eq $what} { + #Debug.trie {del '$what' along ($path) was [dict get $trie {*}$path]} + if {[catch {dict size [dict get $trie {*}$path]} size]} { + # got to a matching leaf - delete it + dict unset trie {*}$path + set path [lrange $path 0 end-1] + } else { + dict unset trie {*}$path "" + } + + my optimize ;# remove empty and singleton elements + } else { + # nothing to delete, guess we're done + } + } + + # find the value of element $what in trie, + # error if not found + method find_or_error {what} { + set path [my find_path $what] + if {[join $path ""] eq $what} { + if {[catch {dict size [dict get $trie {*}$path]} size]} { + # got to a matching leaf - done + return [dict get $trie {*}$path] + } else { + #JMN - what could be an exact match for a path, but not be in the trie itself + if {[dict exists $trie {*}$path ""]} { + return [dict get $trie {*}$path ""] + } else { + ::punk::trie::log::debug {'$what' matches a path but is not a leaf} + error "'$what' not found" + } + } + } else { + error "'$what' not found" + } + } + #JMN - renamed original find to find_or_error + #prefer not to catch on result - but test for -1 + method find {what} { + set path [my find_path $what] + if {[join $path ""] eq $what} { + #presumably we use catch and dict size to avoid llength shimmering large inner dicts to list rep + if {[catch {dict size [dict get $trie {*}$path]} size]} { + # got to a matching leaf - done + return [dict get $trie {*}$path] + } else { + #JMN - what could be an exact match for a path, but not be in the trie itself + if {[dict exists $trie {*}$path ""]} { + return [dict get $trie {*}$path ""] + } else { + ::punk::trie::log::debug {'$what' matches a path but is not a leaf} + return -1 + } + } + } else { + return -1 + } + } + + # dump the trie as a string + method dump {} { + return $trie + } + + # return a string rep of the trie sorted in dict order + method order {{t {}}} { + if {![llength $t]} { + set t $trie + } elseif {[llength $t] == 1} { + return $t + } + set acc {} + + foreach key [lsort -dictionary [dict keys $t]] { + lappend acc $key [my order [dict get $t $key]] + } + return $acc + } + + # return the trie as a dict of names with values + method flatten {{t {}} {prefix ""}} { + if {![llength $t]} { + set t $trie + } elseif {[llength $t] == 1} { + return [list $prefix $t] + } + + set acc {} + + foreach key [dict keys $t] { + lappend acc {*}[my flatten [dict get $t $key] $prefix$key] + } + return $acc + } + + #shortest possible string to identify an element in the trie using the same principle as tcl::prefix::match + #ie if a stored word is a prefix of any other words - it must be fully specified to identify itself. + #JMN - REVIEW - better algorithms? + #caller having retained all members can avoid flatten call + #by selecting a single 'which' known not to be in the trie (or empty string) - all idents can be returned. + #when all 'which' members are in the tree - scanning stops when they're all found + # - and a dict containing result and scanned keys is returned + # - result contains a dict with keys for each which member + # - scanned contains a dict of all words longer than our shortest which - (and a subset of words the same length) + method shortest_idents {which {allmembers {}}} { + set t $trie + if {![llength $allmembers]} { + set members [dict keys [my flatten]] + } else { + set members $allmembers + } + set len_members [lmap m $members {list [string length $m] $m}] + set longestfirst [lsort -index 0 -integer -decreasing $len_members] + set longestfirst [lmap v $longestfirst {lindex $v 1}] + set taken [dict create] + set scanned [dict create] + set result [dict create] ;#words in our which list - if found + foreach w $longestfirst { + set path [my find_path $w] + if {[dict exists $taken $w]} { + #whole word - no unique prefix + dict set scanned $w $w + if {$w in $which} { + #puts stderr "$w -> $w" + dict set result $w $w + if {[dict size $result] == [llength $which]} { + return [dict create result $result scanned $scanned] + } + } + continue + } + set acc "" + foreach p [lrange $path 0 end-1] { + dict set taken [append acc $p] 1 ;#no need to test first - just set even though may already be present + } + append acc [string index [lindex $path end] 0] + dict set scanned $w $acc ;#sorted by length - so no other can have this prefix - and no longer necessary + if {$w in $which} { + #puts stderr "$w -> $acc" + dict set result $w $acc + if {[dict size $result] == [llength $which]} { + return [dict create result $result scanned $scanned] + } + } + } + return [dict create result $result scanned $scanned] + } + + # overwrite the trie + method set {t} { + set trie $t + } + + constructor {args} { + set trie {} + set id 0 + foreach a $args { + my insert $a + } + } + } + + set testlist [list blah x black blacken] + proc test1 {} { + #JMN + #test that find_or_error of a path that isn't stored as a value returns an appropriate error + #(used to report couldn't find dict key "") + set t [punk::trie::trieclass new blah x black blacken] + if {[catch {$t find_or_error bla} errM]} { + puts stderr "should be error indicating 'bla' not found" + puts stderr "err during $t find bla\n$errM" + } + return $t + } + + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } + + #*** !doctools + #[subsection {Namespace punk::trie}] + #[para] Core API functions for punk::trie + #[list_begin definitions] + + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::trie ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::trie::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::trie::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::trie::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::trie::system { + #*** !doctools + #[subsection {Namespace punk::trie::system}] + #[para] Internal functions that are not part of the API + + + +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::trie [tcl::namespace::eval punk::trie { + variable pkg punk::trie + variable version + set version 999999.0a1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/trie-buildversion.txt b/src/modules/punk/trie-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/punk/trie-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index f3895b14..af978d8c 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.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 }