diff --git a/src/bootsupport/modules/punk/lib-0.5.1.tm b/src/bootsupport/modules/punk/lib-0.6.0.tm similarity index 98% rename from src/bootsupport/modules/punk/lib-0.5.1.tm rename to src/bootsupport/modules/punk/lib-0.6.0.tm index 7013a8e5..11a1e0c6 100644 --- a/src/bootsupport/modules/punk/lib-0.5.1.tm +++ b/src/bootsupport/modules/punk/lib-0.6.0.tm @@ -8,7 +8,7 @@ # (C) 2024 # # @@ Meta Begin -# Application punk::lib 0.5.1 +# Application punk::lib 0.6.0 # Meta platform tcl # Meta license BSD # @@ Meta End @@ -18,7 +18,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin punkshell_module_punk::lib 0 0.5.1] +#[manpage_begin punkshell_module_punk::lib 0 0.6.0] #[copyright "2024"] #[titledesc {punk general utility functions}] [comment {-- Name section and table of contents description --}] #[moddesc {punk library}] [comment {-- Description at end of page heading --}] @@ -295,7 +295,7 @@ tcl::namespace::eval punk::lib::check { if {$replversion eq ""} { #not loaded - determine what version would be provided, without loading it: #an unsatisfiable require triggers the package unknown scan (registering ifneeded - #scripts) then fails before any load (0.5.1 dev modules are alpha - below 999999). + #scripts) then fails before any load (0.6.0 dev modules are alpha - below 999999). catch {package require punk::repl 999999} set available [package versions punk::repl] if {[llength $available]} { @@ -2519,7 +2519,7 @@ namespace eval punk::lib { #for each of the above strings we should get a command recognised for the 'puts e*' items as well as the 'list' item, but not for the 'puts n' items since they are within curly braces and not subject to command substitution. #--------------------------------- proc tclscript_info {script {nscontext ""}} { - package require parser + tclparser_prefer ;#c library preferred, punk::tclparser pure-Tcl fallback wired otherwise (G-070) #if the script is ANSI highlighted - the square brackets within the ANSI will disrupt our parsing. if {[punk::ansi::ta::detect $script]} { #we will strip it - but be noisy on stderr since a) it's a bi inefficient to pass in ansi highlighted scripts. @@ -3555,27 +3555,107 @@ namespace eval punk::lib { } return $resultd } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::lib::tclparser_prefer + @cmd -name punk::lib::tclparser_prefer\ + -summary\ + "Resolve which tclparser implementation serves punk::lib's script analysis."\ + -help\ + "Resolve which tclparser implementation serves punk::lib's + script-analysis procs (tclscript_info and the + tclscript_info::* helpers), returning 'c' or 'tcl'. + + With no argument the decision is automatic and memoized for + the process: the tclparser c library is preferred when + 'package require parser' succeeds (it provides the global + ::parse command the analysis procs call); otherwise the + punk::tclparser pure-Tcl engine (G-070, parity-tested + against the c library) is wired in as namespace-local + 'parse' aliases so the same call sites fall back with no + body changes. A c library loaded later is not consulted + once the fallback is wired. + + With the optional argument the preference is forced: 'c' + requires the c library (error if unavailable) and removes + any fallback aliases; 'tcl' wires the pure-Tcl engine even + when the c library is present (testing/benchmarks)." + @values -min 0 -max 1 + which -type string -choices {c tcl} -optional 1 -help\ + "Force the preference instead of deciding automatically" + }] + } + proc tclparser_prefer {args} { + #manual parsing - see PUNKARGS documentation above + variable tclparser_which + if {[llength $args] > 1} { + error "wrong # args: should be \"punk::lib::tclparser_prefer ?c|tcl?\"" + } + if {[llength $args] == 1} { + set want [lindex $args 0] + switch -exact -- $want { + c { + package require parser + catch {interp alias {} ::punk::lib::parse {}} + catch {interp alias {} ::punk::lib::tclscript_info::parse {}} + set tclparser_which c + } + tcl { + package require punk::tclparser + interp alias {} ::punk::lib::parse {} ::punk::tclparser::parse + interp alias {} ::punk::lib::tclscript_info::parse {} ::punk::tclparser::parse + set tclparser_which tcl + } + default { + error "punk::lib::tclparser_prefer: unknown preference '$want' - must be c or tcl" + } + } + return $tclparser_which + } + if {[info exists tclparser_which]} { + return $tclparser_which + } + if {![catch {package require parser}]} { + set tclparser_which c + } else { + package require punk::tclparser + interp alias {} ::punk::lib::parse {} ::punk::tclparser::parse + interp alias {} ::punk::lib::tclscript_info::parse {} ::punk::tclparser::parse + set tclparser_which tcl + } + return $tclparser_which + } + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::lib::tclparser_tcl + @cmd -name punk::lib::tclparser_tcl\ + -summary\ + "Pure-Tcl 'parse' with the same API as the tclparser c library."\ + -help\ + "Pure-Tcl implementation of the tclparser c library's 'parse' + command API (G-070) - a thin delegation to + punk::tclparser::parse, which covers the subcommands + punkshell consumes (command, getstring, countnewline) with + parity-tested result shapes and byte ranges. The c library + remains preferred where present - see tclparser_prefer." + @values -min 3 -max 3 + subcmd -type string -help\ + "parse subcommand (covered set: command, getstring, countnewline)" + string -type string -help\ + "the string to operate on" + range -type list -help\ + "byte range {start length} - {} means the whole string" + }] + } proc tclparser_tcl {subcmd string range} { - #provide a tcl parser with the same API as the tclparser c library. + #pure-Tcl fallback for the tclparser c library (G-070). + #Historical upstream references (now vendored/pinned in the + #punkshell-maintained fork c:/repo/jn/tclparser_punk - see + #goals/G-070-pure-tcl-tclparser.md): #https://chiselapp.com/user/aspect/repository/tclparser/index - #or - #https://github.com/ActiveState/teapot/tree/master/lib/tclparser - - set scriptlist [list] - set argchars [split $string ""] - set in_dq 0 ;#in double quotes - set in_cb 0 ;#in curly braces - set in_commandsub 0 ;#in command substitution (i.e within square brackets) - #when we are in a command substitution - we should be able to keep appending whilst testing for info complete. review - set escaped 0 - set nesting_level 0 - set scripttoken "" - for {set i 0} {$i < [llength $argchars]} {incr i} { - set ch [lindex $argchars $i] - #todo - error "tclparser_tcl not yet implemented - in the meantime install the tclparser c library (package require parser)" - } - + #https://github.com/tcltk-depot/tcl-parser + package require punk::tclparser + tailcall ::punk::tclparser::parse $subcmd $string $range } namespace eval tclscript_info { @@ -3671,7 +3751,39 @@ namespace eval punk::lib { #- commonly just a variable e.g 'set cmdname foo; $cmdname arg1 arg2' # but it could also have command subtitutions e.g 'cmdname_[get_suffix] arg1 arg2' + namespace eval argdoc { + lappend PUNKARGS [list { + @id -id ::punk::lib::tclscript_info::tclword_to_scriptlist + @cmd -name punk::lib::tclscript_info::tclword_to_scriptlist\ + -summary\ + "List the toplevel command substitutions within a single tcl word."\ + -help\ + "Analyse a string representing a single tcl word (a bareword, + double quoted string or curly braced string as it appears in + source - possibly spanning multiple lines) and return the list + of toplevel commands that would be substituted into it, in + order of evaluation. Each element is itself a command list. + A fully brace-quoted word is opaque and returns an empty list. + Command substitutions nested within array-variable indexes are + included; commands nested within OTHER commands' substitutions + are not (this proc is deliberately non-recursive - see + tclscript_info for the recursive analysis). + + Parsing uses the tclparser c library when available, else the + punk::tclparser pure-Tcl engine (G-070) - see + punk::lib::tclparser_prefer. Works under a plain tclsh with no + parser binary on the package path." + @leaders + string -type string -help\ + "the tcl word to analyse" + @values -min 0 -max 1 + nscontext -type string -optional 1 -help\ + "namespace context for the analysis (defaults to the caller's + current namespace)" + }] + } proc tclword_to_scriptlist {string {nscontext ""}} { + #manual args (simple positional signature) - see PUNKARGS documentation above #consider 'list [puts a]$v(x,[puts b])[puts c]' # the command substitutions are [puts a], [puts b] and [puts c] #The order of evaluation is [puts a] then [puts b] then [puts c] but [puts b] is within the variable array syntax and so parses differently to the other two command substitutions. @@ -3680,7 +3792,7 @@ namespace eval punk::lib { if {$nscontext eq ""} { set nscontext [uplevel 1 {namespace current}] } - puts stderr "------------tclword_to_scriptlist called with string: $string nscontext: $nscontext------------" + #puts stderr "------------tclword_to_scriptlist called with string: $string nscontext: $nscontext------------" #analyse a string that will undergo command substitution to determine the list of commands that will be substituted into the string. #e.g for "a string with [puts hello] and [puts world]" we would return a list of 2 items, each being a list of the command and its arguments, e.g {puts hello} and {puts world} #we need to do a full parse of the string to determine which square brackets are actually command substitutions that need to be analysed for complexity, and which are just literal characters within the string. @@ -3697,11 +3809,11 @@ namespace eval punk::lib { set scriptlist [list] - if {![catch {package require parser}]} { - #use tclparser library if available + if {[punk::lib::tclparser_prefer] eq "c"} { + #tclparser c library (preferred where present - performance) set parseinfo [::parse command $boguscmdline {0 end}] } else { - puts stderr "tclparser library not available - using fallback tcl parser which may be less accurate - review" + #punk::tclparser pure-Tcl engine (G-070) - parity-tested against the c library set parseinfo [::punk::lib::tclparser_tcl command $boguscmdline {0 end}] } #returns 4 items. @@ -3780,7 +3892,7 @@ namespace eval punk::lib { #set var_subscript_cmds [punk::lib::tclscript_info::tclword_to_scriptlist $varstringfull $nscontext] set varsubnodes [lindex $subnode 2] foreach varsubnode $varsubnodes { - puts stderr "[a+ cyan]varsubnodes: $varsubnodes type: [lindex $varsubnode 0][a]" + #puts stderr "varsubnodes: $varsubnodes type: [lindex $varsubnode 0]" if {[lindex $varsubnode 0] eq "command"} { set pos_bytes [lindex $varsubnode 1] set cmdstringfull [parse getstring $boguscmdline $pos_bytes] ;#this must be used instead of string range to correctly handle any multibyte characters in the original string @@ -3796,7 +3908,7 @@ namespace eval punk::lib { } elseif {[lindex $varsubnode 0] eq "variable"} { set pos_bytes [lindex $varsubnode 1] set varstringfull [parse getstring $boguscmdline $pos_bytes] - puts stderr "[a+ cyan]varstringfull: $varstringfull[a]" + #puts stderr "varstringfull: $varstringfull" set varscriptlist [punk::lib::tclscript_info::tclword_to_scriptlist $varstringfull $nscontext] lappend scriptlist {*}$varscriptlist } @@ -9390,7 +9502,7 @@ namespace eval ::punk::args::register { package provide punk::lib [tcl::namespace::eval punk::lib { variable pkg punk::lib variable version - set version 0.5.1 + set version 0.6.0 }] return diff --git a/src/bootsupport/modules/punk/mix/base-0.1.2.tm b/src/bootsupport/modules/punk/mix/base-0.2.0.tm similarity index 92% rename from src/bootsupport/modules/punk/mix/base-0.1.2.tm rename to src/bootsupport/modules/punk/mix/base-0.2.0.tm index b91bdca2..10efc821 100644 --- a/src/bootsupport/modules/punk/mix/base-0.1.2.tm +++ b/src/bootsupport/modules/punk/mix/base-0.2.0.tm @@ -1,10 +1,10 @@ # Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck make' or src/make.tcl to update from -buildversion.txt # @@ Meta Begin -# Application punk::mix::base 0.1.2 +# Application punk::mix::base 0.2.0 # @@ Meta End package provide punk::mix::base [namespace eval punk::mix::base { variable version - set version 0.1.2 + set version 0.2.0 }] package require punk::path @@ -344,7 +344,7 @@ namespace eval punk::mix::base { } #we can return module paths even if the project isn't yet under revision control set src_subs [glob -nocomplain -dir [file join $candidate src] -type d -tail *] - set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] + set antipatterns [list *.vfs vendor* lib _build _mint _bake doc embedded runtime bootsupport] set tm_folders [list] foreach sub $src_subs { set is_ok 1 @@ -411,17 +411,23 @@ namespace eval punk::mix::base { return [string map {:: /} $nsq] } - proc get_build_workdir {path} { + proc get_bake_workdir {path} { set repo_info [punk::repo::find_repos $path] set base [lindex [dict get $repo_info project] 0] if {![string length $base]} { - error "get_build_workdir unable to determine project base for path '$path'" + error "get_bake_workdir unable to determine project base for path '$path'" } if {![file exists $base/src] || ![file writable $base/src]} { - error "get_build_workdir unable to access $base/src" + error "get_bake_workdir unable to access $base/src" } - file mkdir $base/src/_build - return $base/src/_build + file mkdir $base/src/_bake + return $base/src/_bake + } + #legacy name (pre-G-155 stage vocabulary; workdir was src/_build) - old make.tcl copies in + #generated projects may still call this. Delegates to the renamed resolver; retirement is a + #G-156 decision. + proc get_build_workdir {path} { + return [get_bake_workdir $path] } @@ -963,86 +969,12 @@ namespace eval punk::mix::base { return [dict create $storedpath $keyvals] } - #calculate the runtime checksum and vfs checksums - proc get_all_vfs_build_cksums {path {cksum_opts {}}} { - set buildfolder [get_build_workdir $path] - set cksum_base_folder [file dirname $buildfolder] ;#this is the /src folder - a reasonable base for our vfs cksums - set dict_cksums [dict create] - - set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] - set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] - - foreach vfstail $vfs_tail_list { - set vname [file rootname $vfstail] - dict set dict_cksums $vfstail [list cksum ""] - dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] - } - - #buildruntime.exe obsolete.. - puts stderr "warning obsolete? get_all_vfs_build_cksums 'buildruntime.exe'???" - set fullpath_buildruntime $buildfolder/buildruntime.exe - - set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] - set ck [dict get $ckinfo_buildruntime cksum] - - - set relpath [file join $buildrelpath "buildruntime.exe"] - dict set dict_cksums $relpath [list cksum $ck opts $cksum_opts] - - set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] - - return $dict_cksums - } - - proc get_vfs_build_cksums_stored {vfsfolder} { - set vfscontainer [file dirname $vfsfolder] - set buildfolder $vfscontainer/_build - set vfs [file tail $vfsfolder] - set vname [file rootname $vfs] - set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] - set ckfile $buildfolder/$vname.cksums - if {[file exists $ckfile]} { - set data [punk::mix::util::fcat -translation binary $ckfile] - foreach ln [split $data \n] { - if {[string trim $ln] eq ""} {continue} - lassign $ln path cksum - dict set dict_vfs $path $cksum - } - } - return $dict_vfs - } - proc get_all_build_cksums_stored {path} { - set buildfolder [get_build_workdir $path] - - set vfscontainer [file dirname $buildfolder] - set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] - set dict_cksums [dict create] - foreach vfs $vfslist { - set vname [file rootname $vfs] - set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] - - dict set dict_cksums $vname $dict_vfs - } - return $dict_cksums - } - - proc store_vfs_build_cksums {vfsfolder} { - if {![file isdirectory $vfsfolder]} { - error "Unable to find supplied vfsfolder: $vfsfolder" - } - set vfscontainer [file dirname $vfsfolder] - set buildfolder $vfscontainer/_build - set dict_vfs [get_vfs_build_cksums $vfsfolder] - set data "" - dict for {path cksum} $dict_vfs { - append data "$path $cksum" \n - } - set fd [open $buildfolder/$vname.cksums w] - chan configure $fd -translation binary - puts $fd $data - close $fd - return $dict_vfs - } + #The legacy vfs-cksums quartet (get_all_vfs_build_cksums, get_vfs_build_cksums_stored, + #get_all_build_cksums_stored, store_vfs_build_cksums) was RETIRED under G-155: repo-wide + #caller search found none, store_vfs_build_cksums called an undefined get_vfs_build_cksums + #(and an unset vname) so it can never have executed, and punkcheck records own the + #change-detection role the cksums files aimed at. Historical copies remain in older + #snapshots (src/vfs/*.vfs, mkzipfix.vfs). diff --git a/src/bootsupport/modules/punk/mix/cli-0.5.2.tm b/src/bootsupport/modules/punk/mix/cli-0.6.0.tm similarity index 95% rename from src/bootsupport/modules/punk/mix/cli-0.5.2.tm rename to src/bootsupport/modules/punk/mix/cli-0.6.0.tm index 47d523f7..99de7593 100644 --- a/src/bootsupport/modules/punk/mix/cli-0.5.2.tm +++ b/src/bootsupport/modules/punk/mix/cli-0.6.0.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::mix::cli 0.5.2 +# Application punk::mix::cli 0.6.0 # Meta platform tcl # Meta license # @@ Meta End @@ -169,11 +169,11 @@ namespace eval punk::mix::cli { set lc_this_exe [string tolower [info nameofexecutable]] set lc_proj_bin [string tolower $project_base/bin] - set lc_build_bin [string tolower $project_base/src/_build] + set lc_bake_bin [string tolower $project_base/src/_bake] if {"project" in $args} { set is_own_exe 0 - if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { + if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_bake_bin}" $lc_this_exe]} { set is_own_exe 1 puts stderr "WARNING - running make using executable that may be created by the project being built" set answer [util::askuser "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N"] @@ -346,7 +346,7 @@ namespace eval punk::mix::cli { set opt_errorprefix [dict get $opts -errorprefix] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- validate_name_not_empty_or_spaced $projectname -errorprefix $opt_errorprefix - set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] + set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build _mint _bake] if {$projectname in $reserved_words } { error "$opt_errorprefix '$projectname' cannot be one of reserved_words: $reserved_words" } @@ -707,7 +707,7 @@ namespace eval punk::mix::cli { } proc build_modules_from_source_to_base {srcdir basedir args} { - set antidir [list "#*" "_build" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy. + set antidir [list "#*" "_build" "_mint" "_bake" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy. set defaults [list {*}{ -installer punk::mix::cli::build_modules_from_source_to_base -call-depth-internal 0 @@ -742,14 +742,13 @@ namespace eval punk::mix::cli { if {[file tail [file dirname $srcdir]] ne "src"} { puts stderr "ERROR build_modules_from_source_to_base can only be called with a srcdir that is a subfolder of your 'src' directory" puts stderr "The .tm modules are namespaced based on their directory depth - so we need to start at the root" - puts stderr "To build a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist." - puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to build only the .tm files at /x/src/modules2/skunkworks/lib" + puts stderr "To mint a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist." + puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to mint only the .tm files at /x/src/modules2/skunkworks/lib" puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" exit 2 } set srcdirname [file tail $srcdir] - set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir if {[llength $subdirlist] == 0} { set target_module_dir $basedir set current_source_dir $srcdir @@ -859,8 +858,8 @@ namespace eval punk::mix::cli { set module_build_version $tmfile_versionsegment } - set buildfolder $current_source_dir/_build - file mkdir $buildfolder + set mintfolder $current_source_dir/_mint + file mkdir $mintfolder # -- --- set config [dict create {*}{ -glob * @@ -870,13 +869,13 @@ namespace eval punk::mix::cli { # -max-depth -1 for no limit set build_installername pods_in_$current_source_dir - set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] - #set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck stderr] ;#with debugchannel - $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_installer [punkcheck::installtrack new $build_installername $mintfolder/.punkcheck] + #set build_installer [punkcheck::installtrack new $build_installername $mintfolder/.punkcheck stderr] ;#with debugchannel + $build_installer set_source_target $current_source_dir/$modpath $mintfolder set build_event [$build_installer start_event $config] # -- --- - set podtree_copy $buildfolder/#modpod-$basename-$module_build_version - set modulefile $buildfolder/$basename-$module_build_version.tm + set podtree_copy $mintfolder/#modpod-$basename-$module_build_version + set modulefile $mintfolder/$basename-$module_build_version.tm #todo - use modpod version as a source for change detection #package require modpod @@ -894,12 +893,12 @@ namespace eval punk::mix::cli { if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} set delete_failed 0 - if {[file exists $buildfolder/]} { - puts stderr "deleting existing _build copy at $podtree_copy" + if {[file exists $mintfolder/]} { + puts stderr "deleting existing _mint copy at $podtree_copy" if {[catch { file delete -force $podtree_copy } errMsg]} { - puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + puts stderr "[punk::ansi::a+ red]deletion of _mint copy at $podtree_copy failed: $errMsg[punk::ansi::a]" set delete_failed 1 } } @@ -911,9 +910,9 @@ namespace eval punk::mix::cli { flush stdout file copy $current_source_dir/$modpath $podtree_copy if {$tmfile_versionsegment eq $magicversion} { - set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm + set tmfile $mintfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm if {[file exists $tmfile]} { - set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm + set newname $mintfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm file rename $tmfile $newname set tmfile $newname } @@ -927,20 +926,20 @@ namespace eval punk::mix::cli { #delete and regenerate zip and modpod stubbed zip set notes [list] if {[catch { - file delete $buildfolder/$basename-$module_build_version.zip + file delete $mintfolder/$basename-$module_build_version.zip } err] } { set had_error 1 lappend notes "zip_delete_failed" } if {[catch { - file delete $buildfolder/$basename-$module_build_version.tm + file delete $mintfolder/$basename-$module_build_version.tm } err]} { set had_error 1 lappend notes "tm_delete_failed" } #create ordinary zip file without using external executable package require punk::zip - set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) + set zipfile $mintfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) #zipfs mkzip does exactly what we need anyway in this case #unfortunately it's not available in all Tclsh versions we might be running.. @@ -949,7 +948,7 @@ namespace eval punk::mix::cli { #(Therefore no timestamps) #zip reading utils generally intuit their existence and display them - but often an editor can't add comments to them set wd [pwd] - cd $buildfolder + cd $mintfolder puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" set mkzip_failed [catch {zipfs mkzip $zipfile #modpod-$basename-$module_build_version} errMkzip] cd $wd @@ -963,14 +962,14 @@ namespace eval punk::mix::cli { #archive variant; modpod stubs read both shapes). puts stderr "zipfs mkzip failed under Tcl [info patchlevel] ($errMkzip) - falling back to punk::zip::mkzip (known pre-c971e6c7c4 Tcl 8.7 zipfs dotfile defect - core tkt 7d5f1c13089d463e7796)" catch {file delete -- $zipfile} ;#a failed zipfs mkzip can leave a partial target zip - punk::zip::mkzip refuses to overwrite - punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * + punk::zip::mkzip -base $mintfolder -directory $mintfolder/#modpod-$basename-$module_build_version -- $zipfile * } } else { - #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise + #use -base $mintfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise #put in an archive-level comment to aid in debugging #punk - punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * + punk::zip::mkzip -base $mintfolder -directory $mintfolder/#modpod-$basename-$module_build_version -- $zipfile * #punk::zip::mkzip stores permissions - (unix style) - which zipfs mkzip doesn't #Directory ident in zipfs relies on folders ending with trailing slash - if missing, it misidentifies dirs as files. #(ie it can't use permissions/attributes alone to determine directory vs file) @@ -1078,8 +1077,8 @@ namespace eval punk::mix::cli { set module_build_version $tmfile_versionsegment } - set buildfolder $current_source_dir/_build - file mkdir $buildfolder + set mintfolder $current_source_dir/_mint + file mkdir $mintfolder # -- --- set config [dict create {*}{ -glob * @@ -1089,12 +1088,12 @@ namespace eval punk::mix::cli { # -max-depth -1 for no limit set build_installername tarjars_in_$current_source_dir - set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] - $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_installer [punkcheck::installtrack new $build_installername $mintfolder/.punkcheck] + $build_installer set_source_target $current_source_dir/$modpath $mintfolder set build_event [$build_installer start_event $config] # -- --- - set podtree_copy $buildfolder/#tarjar-$basename-$module_build_version - set modulefile $buildfolder/$basename-$module_build_version.tm + set podtree_copy $mintfolder/#tarjar-$basename-$module_build_version + set modulefile $mintfolder/$basename-$module_build_version.tm $build_event targetset_init INSTALL $podtree_copy @@ -1110,12 +1109,12 @@ namespace eval punk::mix::cli { if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} set delete_failed 0 - if {[file exists $buildfolder/]} { - puts stderr "deleting existing _build copy at $podtree_copy" + if {[file exists $mintfolder/]} { + puts stderr "deleting existing _mint copy at $podtree_copy" if {[catch { file delete -force $podtree_copy } errMsg]} { - puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + puts stderr "[punk::ansi::a+ red]deletion of _mint copy at $podtree_copy failed: $errMsg[punk::ansi::a]" set delete_failed 1 } } @@ -1126,7 +1125,7 @@ namespace eval punk::mix::cli { puts stdout "$podtree_copy" file copy $current_source_dir/$modpath $podtree_copy if {$tmfile_versionsegment eq $magicversion} { - set tmfile $buildfolder/#tarjar-$basename-$module_build_version/#tarjar-loadscript-$basename.tcl + set tmfile $mintfolder/#tarjar-$basename-$module_build_version/#tarjar-loadscript-$basename.tcl #we don't need to modify version or name of the loadscript if {![file exists $tmfile]} { set had_error 1 @@ -1150,16 +1149,16 @@ namespace eval punk::mix::cli { #delete and regenerate .tm set notes [list] if {[catch { - file delete $buildfolder/$basename-$module_build_version.tm + file delete $mintfolder/$basename-$module_build_version.tm } err]} { set had_error 1 lappend notes "tm_delete_failed" } #create ordinary tar file without using external executable package require tar ;#tcllib - set tarfile $buildfolder/$basename-$module_build_version.tm ;#ordinary tar file (no compression - store) + set tarfile $mintfolder/$basename-$module_build_version.tm ;#ordinary tar file (no compression - store) set wd [pwd] - cd $buildfolder + cd $mintfolder puts "tar::create $tarfile #tarjar-$basename-$module_build_version" if {[catch { tar::create $tarfile #tarjar-$basename-$module_build_version @@ -1269,23 +1268,23 @@ namespace eval punk::mix::cli { #} else { #} - ##REVIEW - should be in same structure/depth as $target_module_dir in _build? + ##REVIEW - should be in same structure/depth as $target_module_dir in _mint? ##TODO - #set buildfolder $current_sourcedir/_build - #file mkdir $buildfolder + #set mintfolder $current_sourcedir/_mint + #file mkdir $mintfolder - #set tmfile $buildfolder/$basename-$module_build_version.tm - #file delete -force $buildfolder/#tarjar-$basename-$module_build_version + #set tmfile $mintfolder/$basename-$module_build_version.tm + #file delete -force $mintfolder/#tarjar-$basename-$module_build_version #file delete -force $tmfile - #file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version + #file copy -force $current_source_dir/#tarjar-$basename-$magicversion $mintfolder/#tarjar-$basename-$module_build_version ## ##bsdtar doesn't seem to work.. or I haven't worked out the right options? - ##exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version + ##exec tar -cvf $mintfolder/$basename-$module_build_version.tm $mintfolder/#tarjar-$basename-$module_build_version #package require tar - #tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version + #tar::create $tmfile $mintfolder/#tarjar-$basename-$module_build_version #if {![file exists $tmfile]} { # puts stdout "ERROR: failed to build tarjar file $tmfile" # exit 4 @@ -1664,6 +1663,6 @@ namespace eval punk::mix::cli { ## Ready package provide punk::mix::cli [namespace eval punk::mix::cli { variable version - set version 0.5.2 + set version 0.6.0 }] return diff --git a/src/bootsupport/modules/punk/mix/templates-0.2.0.tm b/src/bootsupport/modules/punk/mix/templates-0.2.0.tm index 0a9395e2..13fb1158 100644 Binary files a/src/bootsupport/modules/punk/mix/templates-0.2.0.tm and b/src/bootsupport/modules/punk/mix/templates-0.2.0.tm differ diff --git a/src/bootsupport/modules/punkboot/utils-0.6.0.tm b/src/bootsupport/modules/punkboot/utils-0.6.2.tm similarity index 98% rename from src/bootsupport/modules/punkboot/utils-0.6.0.tm rename to src/bootsupport/modules/punkboot/utils-0.6.2.tm index 43372880..da683f94 100644 --- a/src/bootsupport/modules/punkboot/utils-0.6.0.tm +++ b/src/bootsupport/modules/punkboot/utils-0.6.2.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punkboot::utils 0.6.0 +# Application punkboot::utils 0.6.2 # Meta platform tcl # Meta license BSD # @@ Meta End @@ -126,7 +126,7 @@ namespace eval punkboot::utils { -help\ "Walks up from path to the nearest fossil and/or git root and returns warning lines describing uncommitted changes. - Artifacts built from a dirty source tree have no committed + Artifacts produced from a dirty source tree have no committed provenance - callers such as make.tcl vendorupdate use this to flag source projects that should be committed first. @@ -206,7 +206,7 @@ namespace eval punkboot::utils { lappend flines $line } if {[llength $flines]} { - lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes${scopedesc} ([llength $flines] file(s)) - artifacts built from a dirty tree have no committed provenance" + lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes${scopedesc} ([llength $flines] file(s)) - artifacts produced from a dirty tree have no committed provenance" } } cd $original_cwd @@ -222,7 +222,7 @@ namespace eval punkboot::utils { } errM]} { lappend warnings "WARNING: ${label}could not determine git state of source project at $gitroot ($errM)" } elseif {$gchanges ne ""} { - lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes${scopedesc} ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance" + lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes${scopedesc} ([llength [split $gchanges \n]] file(s)) - artifacts produced from a dirty tree have no committed provenance" } } return $warnings @@ -749,7 +749,7 @@ namespace eval punkboot::utils { punkshell bake pipeline emits ARCHIVE-relative payloads by construction; this probe makes that a checked contract - a 'file' result is the pipeline-regression signal make.tcl - surfaces as a recapped BUILD-WARNING (advisory: the kit still + surfaces as a recapped BAKE-WARNING (advisory: the kit still builds and deploys). 'plain' (the file is a bare zip), 'none' (no zip attached - e.g the metakit kit shape, or any non-zip file) and 'unreadable' are silence, not warnings: the pin @@ -805,8 +805,8 @@ namespace eval ::punk::args::register { ## Ready package provide punkboot::utils [tcl::namespace::eval punkboot::utils { variable version - #- this version number, exactly 0.6.0, is a literal used in src module folders + #- this version number, exactly 0.6.2, is a literal used in src module folders #- we refer to this sometimes as the magic version number - set version 0.6.0 + set version 0.6.2 }] return diff --git a/src/bootsupport/modules/voo-1.0.0.tm b/src/bootsupport/modules/voo-1.0.0.tm index a70a19be..64262b07 100644 --- a/src/bootsupport/modules/voo-1.0.0.tm +++ b/src/bootsupport/modules/voo-1.0.0.tm @@ -1,768 +1,768 @@ - -#https://github.com/AlaoPrado/voo -#License: MIT - -namespace eval voo { - # package version - variable version 1.0.0 - variable handlerToObjectMap {} - variable handlerCounter 0 - - - ##\brief Check if a namespace is a valid voo class - # \param[in] namespaceName the namespace to check - # \return 1 if valid voo class, 0 otherwise - proc isVooClass {namespaceName} { - if {![uplevel [list namespace exists $namespaceName]]} { - return 0 - } - return [expr {[uplevel [list namespace eval $namespaceName { - info exists __defaultObj - }]]}] - } - - ##\brief Declare a new voo class namespace and process its class body - # \param[in] args Arguments for class declaration: and optional -extends parent - # \note Creates the class namespace, imports parent fields/methods when using -extends, - # and registers constructors and exports - proc class {args} { - set optDict {} - set defaultArgs {} - set numArgs [llength $args] - for {set i 0} {$i < $numArgs} {incr i} { - set arg [lindex $args $i] - if {$arg eq "-extends"} { - if {$i + 1 >= $numArgs} { - error "Constructor option ’$arg’ requires an argument" - } - dict set optDict $arg [lindex $args [incr i]] - } elseif {$arg eq "-virtual" || $arg eq "-v"} { - dict set optDict "-virtual" {} - } else { - lappend defaultArgs $arg - } - } - lassign $defaultArgs className body - set vooNs [namespace current] - # create the namespace for the class - uplevel [list namespace eval $className [subst -nocommands { - namespace path [list $vooNs] - variable __defaultObj {} - variable __fields {} - variable __tmp_isPublicEnabled 1 - }]] - - uplevel [list namespace eval $className { - ##\brief Access default object for this class - # \return Default class instance (list) - # \note Used for inheritance and constructor defaults - proc class.defaultObj {} { - variable __defaultObj - return $__defaultObj - } - ##\brief Get list of field names for this class - # \return List of field names in declaration order - # \note Useful for introspection and constructor -name new.args - proc class.fields {} { - variable __fields - return $__fields - } - }] - - if {[dict exists $optDict -virtual] && [dict exists $optDict -extends]} { - error "voo::class: cannot use -virtual with -extends; child classes inherit virtual automatically from a -virtual parent" - } - - if {[dict exists $optDict -virtual]} { - set normalizedClassName [uplevel [list namespace eval $className {namespace current}]] - uplevel [list namespace eval $className [list variable __voo_is_virtual_class 1]] - uplevel [list namespace eval $className [list variable __voo_class_namespace $normalizedClassName]] - # Pre-populate __defaultObj with namespace tag at index 0 BEFORE field declarations - # so that _getClassCurrNumFields returns 1 for the first field declared - uplevel [list namespace eval $className [list set __defaultObj [list $normalizedClassName]]] - } - - #81 - # variable __parentClassNamespace {} - if {[dict exists $optDict -extends]} { - set parentClassName [dict get $optDict -extends] - - if {![uplevel [list namespace exists $parentClassName]]} { - error "Parent class ’$parentClassName’ does not exist." - } - - # check if parent class exists - if {![uplevel [list namespace eval $parentClassName {info exists __defaultObj}]]} { - error "Parent class ’$parentClassName’ is not a valid voo class." - } - - # normalize namespace name of parent class - set parentClassName [uplevel [list namespace eval $parentClassName { - namespace current - }]] - - uplevel [list namespace eval $className [subst -nocommands { - variable __parentClassNamespace $parentClassName - }]] - - # import parent’s default object values - set parentDefaultObj [${parentClassName}::class.defaultObj] - uplevel [list namespace eval $className [list set __defaultObj $parentDefaultObj]] - - - # if parent is virtual, update namespace tag at index 0 to child’s namespace - set parentIsVirtual [uplevel [list namespace eval $parentClassName {info exists __voo_is_virtual_class}]] - if {$parentIsVirtual} { - set normalizedChildName [uplevel [list namespace eval $className {namespace current}]] - uplevel [list namespace eval $className \ - [list set __defaultObj [lreplace $parentDefaultObj 0 0 $normalizedChildName]]] - uplevel [list namespace eval $className [list variable __voo_is_virtual_class 1]] - uplevel [list namespace eval $className [list variable __voo_class_namespace $normalizedChildName]] - } - - # 121 - # import parent’s field index variables by copying actual index values from parent - set parentFields [${parentClassName}::class.fields] - foreach field $parentFields { - set fieldIdx [uplevel [list namespace eval $parentClassName [list set $field]]] - uplevel [list namespace eval $className [list variable $field $fieldIdx]] - uplevel [list namespace eval $className [list lappend __fields $field]] - } - - # import parent’s acessors in child class with namespace import - uplevel [list namespace eval $className [subst -nocommands { - namespace import ${parentClassName}::get.* - namespace import ${parentClassName}::set.* - namespace import ${parentClassName}::update.* - }]] - } - - - # 136 - - uplevel [list namespace eval $className $body] - - uplevel [list namespace eval $className { - if {[info commands new] eq ""} { - constructor - } - if {[info commands new()] eq ""} { - constructor -noargs [_buildConstructorNoArgsBody] - } - if {[info commands new.args] eq ""} { - constructor -name new.args {args} [_buildConstructorArgsBody] - } - }] - - - # 151 - uplevel [list namespace eval $className { - # export class methods - namespace export * - }] - - uplevel [list namespace eval $className { - # clean temporary variable - unset __tmp_isPublicEnabled - }] - return - } - - # 161 - ##\brief Return the default value for a given field type - # \param[in] type the field type token (double,int,bool,...) - # \return The default value appropriate for the type - proc _getDefaultValueByType {type} { - switch -- $type { - double { return 0.0 } - int { return 0 } - bool { return 0 } - default { return {} } - } - } - - ##\brief Get the current number of fields declared in the current class - # \return Number of fields (integer) - proc _getClassCurrNumFields {} { - return [uplevel 2 {llength $__defaultObj}] - } - - ##\brief Check whether public mode is enabled during class body parsing - # \return 1 if public mode is enabled, 0 otherwise - proc _getClassIsPublicEnabled {} { - return [uplevel 2 {set __tmp_isPublicEnabled}] - } - - ##\brief Declare getter/setter/updater accessors for a class field - # \param[in] fieldName name of the field - # \param[in] isPublic boolean whether accessors are public - # \param[in] isStatic boolean whether field is static (class-level) - proc _declareFieldAcessors {fieldName isPublic isStatic} { - set prefix {} - - if {$isStatic} { - append prefix class. - } - if {!$isPublic} { - append prefix my. - } - set getterName "${prefix}get.$fieldName" - set setterName "${prefix}set.$fieldName" - set updaterName "${prefix}update.$fieldName" - if {$isStatic} { - uplevel 2 [list proc $getterName {} [subst -nocommands { - variable $fieldName - return $$fieldName - }]] - uplevel 2 [list proc $setterName {value} [subst -nocommands { - variable $fieldName - set $fieldName "\$value" - }]] - - uplevel 2 [list proc $updaterName {tempVar body} [subst -nocommands { - variable $fieldName - upvar "\$tempVar" temp - set temp $$fieldName - # break link with class variable to avoid copy-on-write - set $fieldName {} - try { - uplevel \$body - } finally { - set $fieldName "\$temp" - } - }]] - - } else { - uplevel 2 [list getter $getterName $fieldName] - uplevel 2 [list setter $setterName $fieldName] - uplevel 2 [list updater $updaterName $fieldName] - } - return - } - - ##\brief Validate a field name for illegal characters - # \param[in] fieldName the field name to validate - # \return Raises an error if invalid - proc _validateFieldName {fieldName} { - if {[string first "." $fieldName] != -1 || [string first "::" $fieldName] != -1} { - error "Field name ’$fieldName’ cannot contain ’.’ or ’::’ substrings." - } - } - - ##\brief Ensure a field name does not already exist in the class - # \param[in] fieldName the field name to check - # \return Raises an error if the field already exists - # \note Uses __fields for instance fields and fully-qualified namespace lookup for static - # fields to avoid false positives from global variables with the same name - proc _validateFieldDoesNotExist {fieldName} { - # Check instance fields tracked in __fields (class-scoped, no global bleed) - if {$fieldName in [uplevel 2 {set __fields}]} { - error "Field name ’$fieldName’ already exists in the class." - } - # Check static fields via fully-qualified namespace variable; info exists ::Ns::var - # only matches that exact namespace variable, never a same-named global - set classNs [uplevel 2 {namespace current}] - if {[info exists ${classNs}::$fieldName]} { - error "Field name ’$fieldName’ already exists in the class." - } - } - - ##\brief Validate a variable initial value according to its declared type - # \param[in] type the declared type (double,int,bool,list,dict) - # \param[in] value the value to validate - # \return Raises an error if the value does not match the type - proc _validateVarValueByType {type value} { - switch -- $type { - double { - if {[string is double -strict $value] == 0} { - error "Value for t_double must be a double, got ’$value’" - } - } - int { - if {[string is integer -strict $value] == 0} { - error "Value for t_int must be an integer, got ’$value’" - } - } - bool { - if {[string is boolean -strict $value] == 0} { - error "Value for t_bool must be a boolean, got ’$value’" - } - } - list { - if {[catch {llength $value}]} { - error "Value for t_list must be a list, got ’$value’" - } - } - dict { - if {[catch {dict size $value}]} { - error "Value for t_dict must be a dict, got ’$value’" - } - } - } - } - - ##\brief Declare a field variable inside the class body - # \param[in] type the field type token (double,int,string,bool,list,dict,obj) - # \param[in] argList arguments: ?-static? ?? - proc _var {type argList} { - set defaultArgs {} - set optDict {} - set numArgs [llength $argList] - for {set i 0} {$i < $numArgs} {incr i} { - set arg [lindex $argList $i] - if {$arg eq "-static"} { - dict set optDict $arg {} - } else { - lappend defaultArgs $arg - } - } - if {[llength $defaultArgs] == 0} { - error "Variable definition requires: ?