Browse Source

bootsupport, make.tcl, vendormodules, tomlish fixes + punk::winlnk

master
Julian Noble 3 months ago
parent
commit
8d60f2e1f8
  1. 200
      src/bootsupport/modules/oolib-0.1.1.tm
  2. 18
      src/bootsupport/modules/overtype-1.6.5.tm
  3. 28
      src/bootsupport/modules/punk/console-0.1.1.tm
  4. 165
      src/bootsupport/modules/punk/lib-0.1.1.tm
  5. 35
      src/bootsupport/modules/punk/mix/base-0.1.tm
  6. 6
      src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
  7. 68
      src/bootsupport/modules/punk/ns-0.1.0.tm
  8. 2
      src/bootsupport/modules/punk/repo-0.1.1.tm
  9. BIN
      src/bootsupport/modules/test/tomlish-1.1.1.tm
  10. 3658
      src/bootsupport/modules/tomlish-1.1.1.tm
  11. 214
      src/make.tcl
  12. 540
      src/modules/calculator_test-999999.0a1.0.tm
  13. 28
      src/modules/punk/console-999999.0a1.0.tm
  14. 165
      src/modules/punk/lib-999999.0a1.0.tm
  15. 35
      src/modules/punk/mix/base-0.1.tm
  16. 6
      src/modules/punk/mix/commandset/project-999999.0a1.0.tm
  17. 68
      src/modules/punk/ns-999999.0a1.0.tm
  18. 6
      src/modules/punk/repl-0.1.tm
  19. 2
      src/modules/punk/repo-999999.0a1.0.tm
  20. 561
      src/modules/punk/winlnk-999999.0a1.0.tm
  21. 3
      src/modules/punk/winlnk-buildversion.txt
  22. 8
      src/modules/shellfilter-0.1.9.tm
  23. 214
      src/project_layouts/custom/_project/punk.basic/src/make.tcl
  24. 200
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.1.tm
  25. 3685
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.4.tm
  26. 18
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm
  27. 28
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  28. 165
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
  29. 35
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm
  30. 6
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
  31. 68
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  32. 2
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm
  33. BIN
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm
  34. 3658
      src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.1.tm
  35. 214
      src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl
  36. 18
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm
  37. 28
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm
  38. 165
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm
  39. 35
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm
  40. 6
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm
  41. 68
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm
  42. 2
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm
  43. BIN
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm
  44. 3658
      src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.1.tm
  45. 214
      src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl
  46. 646
      src/project_layouts/vendor/punk/project-0.1/src/make.tcl
  47. 336
      src/vendormodules/fauxlink-0.1.0.tm
  48. 3
      src/vendormodules/include_modules.config
  49. 18
      src/vendormodules/overtype-1.6.5.tm
  50. BIN
      src/vendormodules/test/tomlish-1.1.1.tm
  51. 2952
      src/vendormodules/tomlish-1.1.1.tm
  52. 540
      src/vfs/_vfscommon/modules/calculator_test-0.1.tm
  53. BIN
      src/vfs/_vfscommon/modules/modpodtest-0.1.0.tm
  54. 18
      src/vfs/_vfscommon/modules/overtype-1.6.5.tm
  55. 28
      src/vfs/_vfscommon/modules/punk/console-0.1.1.tm
  56. 165
      src/vfs/_vfscommon/modules/punk/lib-0.1.1.tm
  57. 35
      src/vfs/_vfscommon/modules/punk/mix/base-0.1.tm
  58. 6
      src/vfs/_vfscommon/modules/punk/repl-0.1.tm
  59. 2
      src/vfs/_vfscommon/modules/punk/repo-0.1.1.tm
  60. 8
      src/vfs/_vfscommon/modules/shellfilter-0.1.9.tm
  61. BIN
      src/vfs/_vfscommon/modules/test/tomlish-1.1.1.tm
  62. 2557
      src/vfs/_vfscommon/modules/tomlish-1.1.1.tm
  63. BIN
      src/vfs/_vfscommon/modules/zipper-0.11.tm
  64. 75
      src/vfs/punk86.vfs/main.tcl
  65. 456
      src/vfs/punk86.vfs/main.tcl.xxx
  66. 57
      src/vfs/punk86bawt.vfs/main.tcl
  67. 57
      src/vfs/punk8win.vfs/main.tcl
  68. 345
      src/vfs/punk9linux.vfs/main.tcl
  69. 27
      src/vfs/punk9win.vfs/main.tcl

200
src/bootsupport/modules/oolib-0.1.1.tm

@ -1,200 +0,0 @@
#JMN - api should be kept in sync with package patternlib where possible
#
package provide oolib [namespace eval oolib {
variable version
set version 0.1.1
}]
namespace eval oolib {
oo::class create collection {
variable o_data ;#dict
variable o_alias
constructor {} {
set o_data [dict create]
}
method info {} {
return [dict info $o_data]
}
method count {} {
return [dict size $o_data]
}
method isEmpty {} {
expr {[dict size $o_data] == 0}
}
method names {{globOrIdx {}}} {
if {[llength $globOrIdx]} {
if {[string is integer -strict $globOrIdx]} {
set idx $globOrIdx
if {$idx < 0} {
set idx "end-[expr {abs($idx + 1)}]"
}
if {[catch {lindex [dict keys $o_data] $idx} result]} {
error "[self object] no such index : '$idx'"
} else {
return $result
}
} else {
#glob
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx]
}
} else {
return [dict keys $o_data]
}
}
#like names but without globbing
method keys {} {
dict keys $o_data
}
method key {{posn 0}} {
if {$posn < 0} {
set posn "end-[expr {abs($posn + 1)}]"
}
if {[catch {lindex [dict keys $o_data] $posn} result]} {
error "[self object] no such index : '$posn'"
} else {
return $result
}
}
method hasKey {key} {
dict exists $o_data $key
}
method get {} {
return $o_data
}
method items {} {
return [dict values $o_data]
}
method item {key} {
if {[string is integer -strict $key]} {
if {$key >= 0} {
set valposn [expr {(2*$key) +1}]
return [lindex $o_data $valposn]
} else {
set key "end-[expr {abs($key + 1)}]"
return [lindex $o_data $key]
#return [lindex [dict keys $o_data] $key]
}
}
if {[dict exists $o_data $key]} {
return [dict get $o_data $key]
}
}
#inverse lookup
method itemKeys {value} {
set value_indices [lsearch -all [dict values $o_data] $value]
set keylist [list]
foreach i $value_indices {
set idx [expr {(($i + 1) *2) -2}]
lappend keylist [lindex $o_data $idx]
}
return $keylist
}
method search {value args} {
set matches [lsearch {*}$args [dict values $o_data] $value]
if {"-inline" in $args} {
return $matches
} else {
set keylist [list]
foreach i $matches {
set idx [expr {(($i + 1) *2) -2}]
lappend keylist [lindex $o_data $idx]
}
return $keylist
}
}
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists?
method alias {newAlias existingKeyOrAlias} {
if {[string is integer -strict $newAlias]} {
error "[self object] collection key alias cannot be integer"
}
if {[string length $existingKeyOrAlias]} {
set o_alias($newAlias) $existingKeyOrAlias
} else {
unset o_alias($newAlias)
}
}
method aliases {{key ""}} {
if {[string length $key]} {
set result [list]
foreach {n v} [array get o_alias] {
if {$v eq $key} {
lappend result $n $v
}
}
return $result
} else {
return [array get o_alias]
}
}
#if the supplied index is an alias, return the underlying key; else return the index supplied.
method realKey {idx} {
if {[catch {set o_alias($idx)} key]} {
return $idx
} else {
return $key
}
}
method add {value key} {
if {[string is integer -strict $key]} {
error "[self object] collection key must not be an integer. Use another structure if integer keys required"
}
if {[dict exists $o_data $key]} {
error "[self object] col_processors object error: key '$key' already exists in collection"
}
dict set o_data $key $value
return [expr {[dict size $o_data] - 1}] ;#return index of item
}
method remove {idx {endRange ""}} {
if {[string length $endRange]} {
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time"
}
if {[string is integer -strict $idx]} {
if {$idx < 0} {
set idx "end-[expr {abs($idx+1)}]"
}
set key [lindex [dict keys $o_data] $idx]
set posn $idx
} else {
set key $idx
set posn [lsearch -exact [dict keys $o_data] $key]
if {$posn < 0} {
error "[self object] no such index: '$idx' in this collection"
}
}
dict unset o_data $key
return
}
method clear {} {
set o_data [dict create]
return
}
method reverse_the_collection {} {
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy.
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations.
set dictnew [dict create]
foreach k [lreverse [dict keys $o_data]] {
dict set dictnew $k [dict get $o_data $k]
}
set o_data $dictnew
return
}
#review - cmd as list vs cmd as script?
method map {cmd} {
set seed [list]
dict for {k v} $o_data {
lappend seed [uplevel #0 [list {*}$cmd $v]]
}
return $seed
}
method objectmap {cmd} {
set seed [list]
dict for {k v} $o_data {
lappend seed [uplevel #0 [list $v {*}$cmd]]
}
return $seed
}
}
}

18
src/bootsupport/modules/overtype-1.6.5.tm

@ -439,7 +439,8 @@ tcl::namespace::eval overtype {
if {[llength $lflines]} { if {[llength $lflines]} {
lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1]
} }
set inputchunks $lflines[unset lflines] #set inputchunks $lflines[unset lflines]
set inputchunks [lindex [list $lflines [unset lflines]] 0]
} }
} }
@ -2115,6 +2116,7 @@ tcl::namespace::eval overtype {
if {[llength $undercols]< $opt_width} { if {[llength $undercols]< $opt_width} {
set diff [expr {$opt_width- [llength $undercols]}] set diff [expr {$opt_width- [llength $undercols]}]
if {$diff > 0} { if {$diff > 0} {
#set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower
lappend undercols {*}[lrepeat $diff "\u0000"] lappend undercols {*}[lrepeat $diff "\u0000"]
lappend understacks {*}[lrepeat $diff $cs] lappend understacks {*}[lrepeat $diff $cs]
lappend understacks_gx {*}[lrepeat $diff $gs] lappend understacks_gx {*}[lrepeat $diff $gs]
@ -3889,7 +3891,19 @@ tcl::namespace::eval overtype {
#OSC 4 - set colour palette #OSC 4 - set colour palette
#can take multiple params #can take multiple params
#e.g \x1b\]4\;1\;red\;2\;green\x1b\\ #e.g \x1b\]4\;1\;red\;2\;green\x1b\\
set params [tcl::string::range $code_content 1 end] set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon
set cmap [dict create]
foreach {cnum spec} [split $params {;}] {
if {$cnum >= 0 and $cnum <= 255} {
#todo - parse spec from names like 'red' to RGB
#todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc)
#also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ?
dict set cmap $cnum $spec
} else {
#todo - log
puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"

28
src/bootsupport/modules/punk/console-0.1.1.tm

@ -183,7 +183,9 @@ namespace eval punk::console {
variable previous_stty_state_$channel variable previous_stty_state_$channel
set sttycmd [auto_execok stty] set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} { if {[set previous_stty_state_$channel] eq ""} {
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] if {[catch {{*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
} }
exec {*}$sttycmd raw -echo <@$channel exec {*}$sttycmd raw -echo <@$channel
@ -253,13 +255,21 @@ namespace eval punk::console {
return "line" return "line"
} }
} elseif {$raw_or_line eq "raw"} { } elseif {$raw_or_line eq "raw"} {
punk::console::enableRaw if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} { if {[can_ansi]} {
punk::console::enableVirtualTerminal both punk::console::enableVirtualTerminal both
} }
} elseif {$raw_or_line eq "line"} { } elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
punk::console::disableRaw if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} { if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes punk::console::enableVirtualTerminal output ;#display/use ansi codes
@ -290,12 +300,15 @@ namespace eval punk::console {
set loadstate [zzzload::pkg_require twapi] set loadstate [zzzload::pkg_require twapi]
#loadstate could also be stuck on loading? - review - zzzload not very ripe #loadstate could also be stuck on loading? - review - zzzload not very ripe
#Twapi is relatively slow to load - can be 1s plus in normal cases - and much longer if there are disk performance issues. #Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues.
if {$loadstate ni [list failed]} { if {$loadstate ni [list failed]} {
#possibly still 'loading'
#review zzzload usage #review zzzload usage
#puts stdout "=========== console loading twapi =============" #puts stdout "=========== console loading twapi ============="
zzzload::pkg_wait twapi set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait
}
if {$loadstate ni [list failed]} {
package require twapi ;#should be fast once twapi dll loaded in zzzload thread package require twapi ;#should be fast once twapi dll loaded in zzzload thread
set ::punk::console::has_twapi 1 set ::punk::console::has_twapi 1
@ -523,6 +536,9 @@ namespace eval punk::console {
set is_raw 0 set is_raw 0
return [list stdin [list from $oldmode to $newmode]] return [list stdin [list from $oldmode to $newmode]]
} elseif {[set sttycmd [auto_execok stty]] ne ""} { } elseif {[set sttycmd [auto_execok stty]] ne ""} {
#stty can return info on windows - but doesn't seem to be able to set anything.
#review - is returned info even valid?
set sttycmd [auto_execok stty] set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} { if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel] exec {*}$sttycmd [set previous_stty_state_$channel]

165
src/bootsupport/modules/punk/lib-0.1.1.tm

@ -339,6 +339,92 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}] set has_twapi [expr {![catch {package require twapi}]}]
} }
# -- ---
#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
#8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows
# Review and retest as new versions come out.
# -- ---
proc list_multi_append1 {lvar1 lvar2} {
#clear winner in 2024
upvar $lvar1 l1 $lvar2 l2
lappend l1 {*}$l2
return $l1
}
proc list_multi_append2 {lvar1 lvar2} {
upvar $lvar1 l1 $lvar2 l2
set l1 [list {*}$l1 {*}$l2]
}
proc list_multi_append3 {lvar1 lvar2} {
upvar $lvar1 l1 $lvar2 l2
set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0]
}
#testing e.g
#set l1_reset {a b c}
#set l2 {a b c d e f g}
#set l1 $l1_reset
#time {list_multi_append1 l1 l2} 1000
#set l1 $l1_reset
#time {list_multi_append2 l1 l2} 1000
# -- ---
proc lswap {lvar a z} {
upvar $lvar l
if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} {
#if we didn't do this check - we could raise an error on second lset - leaving list corrupted because only one lset occurred
#(e.g using: lswap mylist end-2 end on a two element list)
#on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report
set a_index [lindex_resolve $l $a]
set a_msg ""
switch -- $a_index {
-2 {
"$a is greater th
}
-3 {
}
}
error "lswap cannot indices $a and $z $a is out of range"
}
set item2 [lindex $l $z]
lset l $z [lindex $l $a]
lset l $a $item2
return $l
}
#proc lswap2 {lvar a z} {
# upvar $lvar l
# #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower
# set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]]
#}
proc lswap2 {lvar a z} {
upvar $lvar l
#if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower
set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]]
}
#an experimental test of swapping vars without intermediate variables
#It's an interesting idea - but probably of little to no practical use
# - the swap_intvars3 version using intermediate var is faster in Tcl
# - This is probably unsurprising - as it's simpler code.
# Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks.
#proc swap_intvars {swapv1 swapv2} {
# upvar $swapv1 _x $swapv2 _y
# set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}]
#}
#proc swap_intvars2 {swapv1 swapv2} {
# upvar $swapv1 _x $swapv2 _y
# set _x [expr {$_x ^ $_y}]
# set _y [expr {$_x ^ $_y}]
# set _x [expr {$_x ^ $_y}]
#}
#proc swap_intvars3 {swapv1 swapv2} {
# #using intermediate variable
# upvar $swapv1 _x $swapv2 _y
# set z $_x
# set _x $_y
# set _y $z
#}
#*** !doctools #*** !doctools
#[subsection {Namespace punk::lib}] #[subsection {Namespace punk::lib}]
@ -347,6 +433,7 @@ namespace eval punk::lib {
if {[info commands lseq] ne ""} { if {[info commands lseq] ne ""} {
#tcl 8.7+ lseq significantly faster, especially for larger ranges #tcl 8.7+ lseq significantly faster, especially for larger ranges
#The internal rep can be an 'arithseries' with no string representation
#support minimal set from to #support minimal set from to
proc range {from to} { proc range {from to} {
lseq $from $to lseq $from $to
@ -1009,24 +1096,28 @@ namespace eval punk::lib {
} }
set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high
#keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds
if {${lower_resolve} == -1} { if {${lower_resolve} == -2} {
##x
#lower bound is above upper list range #lower bound is above upper list range
#match with decreasing indices is still possible #match with decreasing indices is still possible
set lower [expr {[llength $dval]-1}] ;#set to max set lower [expr {[llength $dval]-1}] ;#set to max
} elseif {$lower_resolve == -2} { } elseif {$lower_resolve == -3} {
##x
set lower 0 set lower 0
} else { } else {
set lower $lower_resolve set lower $lower_resolve
} }
set upper [punk::lib::lindex_resolve $dval $b] set upper [punk::lib::lindex_resolve $dval $b]
if {$upper == -2} { if {$upper == -3} {
##x
#upper bound is below list range - #upper bound is below list range -
if {$lower_resolve >=-1} { if {$lower_resolve >=-2} {
##x
set upper 0 set upper 0
} else { } else {
continue continue
} }
} elseif {$upper == -1} { } elseif {$upper == -2} {
#use max #use max
set upper [expr {[llength $dval]-1}] set upper [expr {[llength $dval]-1}]
#assert - upper >=0 because we have ruled out empty lists #assert - upper >=0 because we have ruled out empty lists
@ -1670,6 +1761,7 @@ namespace eval punk::lib {
} }
} }
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side
proc lindex_resolve {list index} { proc lindex_resolve {list index} {
#*** !doctools #*** !doctools
#[call [fun lindex_resolve] [arg list] [arg index]] #[call [fun lindex_resolve] [arg list] [arg index]]
@ -1679,11 +1771,13 @@ namespace eval punk::lib {
#[para]Sometimes the actual integer index is desired. #[para]Sometimes the actual integer index is desired.
#[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks.
#[para]lindex_resolve will parse the index expression and return: #[para]lindex_resolve will parse the index expression and return:
#[para] a) -2 if the supplied index expression is below the lower bound for the supplied list. (< 0) #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
#[para] b) -1 if the supplied index expression is above the upper bound for the supplied list. (> end) #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end)
#[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list
#[para]Otherwise it will return an integer corresponding to the position in the list. #[para]Otherwise it will return an integer corresponding to the position in the list.
#[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway. #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway.
#[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable
#[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2
#Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr
#if {![llength $list]} { #if {![llength $list]} {
@ -1694,9 +1788,9 @@ namespace eval punk::lib {
if {[string is integer -strict $index]} { if {[string is integer -strict $index]} {
#can match +i -i #can match +i -i
if {$index < 0} { if {$index < 0} {
return -2 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= [llength $list]} {
return -1 return -2
} else { } else {
#integer may still have + sign - normalize with expr #integer may still have + sign - normalize with expr
return [expr {$index}] return [expr {$index}]
@ -1708,14 +1802,14 @@ namespace eval punk::lib {
set offset [string range $index 4 end] set offset [string range $index 4 end]
if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"}
if {$op eq "+" && $offset != 0} { if {$op eq "+" && $offset != 0} {
return -1 return -2
} }
} else { } else {
#end #index is 'end'
set index [expr {[llength $list]-1}] set index [expr {[llength $list]-1}]
if {$index < 0} { if {$index < 0} {
#special case - end with empty list - treat end like a positive number out of bounds #special case - 'end' with empty list - treat end like a positive number out of bounds
return -1 return -2
} else { } else {
return $index return $index
} }
@ -1723,7 +1817,7 @@ namespace eval punk::lib {
if {$offset == 0} { if {$offset == 0} {
set index [expr {[llength $list]-1}] set index [expr {[llength $list]-1}]
if {$index < 0} { if {$index < 0} {
return -1 ;#special case return -2 ;#special case as above
} else { } else {
return $index return $index
} }
@ -1732,7 +1826,7 @@ namespace eval punk::lib {
set index [expr {([llength $list]-1) - $offset}] set index [expr {([llength $list]-1) - $offset}]
} }
if {$index < 0} { if {$index < 0} {
return -2 return -3
} else { } else {
return $index return $index
} }
@ -1753,26 +1847,50 @@ namespace eval punk::lib {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
} }
if {$index < 0} { if {$index < 0} {
return -2 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= [llength $list]} {
return -1 return -2
} }
return $index return $index
} }
} }
} }
proc lindex_resolve2 {list index} { proc lindex_resolve_basic {list index} {
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. #*** !doctools
#[call [fun lindex_resolve_basic] [arg list] [arg index]]
#[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2)
#[para] returns -1 for out of range at either end, or a valid integer index
#[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound
#[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command
#[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1
#[para] For pure integer indices the performance should be equivalent
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+
# - which
#for {set i 0} {$i < [llength $list]} {incr i} { #for {set i 0} {$i < [llength $list]} {incr i} {
# lappend indices $i # lappend indices $i
#} #}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
#avoid even the lseq overhead when the index is simple
if {$index < 0 || ($index >= [llength $list])} {
#even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method.
return -1
} else {
#integer may still have + sign - normalize with expr
return [expr {$index}]
}
}
if {[llength $list]} { if {[llength $list]} {
set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback.
#if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?)
} else { } else {
set indices [list] set indices [list]
} }
set idx [lindex $indices $index] set idx [lindex $indices $index]
if {$idx eq ""} { if {$idx eq ""} {
#we have no way to determine if out of bounds is at lower vs upper end
return -1 return -1
} else { } else {
return $idx return $idx
@ -2334,13 +2452,6 @@ namespace eval punk::lib {
} }
return $prefix return $prefix
} }
#test example of the technique - not necessarily particularly useful as a function, except maybe for brevity/clarity. todo - test if inlined version gives any perf advantage compared to a temp var
proc swapnumvars {namea nameb} {
upvar $namea a $nameb b
set a [expr {$a ^ $b}]
set b [expr {$a ^ $b}]
set a [expr {$a ^ $b}]
}
#e.g linesort -decreasing $data #e.g linesort -decreasing $data
proc linesort {args} { proc linesort {args} {
@ -2956,7 +3067,7 @@ namespace eval punk::lib {
# and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]*
proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} {
set number [punk::objclone $unformattednumber] set number [objclone $unformattednumber]
set number [string map {_ ""} $number] set number [string map {_ ""} $number]
#normalize using expr - e.g 2e4 -> 20000.0 #normalize using expr - e.g 2e4 -> 20000.0
set number [expr {$number}] set number [expr {$number}]

35
src/bootsupport/modules/punk/mix/base-0.1.tm

@ -4,6 +4,7 @@ package provide punk::mix::base [namespace eval punk::mix::base {
}] }]
package require punk::path package require punk::path
package require punk::lib ;#format_number etc
#base internal plumbing functions #base internal plumbing functions
namespace eval punk::mix::base { namespace eval punk::mix::base {
@ -657,16 +658,38 @@ namespace eval punk::mix::base {
#temp emission to stdout.. todo - repl telemetry channel #temp emission to stdout.. todo - repl telemetry channel
puts stdout "cksum_path: creating temporary tar archive for $path" puts stdout "cksum_path: creating temporary tar archive for $path"
puts stdout " at: $archivename .." puts -nonewline stdout " at: $archivename ..."
tar::create $archivename $target set tsstart [clock millis]
if {[set tarpath [auto_execok tar]] ne ""} {
#using an external binary is *significantly* faster than tar::create - but comes with some risks
#review - need to check behaviour/flag variances across platforms
#don't use -z flag. On at least some tar versions the zipped file will contain a timestamped subfolder of filename.tar - which ruins the checksum
#also - tar is generally faster without the compression (although this may vary depending on file size and disk speed?)
exec {*}$tarpath -cf $archivename $target ;#{*} needed in case spaces in tarpath
set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " tar -cf done ($ms ms)"
} else {
set tsstart [clock millis] ;#don't include auto_exec search time for tar::create
tar::create $archivename $target
set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " tar::create done ($ms ms)"
puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing"
}
if {$ftype eq "file"} { if {$ftype eq "file"} {
set sizeinfo "(size [file size $target])" set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)"
} else { } else {
set sizeinfo "(file type $ftype - size unknown)" set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)"
} }
puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." set tsstart [clock millis]
puts -nonewline stdout "cksum_path: calculating cksum for $target $sizeinfo ... "
set cksum [{*}$cksum_command $archivename] set cksum [{*}$cksum_command $archivename]
#puts stdout "cksum_path: cleaning up.. " set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " cksum done ($ms ms)"
puts stdout " cksum: $cksum"
file delete -force $archivename file delete -force $archivename
cd $startdir cd $startdir

6
src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm

@ -157,6 +157,9 @@ namespace eval punk::mix::commandset::project {
set opt_force [dict get $opts -force] set opt_force [dict get $opts -force]
set opt_confirm [string tolower [dict get $opts -confirm]] set opt_confirm [string tolower [dict get $opts -confirm]]
# -- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_layout [dict get $opts -layout]
set opt_update [dict get $opts -update]
# -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_modules [dict get $opts -modules] set opt_modules [dict get $opts -modules]
if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} {
#if not specified - add a single module matching project name #if not specified - add a single module matching project name
@ -169,9 +172,6 @@ namespace eval punk::mix::commandset::project {
} }
} }
# -- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_layout [dict get $opts -layout]
set opt_update [dict get $opts -update]
# -- --- --- --- --- --- --- --- --- --- --- --- ---
#todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache

68
src/bootsupport/modules/punk/ns-0.1.0.tm

@ -1707,6 +1707,7 @@ tcl::namespace::eval punk::ns {
lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs
set use_vars [expr {"-vars" in $runopts}] set use_vars [expr {"-vars" in $runopts}]
set no_warnings [expr {"-nowarnings" in $runopts}] set no_warnings [expr {"-nowarnings" in $runopts}]
set ver ""
#todo support leading solo flags such as -capture to control whether we do a static capture of local vars in the ns #todo support leading solo flags such as -capture to control whether we do a static capture of local vars in the ns
@ -1717,15 +1718,68 @@ tcl::namespace::eval punk::ns {
} }
default { default {
if {[string match ::* $pkg_or_existing_ns]} { if {[string match ::* $pkg_or_existing_ns]} {
set pkg_unqualified [string range $pkg_or_existing_ns 2 end]
if {![tcl::namespace::exists $pkg_or_existing_ns]} { if {![tcl::namespace::exists $pkg_or_existing_ns]} {
set ver [package require [string range $pkg_or_existing_ns 2 end]] set ver [package require $pkg_unqualified]
} else { } else {
set ver "" set ver ""
} }
set ns $pkg_or_existing_ns set ns $pkg_or_existing_ns
} else { } else {
set ver [package require $pkg_or_existing_ns] set pkg_unqualified $pkg_or_existing_ns
set ns ::$pkg_or_existing_ns set ver [package require $pkg_unqualified]
set ns ::$pkg_unqualified
}
#some packages don't create their namespace immediately and/or don't populate it with commands and instead put entries in ::auto_index
set previous_command_count 0
if {[namespace exists $ns]} {
set previous_command_count [llength [info commands ${ns}::*]]
}
#also if a sub package was loaded first - then the namespace for the base or lower package may exist but have no commands
#for the purposes of pkguse - which most commonly interactive - we want the namespace populated
#It may still not be *fully* populated because we stop at first source that adds commands - REVIEW
set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}]
if {!$ns_populated} {
#we will catch-run an auto_index entry if any
#auto_index entry may or may not be prefixed with ::
set keys [list]
#first look for exact pkg_unqualified and ::pkg_unqualified
#leave these at beginning of keys list
if {[array exists ::auto_index($pkg_unqualified)]} {
lappend keys $pkg_unqualified
}
if {[array exists ::auto_index(::$pkg_unqualified)]} {
lappend keys ::$pkg_unqualified
}
#as auto_index is an array - we could get keys in arbitrary order
set matches [lsort [array names ::auto_index ${pkg_unqualified}::*]]
lappend keys {*}$matches
set matches [lsort [array names ::auto_index ::${pkg_unqualified}::*]]
lappend keys {*}$matches
set ns_populated 0
set i 0
set already_sourced [list] ;#often multiple triggers for the same source - don't waste time re-sourcing
set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]]
while {!$ns_populated && $i < [llength $keys]} {
#todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base
#e.g if we are loading ::x::y
#only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc
set k [lindex $keys $i]
set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]]
if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} {
set auto_source [set ::auto_index($k)]
if {$auto_source ni $already_sourced} {
uplevel 1 $auto_source
lappend already_sourced $auto_source
set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}]
}
}
incr i
}
} }
} }
} }
@ -1799,7 +1853,13 @@ tcl::namespace::eval punk::ns {
return $out return $out
} }
} else { } else {
error "Namespace $ns not found." if {$ver eq ""} {
error "Namespace $ns not found. No package version found."
} else {
set out "(no package namespace found) remaining in [uplevel 1 {namespace current}]"
append out \n $ver
return $out
}
} }
return $out return $out
} }

2
src/bootsupport/modules/punk/repo-0.1.1.tm

@ -468,7 +468,7 @@ namespace eval punk::repo {
set path [string trim [string range $ln [string length "MISSING "] end]] set path [string trim [string range $ln [string length "MISSING "] end]]
dict set pathdict $path "missing" dict set pathdict $path "missing"
} }
"EXTRA * " { "EXTRA *" {
#fossil will explicitly list files in a new folder - as opposed to git which shows just the folder #fossil will explicitly list files in a new folder - as opposed to git which shows just the folder
set path [string trim [string range $ln [string length "EXTRA "] end]] set path [string trim [string range $ln [string length "EXTRA "] end]]
dict set pathdict $path "extra" dict set pathdict $path "extra"

BIN
src/bootsupport/modules/test/tomlish-1.1.1.tm

Binary file not shown.

3658
src/bootsupport/modules/tomlish-1.1.1.tm

File diff suppressed because it is too large Load Diff

214
src/make.tcl

@ -13,7 +13,7 @@ namespace eval ::punkmake {
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k] variable non_help_flags [list -k]
variable help_flags [list -help --help /?] variable help_flags [list -help --help /?]
variable known_commands [list project get-project-info shell vendorupdate bootsupport vfscommonupdate] variable known_commands [list project modules info check shell vendorupdate bootsupport vfscommonupdate]
} }
if {"::try" ni [info commands ::try]} { if {"::try" ni [info commands ::try]} {
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting"
@ -21,7 +21,7 @@ if {"::try" ni [info commands ::try]} {
} }
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
#Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder #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 the there is a folder under the current directory /src/bootsupport/modules which contains .tm files
# - then it will attempt to preference these modules # - then it will attempt to preference these modules
@ -35,8 +35,10 @@ if {[file exists [file join $startdir src bootsupport]]} {
set bootsupport_mod [file join $startdir bootsupport modules] set bootsupport_mod [file join $startdir bootsupport modules]
set bootsupport_lib [file join $startdir bootsupport lib] set bootsupport_lib [file join $startdir bootsupport lib]
} }
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
set package_paths_modified 0
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
set original_tm_list [tcl::tm::list] set original_tm_list [tcl::tm::list]
tcl::tm::remove {*}$original_tm_list tcl::tm::remove {*}$original_tm_list
set original_auto_path $::auto_path set original_auto_path $::auto_path
@ -63,8 +65,18 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
} }
if {[file exists [pwd]/modules]} { #we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir.
tcl::tm::add [pwd]/modules #The <projectdir>/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 <projectdir/src is also likely to be common
# but we need to be loud about what's going on.
puts stderr "------------------------------------------------------------------"
puts stderr "Launched from within a folder ending in 'src'"
puts stderr " - modules in $startdir/modules may override bootsupport modules"
puts stderr "------------------------------------------------------------------"
tcl::tm::add $startdir/modules
}
} }
#package require Thread #package require Thread
@ -81,16 +93,8 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
package require punkcheck package require punkcheck
package require punk::lib package require punk::lib
set package_paths_modified 1
#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]
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
} }
@ -106,6 +110,8 @@ try {
} }
package require punk::mix package require punk::mix
package require punk::repo package require punk::repo
package require punk::ansi
package require overtype
} finally { } finally {
catch {rename ::package ""} catch {rename ::package ""}
catch {rename ::punkmake::package_temp_aside ::package} catch {rename ::punkmake::package_temp_aside ::package}
@ -129,18 +135,24 @@ proc punkmake_gethelp {args} {
append h "Usage:" \n append h "Usage:" \n
append h "" \n append h "" \n
append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n
append h " - This help." \n \n append h " - This help." \n \n
append h " $scriptname project ?-k?" \n append h " $scriptname project ?-k?" \n
append h " - this is the literal word project - and confirms you want to run the project build" \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 \n append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n
append h " - built modules go into <projectdir>/modules <projectdir>/lib etc." \n \n
append h " $scriptname modules" \n
append h " - build modules from src/modules etc without scanning src/runtime and src/vfs folders to build kit/zipkit executables" \n \n
append h " $scriptname bootsupport" \n append h " $scriptname bootsupport" \n
append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n \n append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n
append h " - bootsupport modules are available to make.tcl" \n \n
append h " $scriptname vendorupdate" \n append h " $scriptname vendorupdate" \n
append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n
append h " $scriptname vfscommonupdate" \n append h " $scriptname vfscommonupdate" \n
append h " - update the src/vfs/_vfscommon from compiled src/modules and src/lib" \n \n append h " - update the src/vfs/_vfscommon from compiled src/modules and src/lib etc" \n
append h " $scriptname get-project-info" \n append h " - before calling this (followed by make project) - you can test using '<builtexe>(.exe) dev'" \n
append h " - show the name and base folder of the project to be built" \n append h " this will load modules from your <projectdir>/module <projectdir>/lib paths instead of from the kit/zipkit" \n \n
append h " $scriptname info" \n
append h " - show the name and base folder of the project to be built" \n
append h "" \n append h "" \n
if {[llength $::punkmake::pkg_missing]} { if {[llength $::punkmake::pkg_missing]} {
append h "* ** NOTE ** ***" \n append h "* ** NOTE ** ***" \n
@ -220,12 +232,68 @@ if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]}
} }
set sourcefolder $projectroot/src set sourcefolder $projectroot/src
if {$::punkmake::command eq "check"} {
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 v [package require punk::mix::base]
puts stdout "punk::mix::base version $v\n[package ifneeded punk::mix::base $v]"
exit 0
}
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]
}
if {$::punkmake::command eq "get-project-info"} { if {$::punkmake::command eq "info"} {
puts stdout "- -- --- --- --- --- --- --- --- --- ---" puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
puts stdout "- -- get-project-info -- -" puts stdout "- -- info -- -"
puts stdout "- -- --- --- --- --- --- --- --- --- ---" puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
puts stdout "- projectroot : $projectroot" puts stdout "- projectroot : $projectroot"
set sourcefolder $projectroot/src
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*]
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*]
puts stdout "- vendorlib folders: ([llength $vendorlibfolders])"
foreach fld $vendorlibfolders {
puts stdout " src/$fld"
}
puts stdout "- vendormodule folders: ([llength $vendormodulefolders])"
foreach fld $vendormodulefolders {
puts stdout " src/$fld"
}
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot]
puts stdout "- source module paths: [llength $source_module_folderlist]"
foreach fld $source_module_folderlist {
puts stdout " $fld"
}
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*]
lappend projectlibfolders lib
puts stdout "- source libary paths: [llength $projectlibfolders]"
foreach fld $projectlibfolders {
puts stdout " src/$fld"
}
if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} {
set vc "fossil" set vc "fossil"
set rev [punk::repo::fossil_revision $scriptfolder] set rev [punk::repo::fossil_revision $scriptfolder]
@ -241,8 +309,11 @@ if {$::punkmake::command eq "get-project-info"} {
} }
puts stdout "- version control : $vc" puts stdout "- version control : $vc"
puts stdout "- revision : $rev" puts stdout "- revision : $rev"
puts stdout "- remote : $rem" puts stdout "- remote"
puts stdout "- -- --- --- --- --- --- --- --- --- ---" foreach ln [split $rem \n] {
puts stdout " $ln"
}
puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
exit 0 exit 0
} }
@ -564,7 +635,7 @@ if {$::punkmake::command eq "bootsupport"} {
if {$::punkmake::command ne "project"} { if {$::punkmake::command ni {project modules}} {
puts stderr "Command $::punkmake::command not implemented - aborting." puts stderr "Command $::punkmake::command not implemented - aborting."
flush stderr flush stderr
after 100 after 100
@ -803,6 +874,19 @@ if {[punk::repo::is_fossil_root $projectroot]} {
$installer destroy $installer destroy
} }
if {$::punkmake::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"
puts stdout " - use 'make.tcl project' to build executable kits/zipkits from vfs folders as well if you have runtimes installed"
puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but"
puts stdout " without the latest built modules."
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'"
puts stdout "-done-"
exit 0
}
set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder]
if {$buildfolder ne "$sourcefolder/_build"} { if {$buildfolder ne "$sourcefolder/_build"} {
puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure" puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure"
@ -832,10 +916,12 @@ if {![llength $runtimes]} {
exit 0 exit 0
} }
set has_sdx 1
if {[catch {exec sdx help} errM]} { if {[catch {exec sdx help} errM]} {
puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" puts stderr "FAILED to find usable sdx command - check that sdx executable is on path"
puts stderr "err: $errM" puts stderr "err: $errM"
exit 1 #exit 1
set has_sdx 0
} }
# -- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- ---
@ -1025,6 +1111,8 @@ foreach runtimefile $runtimes {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set failed_kits [list] set failed_kits [list]
set installed_kits [list] set installed_kits [list]
set skipped_kits [list]
set skipped_kit_installs [list]
proc ::make_file_traversal_error {args} { proc ::make_file_traversal_error {args} {
error "file_traverse error: $args" error "file_traverse error: $args"
@ -1304,30 +1392,39 @@ foreach vfstail $vfs_tails {
} }
} }
kit { kit {
if {[catch { if {!$has_sdx} {
if {$rtname ne "-"} { puts stderr "no sdx available to wrap $targetkit"
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"]
} else {
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose
}
} result]} {
if {$rtname ne "-"} {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result"
} else {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose failed with msg: $result"
}
puts stderr "sdx wrap $targetkit failed"
lappend failed_kits [list kit $targetkit reason $sdxmsg]
$vfs_event targetset_end FAILED $vfs_event targetset_end FAILED
$vfs_event destroy $vfs_event destroy
$vfs_installer destroy $vfs_installer destroy
continue continue
} else { } else {
puts stdout "ok - finished sdx" if {[catch {
set separator [string repeat = 40] if {$rtname ne "-"} {
puts stdout $separator exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose
puts stdout $result } else {
puts stdout $separator exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose
}
} result]} {
if {$rtname ne "-"} {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result"
} else {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose failed with msg: $result"
}
puts stderr "sdx wrap $targetkit failed"
lappend failed_kits [list kit $targetkit reason $sdxmsg]
$vfs_event targetset_end FAILED
$vfs_event destroy
$vfs_installer destroy
continue
} else {
puts stdout "ok - finished sdx"
set separator [string repeat = 40]
puts stdout $separator
puts stdout $result
puts stdout $separator
}
} }
} }
} }
@ -1435,6 +1532,7 @@ foreach vfstail $vfs_tails {
set skipped_vfs_build 1 set skipped_vfs_build 1
puts stderr "." puts stderr "."
puts stdout "Skipping build for vfs $vfstail with runtime $rtname - no change detected" puts stdout "Skipping build for vfs $vfstail with runtime $rtname - no change detected"
lappend skipped_kits [list kit $targetkit reason "no change detected"]
$vfs_event targetset_end SKIPPED $vfs_event targetset_end SKIPPED
} }
$vfs_event destroy $vfs_event destroy
@ -1489,6 +1587,7 @@ foreach vfstail $vfs_tails {
set skipped_kit_install 1 set skipped_kit_install 1
puts stderr "." puts stderr "."
puts stdout "Skipping kit install for $targetkit with vfs $vfstail runtime $rtname - no change detected" puts stdout "Skipping kit install for $targetkit with vfs $vfstail runtime $rtname - no change detected"
lappend skipped_kit_installs [list kit $targetkit reason "no change detected"]
$bin_event targetset_end SKIPPED $bin_event targetset_end SKIPPED
} }
$bin_event destroy $bin_event destroy
@ -1510,8 +1609,21 @@ if {[llength $failed_kits]} {
punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@* punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@*
#puts stderr [join $failed_kits \n] #puts stderr [join $failed_kits \n]
} }
set had_kits [expr {[llength $installed_kits] || [llength $failed_kits] || [llength $skipped_kits]}]
puts stdout "done" if {$had_kits} {
puts stdout " module builds and kit/zipkit builds processed (vfs config: src/runtime/mapvfs.config)"
puts stdout " - use 'make.tcl modules' to build modules without scanning/building the vfs folders into executable kits/zipkits"
puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into the base vfs folder"
puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but"
puts stdout " without the latest built modules."
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'"
} else {
puts stdout " module builds processed"
puts stdout ""
puts stdout " If kit/zipkit based executables required - create src/vfs/<somename>.vfs folders containing lib,modules,modules_tcl9 etc folders"
puts stdout " Also ensure appropriate executables exist in src/runtime along with src/runtime/mapvfs.config"
}
puts stdout "-done-"
exit 0 exit 0

540
src/modules/calculator_test-999999.0a1.0.tm

@ -0,0 +1,540 @@
## -*- tcl -*-
##
## OO-based Tcl/PARAM implementation of the parsing
## expression grammar
##
## calculator grammar
##
## Generated from file calctest.tcl
## for user jnoble
##
# # ## ### ##### ######## ############# #####################
## Requirements
package require Tcl 8.5 9
package require TclOO
package require pt::rde::oo ; # OO-based implementation of the
# PARAM virtual machine
# underlying the Tcl/PARAM code
# used below.
# # ## ### ##### ######## ############# #####################
##
oo::class create calculator_test {
# # ## ### ##### ######## #############
## Public API
superclass pt::rde::oo ; # TODO - Define this class.
# Or can we inherit from a snit
# class too ?
method parse {channel} {
my reset $channel
my MAIN ; # Entrypoint for the generated code.
return [my complete]
}
method parset {text} {
my reset {}
my data $text
my MAIN ; # Entrypoint for the generated code.
return [my complete]
}
# # ## ### ###### ######## #############
## BEGIN of GENERATED CODE. DO NOT EDIT.
#
# Grammar Start Expression
#
method MAIN {} {
my sym_Expression
return
}
#
# value Symbol 'AddOp'
#
method sym_AddOp {} {
# [+-]
my si:void_symbol_start AddOp
my si:next_class +-
my si:void_leaf_symbol_end AddOp
return
}
#
# value Symbol 'Digit'
#
method sym_Digit {} {
# [0123456789]
my si:void_symbol_start Digit
my si:next_class 0123456789
my si:void_leaf_symbol_end Digit
return
}
#
# value Symbol 'Expression'
#
method sym_Expression {} {
# x
# (Term)
# *
# x
# *
# '<blank>'
# (AddOp)
# *
# '<blank>'
# (Term)
my si:value_symbol_start Expression
my sequence_18
my si:reduce_symbol_end Expression
return
}
method sequence_18 {} {
# x
# (Term)
# *
# x
# *
# '<blank>'
# (AddOp)
# *
# '<blank>'
# (Term)
my si:value_state_push
my sym_Term
my si:valuevalue_part
my kleene_16
my si:value_state_merge
return
}
method kleene_16 {} {
# *
# x
# *
# '<blank>'
# (AddOp)
# *
# '<blank>'
# (Term)
while {1} {
my si:void2_state_push
my sequence_14
my si:kleene_close
}
return
}
method sequence_14 {} {
# x
# *
# '<blank>'
# (AddOp)
# *
# '<blank>'
# (Term)
my si:void_state_push
my kleene_8
my si:voidvalue_part
my sym_AddOp
my si:valuevalue_part
my kleene_8
my si:valuevalue_part
my sym_Term
my si:value_state_merge
return
}
method kleene_8 {} {
# *
# '<blank>'
while {1} {
my si:void2_state_push
my si:next_char \40
my si:kleene_close
}
return
}
#
# value Symbol 'Factor'
#
method sym_Factor {} {
# x
# (Fragment)
# *
# x
# *
# '<blank>'
# (PowOp)
# *
# '<blank>'
# (Fragment)
my si:value_symbol_start Factor
my sequence_32
my si:reduce_symbol_end Factor
return
}
method sequence_32 {} {
# x
# (Fragment)
# *
# x
# *
# '<blank>'
# (PowOp)
# *
# '<blank>'
# (Fragment)
my si:value_state_push
my sym_Fragment
my si:valuevalue_part
my kleene_30
my si:value_state_merge
return
}
method kleene_30 {} {
# *
# x
# *
# '<blank>'
# (PowOp)
# *
# '<blank>'
# (Fragment)
while {1} {
my si:void2_state_push
my sequence_28
my si:kleene_close
}
return
}
method sequence_28 {} {
# x
# *
# '<blank>'
# (PowOp)
# *
# '<blank>'
# (Fragment)
my si:void_state_push
my kleene_8
my si:voidvalue_part
my sym_PowOp
my si:valuevalue_part
my kleene_8
my si:valuevalue_part
my sym_Fragment
my si:value_state_merge
return
}
#
# value Symbol 'Fragment'
#
method sym_Fragment {} {
# /
# x
# '\('
# *
# '<blank>'
# (Expression)
# *
# '<blank>'
# '\)'
# (Number)
# (Var)
my si:value_symbol_start Fragment
my choice_46
my si:reduce_symbol_end Fragment
return
}
method choice_46 {} {
# /
# x
# '\('
# *
# '<blank>'
# (Expression)
# *
# '<blank>'
# '\)'
# (Number)
# (Var)
my si:value_state_push
my sequence_42
my si:valuevalue_branch
my sym_Number
my si:valuevalue_branch
my sym_Var
my si:value_state_merge
return
}
method sequence_42 {} {
# x
# '\('
# *
# '<blank>'
# (Expression)
# *
# '<blank>'
# '\)'
my si:void_state_push
my si:next_char \50
my si:voidvoid_part
my kleene_8
my si:voidvalue_part
my sym_Expression
my si:valuevalue_part
my kleene_8
my si:valuevalue_part
my si:next_char \51
my si:value_state_merge
return
}
#
# value Symbol 'MulOp'
#
method sym_MulOp {} {
# [*/]
my si:void_symbol_start MulOp
my si:next_class */
my si:void_leaf_symbol_end MulOp
return
}
#
# value Symbol 'Number'
#
method sym_Number {} {
# x
# ?
# (Sign)
# +
# (Digit)
my si:value_symbol_start Number
my sequence_57
my si:reduce_symbol_end Number
return
}
method sequence_57 {} {
# x
# ?
# (Sign)
# +
# (Digit)
my si:value_state_push
my optional_52
my si:valuevalue_part
my poskleene_55
my si:value_state_merge
return
}
method optional_52 {} {
# ?
# (Sign)
my si:void2_state_push
my sym_Sign
my si:void_state_merge_ok
return
}
method poskleene_55 {} {
# +
# (Digit)
my i_loc_push
my sym_Digit
my si:kleene_abort
while {1} {
my si:void2_state_push
my sym_Digit
my si:kleene_close
}
return
}
#
# value Symbol 'PowOp'
#
method sym_PowOp {} {
# "**"
my si:void_symbol_start PowOp
my si:next_str **
my si:void_leaf_symbol_end PowOp
return
}
#
# value Symbol 'Sign'
#
method sym_Sign {} {
# [-+]
my si:void_symbol_start Sign
my si:next_class -+
my si:void_leaf_symbol_end Sign
return
}
#
# value Symbol 'Term'
#
method sym_Term {} {
# x
# (Factor)
# *
# x
# *
# '<blank>'
# (MulOp)
# *
# '<blank>'
# (Factor)
my si:value_symbol_start Term
my sequence_75
my si:reduce_symbol_end Term
return
}
method sequence_75 {} {
# x
# (Factor)
# *
# x
# *
# '<blank>'
# (MulOp)
# *
# '<blank>'
# (Factor)
my si:value_state_push
my sym_Factor
my si:valuevalue_part
my kleene_73
my si:value_state_merge
return
}
method kleene_73 {} {
# *
# x
# *
# '<blank>'
# (MulOp)
# *
# '<blank>'
# (Factor)
while {1} {
my si:void2_state_push
my sequence_71
my si:kleene_close
}
return
}
method sequence_71 {} {
# x
# *
# '<blank>'
# (MulOp)
# *
# '<blank>'
# (Factor)
my si:void_state_push
my kleene_8
my si:voidvalue_part
my sym_MulOp
my si:valuevalue_part
my kleene_8
my si:valuevalue_part
my sym_Factor
my si:value_state_merge
return
}
#
# value Symbol 'Var'
#
method sym_Var {} {
# x
# '$'
# [xyz]
my si:void_symbol_start Var
my sequence_80
my si:void_leaf_symbol_end Var
return
}
method sequence_80 {} {
# x
# '$'
# [xyz]
my si:void_state_push
my si:next_char $
my si:voidvoid_part
my si:next_class xyz
my si:void_state_merge
return
}
## END of GENERATED CODE. DO NOT EDIT.
# # ## ### ###### ######## #############
}
# # ## ### ##### ######## ############# #####################
## Ready
package provide calculator_test 999999.0a1.0
return

28
src/modules/punk/console-999999.0a1.0.tm

@ -183,7 +183,9 @@ namespace eval punk::console {
variable previous_stty_state_$channel variable previous_stty_state_$channel
set sttycmd [auto_execok stty] set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} { if {[set previous_stty_state_$channel] eq ""} {
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] if {[catch {{*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
} }
exec {*}$sttycmd raw -echo <@$channel exec {*}$sttycmd raw -echo <@$channel
@ -253,13 +255,21 @@ namespace eval punk::console {
return "line" return "line"
} }
} elseif {$raw_or_line eq "raw"} { } elseif {$raw_or_line eq "raw"} {
punk::console::enableRaw if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} { if {[can_ansi]} {
punk::console::enableVirtualTerminal both punk::console::enableVirtualTerminal both
} }
} elseif {$raw_or_line eq "line"} { } elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
punk::console::disableRaw if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} { if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes punk::console::enableVirtualTerminal output ;#display/use ansi codes
@ -290,12 +300,15 @@ namespace eval punk::console {
set loadstate [zzzload::pkg_require twapi] set loadstate [zzzload::pkg_require twapi]
#loadstate could also be stuck on loading? - review - zzzload not very ripe #loadstate could also be stuck on loading? - review - zzzload not very ripe
#Twapi is relatively slow to load - can be 1s plus in normal cases - and much longer if there are disk performance issues. #Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues.
if {$loadstate ni [list failed]} { if {$loadstate ni [list failed]} {
#possibly still 'loading'
#review zzzload usage #review zzzload usage
#puts stdout "=========== console loading twapi =============" #puts stdout "=========== console loading twapi ============="
zzzload::pkg_wait twapi set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait
}
if {$loadstate ni [list failed]} {
package require twapi ;#should be fast once twapi dll loaded in zzzload thread package require twapi ;#should be fast once twapi dll loaded in zzzload thread
set ::punk::console::has_twapi 1 set ::punk::console::has_twapi 1
@ -523,6 +536,9 @@ namespace eval punk::console {
set is_raw 0 set is_raw 0
return [list stdin [list from $oldmode to $newmode]] return [list stdin [list from $oldmode to $newmode]]
} elseif {[set sttycmd [auto_execok stty]] ne ""} { } elseif {[set sttycmd [auto_execok stty]] ne ""} {
#stty can return info on windows - but doesn't seem to be able to set anything.
#review - is returned info even valid?
set sttycmd [auto_execok stty] set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} { if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel] exec {*}$sttycmd [set previous_stty_state_$channel]

165
src/modules/punk/lib-999999.0a1.0.tm

@ -339,6 +339,92 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}] set has_twapi [expr {![catch {package require twapi}]}]
} }
# -- ---
#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
#8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows
# Review and retest as new versions come out.
# -- ---
proc list_multi_append1 {lvar1 lvar2} {
#clear winner in 2024
upvar $lvar1 l1 $lvar2 l2
lappend l1 {*}$l2
return $l1
}
proc list_multi_append2 {lvar1 lvar2} {
upvar $lvar1 l1 $lvar2 l2
set l1 [list {*}$l1 {*}$l2]
}
proc list_multi_append3 {lvar1 lvar2} {
upvar $lvar1 l1 $lvar2 l2
set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0]
}
#testing e.g
#set l1_reset {a b c}
#set l2 {a b c d e f g}
#set l1 $l1_reset
#time {list_multi_append1 l1 l2} 1000
#set l1 $l1_reset
#time {list_multi_append2 l1 l2} 1000
# -- ---
proc lswap {lvar a z} {
upvar $lvar l
if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} {
#if we didn't do this check - we could raise an error on second lset - leaving list corrupted because only one lset occurred
#(e.g using: lswap mylist end-2 end on a two element list)
#on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report
set a_index [lindex_resolve $l $a]
set a_msg ""
switch -- $a_index {
-2 {
"$a is greater th
}
-3 {
}
}
error "lswap cannot indices $a and $z $a is out of range"
}
set item2 [lindex $l $z]
lset l $z [lindex $l $a]
lset l $a $item2
return $l
}
#proc lswap2 {lvar a z} {
# upvar $lvar l
# #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower
# set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]]
#}
proc lswap2 {lvar a z} {
upvar $lvar l
#if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower
set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]]
}
#an experimental test of swapping vars without intermediate variables
#It's an interesting idea - but probably of little to no practical use
# - the swap_intvars3 version using intermediate var is faster in Tcl
# - This is probably unsurprising - as it's simpler code.
# Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks.
#proc swap_intvars {swapv1 swapv2} {
# upvar $swapv1 _x $swapv2 _y
# set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}]
#}
#proc swap_intvars2 {swapv1 swapv2} {
# upvar $swapv1 _x $swapv2 _y
# set _x [expr {$_x ^ $_y}]
# set _y [expr {$_x ^ $_y}]
# set _x [expr {$_x ^ $_y}]
#}
#proc swap_intvars3 {swapv1 swapv2} {
# #using intermediate variable
# upvar $swapv1 _x $swapv2 _y
# set z $_x
# set _x $_y
# set _y $z
#}
#*** !doctools #*** !doctools
#[subsection {Namespace punk::lib}] #[subsection {Namespace punk::lib}]
@ -347,6 +433,7 @@ namespace eval punk::lib {
if {[info commands lseq] ne ""} { if {[info commands lseq] ne ""} {
#tcl 8.7+ lseq significantly faster, especially for larger ranges #tcl 8.7+ lseq significantly faster, especially for larger ranges
#The internal rep can be an 'arithseries' with no string representation
#support minimal set from to #support minimal set from to
proc range {from to} { proc range {from to} {
lseq $from $to lseq $from $to
@ -1009,24 +1096,28 @@ namespace eval punk::lib {
} }
set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high
#keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds
if {${lower_resolve} == -1} { if {${lower_resolve} == -2} {
##x
#lower bound is above upper list range #lower bound is above upper list range
#match with decreasing indices is still possible #match with decreasing indices is still possible
set lower [expr {[llength $dval]-1}] ;#set to max set lower [expr {[llength $dval]-1}] ;#set to max
} elseif {$lower_resolve == -2} { } elseif {$lower_resolve == -3} {
##x
set lower 0 set lower 0
} else { } else {
set lower $lower_resolve set lower $lower_resolve
} }
set upper [punk::lib::lindex_resolve $dval $b] set upper [punk::lib::lindex_resolve $dval $b]
if {$upper == -2} { if {$upper == -3} {
##x
#upper bound is below list range - #upper bound is below list range -
if {$lower_resolve >=-1} { if {$lower_resolve >=-2} {
##x
set upper 0 set upper 0
} else { } else {
continue continue
} }
} elseif {$upper == -1} { } elseif {$upper == -2} {
#use max #use max
set upper [expr {[llength $dval]-1}] set upper [expr {[llength $dval]-1}]
#assert - upper >=0 because we have ruled out empty lists #assert - upper >=0 because we have ruled out empty lists
@ -1670,6 +1761,7 @@ namespace eval punk::lib {
} }
} }
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side
proc lindex_resolve {list index} { proc lindex_resolve {list index} {
#*** !doctools #*** !doctools
#[call [fun lindex_resolve] [arg list] [arg index]] #[call [fun lindex_resolve] [arg list] [arg index]]
@ -1679,11 +1771,13 @@ namespace eval punk::lib {
#[para]Sometimes the actual integer index is desired. #[para]Sometimes the actual integer index is desired.
#[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks.
#[para]lindex_resolve will parse the index expression and return: #[para]lindex_resolve will parse the index expression and return:
#[para] a) -2 if the supplied index expression is below the lower bound for the supplied list. (< 0) #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
#[para] b) -1 if the supplied index expression is above the upper bound for the supplied list. (> end) #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end)
#[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list
#[para]Otherwise it will return an integer corresponding to the position in the list. #[para]Otherwise it will return an integer corresponding to the position in the list.
#[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway. #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway.
#[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable
#[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2
#Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr
#if {![llength $list]} { #if {![llength $list]} {
@ -1694,9 +1788,9 @@ namespace eval punk::lib {
if {[string is integer -strict $index]} { if {[string is integer -strict $index]} {
#can match +i -i #can match +i -i
if {$index < 0} { if {$index < 0} {
return -2 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= [llength $list]} {
return -1 return -2
} else { } else {
#integer may still have + sign - normalize with expr #integer may still have + sign - normalize with expr
return [expr {$index}] return [expr {$index}]
@ -1708,14 +1802,14 @@ namespace eval punk::lib {
set offset [string range $index 4 end] set offset [string range $index 4 end]
if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"}
if {$op eq "+" && $offset != 0} { if {$op eq "+" && $offset != 0} {
return -1 return -2
} }
} else { } else {
#end #index is 'end'
set index [expr {[llength $list]-1}] set index [expr {[llength $list]-1}]
if {$index < 0} { if {$index < 0} {
#special case - end with empty list - treat end like a positive number out of bounds #special case - 'end' with empty list - treat end like a positive number out of bounds
return -1 return -2
} else { } else {
return $index return $index
} }
@ -1723,7 +1817,7 @@ namespace eval punk::lib {
if {$offset == 0} { if {$offset == 0} {
set index [expr {[llength $list]-1}] set index [expr {[llength $list]-1}]
if {$index < 0} { if {$index < 0} {
return -1 ;#special case return -2 ;#special case as above
} else { } else {
return $index return $index
} }
@ -1732,7 +1826,7 @@ namespace eval punk::lib {
set index [expr {([llength $list]-1) - $offset}] set index [expr {([llength $list]-1) - $offset}]
} }
if {$index < 0} { if {$index < 0} {
return -2 return -3
} else { } else {
return $index return $index
} }
@ -1753,26 +1847,50 @@ namespace eval punk::lib {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
} }
if {$index < 0} { if {$index < 0} {
return -2 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= [llength $list]} {
return -1 return -2
} }
return $index return $index
} }
} }
} }
proc lindex_resolve2 {list index} { proc lindex_resolve_basic {list index} {
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. #*** !doctools
#[call [fun lindex_resolve_basic] [arg list] [arg index]]
#[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2)
#[para] returns -1 for out of range at either end, or a valid integer index
#[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound
#[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command
#[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1
#[para] For pure integer indices the performance should be equivalent
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+
# - which
#for {set i 0} {$i < [llength $list]} {incr i} { #for {set i 0} {$i < [llength $list]} {incr i} {
# lappend indices $i # lappend indices $i
#} #}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
#avoid even the lseq overhead when the index is simple
if {$index < 0 || ($index >= [llength $list])} {
#even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method.
return -1
} else {
#integer may still have + sign - normalize with expr
return [expr {$index}]
}
}
if {[llength $list]} { if {[llength $list]} {
set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback.
#if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?)
} else { } else {
set indices [list] set indices [list]
} }
set idx [lindex $indices $index] set idx [lindex $indices $index]
if {$idx eq ""} { if {$idx eq ""} {
#we have no way to determine if out of bounds is at lower vs upper end
return -1 return -1
} else { } else {
return $idx return $idx
@ -2334,13 +2452,6 @@ namespace eval punk::lib {
} }
return $prefix return $prefix
} }
#test example of the technique - not necessarily particularly useful as a function, except maybe for brevity/clarity. todo - test if inlined version gives any perf advantage compared to a temp var
proc swapnumvars {namea nameb} {
upvar $namea a $nameb b
set a [expr {$a ^ $b}]
set b [expr {$a ^ $b}]
set a [expr {$a ^ $b}]
}
#e.g linesort -decreasing $data #e.g linesort -decreasing $data
proc linesort {args} { proc linesort {args} {
@ -2956,7 +3067,7 @@ namespace eval punk::lib {
# and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]*
proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} {
set number [punk::objclone $unformattednumber] set number [objclone $unformattednumber]
set number [string map {_ ""} $number] set number [string map {_ ""} $number]
#normalize using expr - e.g 2e4 -> 20000.0 #normalize using expr - e.g 2e4 -> 20000.0
set number [expr {$number}] set number [expr {$number}]

35
src/modules/punk/mix/base-0.1.tm

@ -4,6 +4,7 @@ package provide punk::mix::base [namespace eval punk::mix::base {
}] }]
package require punk::path package require punk::path
package require punk::lib ;#format_number etc
#base internal plumbing functions #base internal plumbing functions
namespace eval punk::mix::base { namespace eval punk::mix::base {
@ -657,16 +658,38 @@ namespace eval punk::mix::base {
#temp emission to stdout.. todo - repl telemetry channel #temp emission to stdout.. todo - repl telemetry channel
puts stdout "cksum_path: creating temporary tar archive for $path" puts stdout "cksum_path: creating temporary tar archive for $path"
puts stdout " at: $archivename .." puts -nonewline stdout " at: $archivename ..."
tar::create $archivename $target set tsstart [clock millis]
if {[set tarpath [auto_execok tar]] ne ""} {
#using an external binary is *significantly* faster than tar::create - but comes with some risks
#review - need to check behaviour/flag variances across platforms
#don't use -z flag. On at least some tar versions the zipped file will contain a timestamped subfolder of filename.tar - which ruins the checksum
#also - tar is generally faster without the compression (although this may vary depending on file size and disk speed?)
exec {*}$tarpath -cf $archivename $target ;#{*} needed in case spaces in tarpath
set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " tar -cf done ($ms ms)"
} else {
set tsstart [clock millis] ;#don't include auto_exec search time for tar::create
tar::create $archivename $target
set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " tar::create done ($ms ms)"
puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing"
}
if {$ftype eq "file"} { if {$ftype eq "file"} {
set sizeinfo "(size [file size $target])" set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)"
} else { } else {
set sizeinfo "(file type $ftype - size unknown)" set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)"
} }
puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." set tsstart [clock millis]
puts -nonewline stdout "cksum_path: calculating cksum for $target $sizeinfo ... "
set cksum [{*}$cksum_command $archivename] set cksum [{*}$cksum_command $archivename]
#puts stdout "cksum_path: cleaning up.. " set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " cksum done ($ms ms)"
puts stdout " cksum: $cksum"
file delete -force $archivename file delete -force $archivename
cd $startdir cd $startdir

6
src/modules/punk/mix/commandset/project-999999.0a1.0.tm

@ -157,6 +157,9 @@ namespace eval punk::mix::commandset::project {
set opt_force [dict get $opts -force] set opt_force [dict get $opts -force]
set opt_confirm [string tolower [dict get $opts -confirm]] set opt_confirm [string tolower [dict get $opts -confirm]]
# -- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_layout [dict get $opts -layout]
set opt_update [dict get $opts -update]
# -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_modules [dict get $opts -modules] set opt_modules [dict get $opts -modules]
if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} {
#if not specified - add a single module matching project name #if not specified - add a single module matching project name
@ -169,9 +172,6 @@ namespace eval punk::mix::commandset::project {
} }
} }
# -- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_layout [dict get $opts -layout]
set opt_update [dict get $opts -update]
# -- --- --- --- --- --- --- --- --- --- --- --- ---
#todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache

68
src/modules/punk/ns-999999.0a1.0.tm

@ -1707,6 +1707,7 @@ tcl::namespace::eval punk::ns {
lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs
set use_vars [expr {"-vars" in $runopts}] set use_vars [expr {"-vars" in $runopts}]
set no_warnings [expr {"-nowarnings" in $runopts}] set no_warnings [expr {"-nowarnings" in $runopts}]
set ver ""
#todo support leading solo flags such as -capture to control whether we do a static capture of local vars in the ns #todo support leading solo flags such as -capture to control whether we do a static capture of local vars in the ns
@ -1717,15 +1718,68 @@ tcl::namespace::eval punk::ns {
} }
default { default {
if {[string match ::* $pkg_or_existing_ns]} { if {[string match ::* $pkg_or_existing_ns]} {
set pkg_unqualified [string range $pkg_or_existing_ns 2 end]
if {![tcl::namespace::exists $pkg_or_existing_ns]} { if {![tcl::namespace::exists $pkg_or_existing_ns]} {
set ver [package require [string range $pkg_or_existing_ns 2 end]] set ver [package require $pkg_unqualified]
} else { } else {
set ver "" set ver ""
} }
set ns $pkg_or_existing_ns set ns $pkg_or_existing_ns
} else { } else {
set ver [package require $pkg_or_existing_ns] set pkg_unqualified $pkg_or_existing_ns
set ns ::$pkg_or_existing_ns set ver [package require $pkg_unqualified]
set ns ::$pkg_unqualified
}
#some packages don't create their namespace immediately and/or don't populate it with commands and instead put entries in ::auto_index
set previous_command_count 0
if {[namespace exists $ns]} {
set previous_command_count [llength [info commands ${ns}::*]]
}
#also if a sub package was loaded first - then the namespace for the base or lower package may exist but have no commands
#for the purposes of pkguse - which most commonly interactive - we want the namespace populated
#It may still not be *fully* populated because we stop at first source that adds commands - REVIEW
set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}]
if {!$ns_populated} {
#we will catch-run an auto_index entry if any
#auto_index entry may or may not be prefixed with ::
set keys [list]
#first look for exact pkg_unqualified and ::pkg_unqualified
#leave these at beginning of keys list
if {[array exists ::auto_index($pkg_unqualified)]} {
lappend keys $pkg_unqualified
}
if {[array exists ::auto_index(::$pkg_unqualified)]} {
lappend keys ::$pkg_unqualified
}
#as auto_index is an array - we could get keys in arbitrary order
set matches [lsort [array names ::auto_index ${pkg_unqualified}::*]]
lappend keys {*}$matches
set matches [lsort [array names ::auto_index ::${pkg_unqualified}::*]]
lappend keys {*}$matches
set ns_populated 0
set i 0
set already_sourced [list] ;#often multiple triggers for the same source - don't waste time re-sourcing
set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]]
while {!$ns_populated && $i < [llength $keys]} {
#todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base
#e.g if we are loading ::x::y
#only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc
set k [lindex $keys $i]
set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]]
if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} {
set auto_source [set ::auto_index($k)]
if {$auto_source ni $already_sourced} {
uplevel 1 $auto_source
lappend already_sourced $auto_source
set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}]
}
}
incr i
}
} }
} }
} }
@ -1799,7 +1853,13 @@ tcl::namespace::eval punk::ns {
return $out return $out
} }
} else { } else {
error "Namespace $ns not found." if {$ver eq ""} {
error "Namespace $ns not found. No package version found."
} else {
set out "(no package namespace found) remaining in [uplevel 1 {namespace current}]"
append out \n $ver
return $out
}
} }
return $out return $out
} }

6
src/modules/punk/repl-0.1.tm

@ -416,7 +416,11 @@ proc repl::start {inchan args} {
variable codethread_cond variable codethread_cond
tsv::unset codethread_$codethread if {[catch {
tsv::unset codethread_$codethread
} errM]} {
puts stderr " repl::start temp warning - $errM"
}
thread::cancel $codethread thread::cancel $codethread
thread::cond destroy $codethread_cond ;#race if we destroy cond before child thread has exited - as it can send a -async quit thread::cond destroy $codethread_cond ;#race if we destroy cond before child thread has exited - as it can send a -async quit
set codethread "" set codethread ""

2
src/modules/punk/repo-999999.0a1.0.tm

@ -468,7 +468,7 @@ namespace eval punk::repo {
set path [string trim [string range $ln [string length "MISSING "] end]] set path [string trim [string range $ln [string length "MISSING "] end]]
dict set pathdict $path "missing" dict set pathdict $path "missing"
} }
"EXTRA * " { "EXTRA *" {
#fossil will explicitly list files in a new folder - as opposed to git which shows just the folder #fossil will explicitly list files in a new folder - as opposed to git which shows just the folder
set path [string trim [string range $ln [string length "EXTRA "] end]] set path [string trim [string range $ln [string length "EXTRA "] end]]
dict set pathdict $path "extra" dict set pathdict $path "extra"

561
src/modules/punk/winlnk-999999.0a1.0.tm

@ -0,0 +1,561 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-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) 2024
#
# @@ Meta Begin
# Application punk::winlnk 999999.0a1.0
# Meta platform tcl
# Meta license MIT
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin shellspy_module_punk::winlnk 0 999999.0a1.0]
#[copyright "2024"]
#[titledesc {windows shortcut .lnk library}] [comment {-- Name section and table of contents description --}]
#[moddesc {punk::winlnk}] [comment {-- Description at end of page heading --}]
#[require punk::winlnk]
#[keywords module shortcut lnk parse windows crossplatform]
#[description]
#[para] Tools for reading windows shortcuts (.lnk files) on any platform
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of punk::winlnk
#[subsection Concepts]
#[para] Windows shortcuts are a binary format file with a .lnk extension
#[para] Shell Link (.LNK) Binary File Format is documented in [MS_SHLLINK].pdf published by Microsoft.
#[para] Revision 8.0 published 2024-04-23
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by punk::winlnk
#[list_begin itemized]
package require Tcl 8.6-
#*** !doctools
#[item] [package {Tcl 8.6}]
#TODO - logger
#*** !doctools
#[list_end]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section API]
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# oo::class namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#tcl::namespace::eval punk::winlnk::class {
#*** !doctools
#[subsection {Namespace punk::winlnk::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::winlnk {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
#variable xyz
#*** !doctools
#[subsection {Namespace punk::winlnk}]
#[para] Core API functions for punk::winlnk
#[list_begin definitions]
variable magic_HeaderSize "0000004C" ;#HeaderSize MUST equal this
variable magic_LinkCLSID "00021401-0000-0000-C000-000000000046" ;#LinkCLSID MUST equal this
proc Get_contents {path {bytes all}} {
if {![file exists $path] || [file type $path] ne "file"} {
error "punk::winlnk::get_contents cannot find a filesystem object of type 'file' at location: $path"
}
set fd [open $path r]
chan configure $fd -translation binary -encoding iso8859-1
if {$bytes eq "all"} {
set data [read $fd]
} else {
set data [read $fd $bytes]
}
close $fd
return $data
}
proc Get_HeaderSize {contents} {
set 4bytes [split [string range $contents 0 3] ""]
set hex4 ""
foreach b [lreverse $4bytes] {
set dec [scan $b %c] ;# 0-255 decimal
set HH [format %2.2llX $dec]
append hex4 $HH
}
return $hex4
}
proc Get_LinkCLSID {contents} {
set 16bytes [string range $contents 4 19]
#CLSID hex textual representation is split as 4-2-2-2-6 bytes(hex pairs)
#e.g We expect 00021401-0000-0000-C000-000000000046 for .lnk files
#for endianness - it is little endian all the way but the split is 4-2-2-1-1-1-1-1-1-1-1 REVIEW
#(so it can appear as mixed endianness if you don't know the splits)
#https://devblogs.microsoft.com/oldnewthing/20220928-00/?p=107221
#This is based on COM textual representation of GUIDS
#Apparently a CLSID is a GUID that identifies a COM object
set clsid ""
set s1 [tcl::string::range $16bytes 0 3]
set declist [scan [string reverse $s1] %c%c%c%c]
set fmt "%02X%02X%02X%02X"
append clsid [format $fmt {*}$declist]
append clsid -
set s2 [tcl::string::range $16bytes 4 5]
set declist [scan [string reverse $s2] %c%c]
set fmt "%02X%02X"
append clsid [format $fmt {*}$declist]
append clsid -
set s3 [tcl::string::range $16bytes 6 7]
set declist [scan [string reverse $s3] %c%c]
append clsid [format $fmt {*}$declist]
append clsid -
#now treat bytes individually - so no endianness conversion
set declist [scan [tcl::string::range $16bytes 8 9] %c%c]
append clsid [format $fmt {*}$declist]
append clsid -
set scan [string repeat %c 6]
set fmt [string repeat %02X 6]
set declist [scan [tcl::string::range $16bytes 10 15] $scan]
append clsid [format $fmt {*}$declist]
return $clsid
}
proc Contents_check_header {contents} {
variable magic_HeaderSize
variable magic_LinkCLSID
expr {[Get_HeaderSize $contents] eq $magic_HeaderSize && [Get_LinkCLSID $contents] eq $magic_LinkCLSID}
}
#LinkFlags - 4 bytes - specifies information about the shell link and the presence of optional portions of the structure.
proc Show_LinkFlags {contents} {
set 4bytes [string range $contents 20 23]
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int
puts "val: $val"
set declist [scan [string reverse $4bytes] %c%c%c%c]
set fmt [string repeat %08b 4]
puts "LinkFlags:[format $fmt {*}$declist]"
set r [binary scan $4bytes b32 val]
puts "bscan-le: $val"
set r [binary scan [string reverse $4bytes] b32 val]
puts "bscan-2 : $val"
}
proc Get_LinkFlags {contents} {
set 4bytes [string range $contents 20 23]
set r [binary scan $4bytes i val] ;# i for little endian 32-bit signed int
return $val
}
variable LinkFlags
set LinkFlags [dict create\
hasLinkTargetIDList 1\
HasLinkInfo 2\
HasName 4\
HasRelativePath 8\
HasWorkingDir 16\
HasArguments 32\
HasIconLocation 64\
IsUnicode 128\
ForceNoLinkInfo 256\
HasExpString 512\
RunInSeparateProcess 1024\
Unused1 2048\
HasDarwinID 4096\
RunAsUser 8192\
HasExpIcon 16394\
NoPidlAlias 32768\
Unused2 65536\
RunWithShimLayer 131072\
ForceNoLinkTrack 262144\
EnableTargetMetadata 524288\
DisableLinkPathTracking 1048576\
DisableKnownFolderTracking 2097152\
DisableKnownFolderAlias 4194304\
AllowLinkToLink 8388608\
UnaliasOnSave 16777216\
PreferEnvironmentPath 33554432\
KeepLocalIDListForUNCTarget 67108864\
]
variable LinkFlagLetters [list A B C D E F G H I J K L M N O P Q R S T U V W X Y Z AA]
proc Has_LinkFlag {contents flagname} {
variable LinkFlags
variable LinkFlagLetters
if {[string length $flagname] <= 2} {
set idx [lsearch $LinkFlagLetters $flagname]
if {$idx < 0} {
error "punk::winlnk::Has_LinkFlag error - flagname $flagname not known"
}
set binflag [expr {2**$idx}]
set allflags [Get_LinkFlags $contents]
return [expr {$allflags & $binflag}]
}
if {[dict exists $LinkFlags $flagname]} {
set binflag [dict get $LinkFlags $flagname]
set allflags [Get_LinkFlags $contents]
return [expr {$allflags & $binflag}]
} else {
error "punk::winlnk::Has_LinkFlag error - flagname $flagname not known"
}
}
#https://github.com/libyal/liblnk/blob/main/documentation/Windows%20Shortcut%20File%20(LNK)%20format.asciidoc
#offset 24 4 bytes
#File attribute flags
#offset 28 8 bytes
#creation date and time
#offset 36 8 bytes
#last access date and time
#offset 44 8 bytes
#last modification date and time
#offset 52 4 bytes - unsigned int
#file size in bytes (of target)
proc Get_FileSize {contents} {
set 4bytes [string range $contents 52 55]
set r [binary scan $4bytes i val]
return $val
}
#offset 56 4 bytes signed integer
#icon index value
#offset 60 4 bytes - unsigned integer
#SW_SHOWNORMAL 0x00000001
#SW_SHOWMAXIMIZED 0x00000001
#SW_SHOWMINNOACTIVE 0x00000007
# - all other values MUST be treated as SW_SHOWNORMAL
proc Get_ShowCommand {contents} {
set 4bytes [string range $contents 60 63]
set r [binary scan $4bytes i val]
return $val
}
#offset 64 Bytes 2
#Hot key
#offset 66 2 bytes - reserved
#offset 68 4 bytes - reserved
#offset 72 4 bytes - reserved
#next 76
proc Get_LinkTargetIDList_size {contents} {
if {[Has_LinkFlag $contents "A"]} {
set 2bytes [string range $contents 76 77]
set r [binary scan $2bytes s val] ;#short
#logger
#puts stderr "LinkTargetIDList_size: $val"
return $val
} else {
return 0
}
}
proc Get_LinkInfo_content {contents} {
set idlist_size [Get_LinkTargetIDList_size $contents]
if {$idlist_size == 0} {
set offset 0
} else {
set offset [expr {2 + $idlist_size}] ;#LinkTargetIdList IDListSize field + value
}
set linkinfo_start [expr {76 + $offset}]
if {[Has_LinkFlag $contents B]} {
#puts stderr "linkinfo_start: $linkinfo_start"
set 4bytes [string range $contents $linkinfo_start $linkinfo_start+3]
binary scan $4bytes i val ;#size *including* these 4 bytes
set linkinfo_content [string range $contents $linkinfo_start [expr {$linkinfo_start + $val -1}]]
return [dict create linkinfo_start $linkinfo_start size $val next_start [expr {$linkinfo_start + $val}] content $linkinfo_content]
} else {
return [dict create linkinfo_start $linkinfo_start size 0 next_start $linkinfo_start content ""]
}
}
proc LinkInfo_get_fields {linkinfocontent} {
set 4bytes [string range $linkinfocontent 0 3]
binary scan $4bytes i val ;#size *including* these 4 bytes
set bytes_linkinfoheadersize [string range $linkinfocontent 4 7]
set bytes_linkinfoflags [string range $linkinfocontent 8 11]
set r [binary scan $4bytes i flags] ;# i for little endian 32-bit signed int
#puts "linkinfoflags: $flags"
set localbasepath ""
set commonpathsuffix ""
#REVIEW - flags problem?
if {$flags & 1} {
#VolumeIDAndLocalBasePath
#logger
#puts stderr "VolumeIDAndLocalBasePath"
}
if {$flags & 2} {
#logger
#puts stderr "CommonNetworkRelativeLinkAndPathSuffix"
}
set bytes_volumeid_offset [string range $linkinfocontent 12 15]
set bytes_localbasepath_offset [string range $linkinfocontent 16 19] ;# a
set bytes_commonnetworkrelativelinkoffset [string range $linkinfocontent 20 23]
set bytes_commonpathsuffix_offset [string range $linkinfocontent 24 27] ;# a
binary scan $bytes_localbasepath_offset i bp_offset
if {$bp_offset > 0} {
set tail [string range $linkinfocontent $bp_offset end]
set stringterminator 0
set i 0
set localbasepath ""
#TODO
while {!$stringterminator & $i < 100} {
set c [string index $tail $i]
if {$c eq "\x00"} {
set stringterminator 1
} else {
append localbasepath $c
}
incr i
}
}
binary scan $bytes_commonpathsuffix_offset i cps_offset
if {$cps_offset > 0} {
set tail [string range $linkinfocontent $cps_offset end]
set stringterminator 0
set i 0
set commonpathsuffix ""
#TODO
while {!$stringterminator && $i < 100} {
set c [string index $tail $i]
if {$c eq "\x00"} {
set stringterminator 1
} else {
append commonpathsuffix $c
}
incr i
}
}
return [dict create localbasepath $localbasepath commonpathsuffix $commonpathsuffix]
}
proc contents_get_info {contents} {
#todo - return something like the perl lnk-parse-1.0.pl script?
#Link File: C:/repo/jn/tclmodules/tomlish/src/modules/test/#modpod-tomlish-999999.0a1.0/suites/all/arrays_1.toml#roundtrip+roundtrip_files+arrays_1.toml.fauxlink.lnk
#Link Flags: HAS SHELLIDLIST | POINTS TO FILE/DIR | NO DESCRIPTION | HAS RELATIVE PATH STRING | HAS WORKING DIRECTORY | NO CMD LINE ARGS | NO CUSTOM ICON |
#File Attributes: ARCHIVE
#Create Time: Sun Jul 14 2024 10:41:34
#Last Accessed time: Sat Sept 21 2024 02:46:10
#Last Modified Time: Tue Sept 10 2024 17:16:07
#Target Length: 479
#Icon Index: 0
#ShowWnd: 1 SW_NORMAL
#HotKey: 0
#(App Path:) Remaining Path: repo\jn\tclmodules\tomlish\src\modules\test\#modpod-tomlish-999999.0a1.0\suites\roundtrip\roundtrip_files\arrays_1.toml
#Relative Path: ..\roundtrip\roundtrip_files\arrays_1.toml
#Working Dir: C:\repo\jn\tclmodules\tomlish\src\modules\test\#modpod-tomlish-999999.0a1.0\suites\roundtrip\roundtrip_files
variable LinkFlags
set flags_enabled [list]
dict for {k v} $LinkFlags {
if {[Has_LinkFlag $contents $k] > 0} {
lappend flags_enabled $k
}
}
set showcommand_val [Get_ShowCommand $contents]
switch -- $showcommand_val {
1 {
set showwnd [list 1 SW_SHOWNORMAL]
}
3 {
set showwnd [list 3 SW_SHOWMAXIMIZED]
}
7 {
set showwnd [list 7 SW_SHOWMINNOACTIVE]
}
default {
set showwnd [list $showcommand_val SW_SHOWNORMAL-effective]
}
}
set linkinfo_content_dict [Get_LinkInfo_content $contents]
set localbase_path ""
set suffix_path ""
set linkinfocontent [dict get $linkinfo_content_dict content]
set link_file ""
if {$linkinfocontent ne ""} {
set linkfields [LinkInfo_get_fields $linkinfocontent]
set localbase_path [dict get $linkfields localbasepath]
set suffix_path [dict get $linkfields commonpathsuffix]
set link_file [file join $localbase_path $suffix_path]
}
set result [dict create\
link_file $link_file\
link_flags $flags_enabled\
file_attributes "<unimplemented>"\
create_time "<unimplemented>"\
last_accessed_time "<unimplemented"\
last_modified_time "<unimplementd>"\
target_length [Get_FileSize $contents]\
icon_index "<unimplemented>"\
showwnd "$showwnd"\
hotkey "<unimplemented>"\
relative_path "?"\
]
}
proc file_check_header {path} {
#*** !doctools
#[call [fun file_check_header] [arg path] ]
#[para]Return 0|1
#[para]Determines if the .lnk file specified in path has a valid header for a windows shortcut
set c [Get_contents $path 20]
return [Contents_check_header $c]
}
proc file_get_info {path} {
#*** !doctools
#[call [fun file_get_info] [arg path] ]
#[para] Return a dict of info obtained by parsing the binary data in a windows .lnk file
#[para] If the .lnk header check fails, then the .lnk file probably isn't really a shortcut file and the dictionary will contain an 'error' key
set c [Get_contents $path]
if {[Contents_check_header $c]} {
return [contents_get_info $c]
} else {
return [dict create error "lnk_header_check_failed"]
}
}
proc file_show_info {path} {
package require punk::lib
punk::lib::showdict [file_get_info $path] *
}
#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::winlnk ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
tcl::namespace::eval punk::winlnk::lib {
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase
tcl::namespace::path [tcl::namespace::parent]
#*** !doctools
#[subsection {Namespace punk::winlnk::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::winlnk::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
#tcl::namespace::eval punk::winlnk::system {
#*** !doctools
#[subsection {Namespace punk::winlnk::system}]
#[para] Internal functions that are not part of the API
#}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::winlnk [tcl::namespace::eval punk::winlnk {
variable pkg punk::winlnk
variable version
set version 999999.0a1.0
}]
return
#*** !doctools
#[manpage_end]

3
src/modules/punk/winlnk-buildversion.txt

@ -0,0 +1,3 @@
0.1.0
#First line must be a semantic version number
#all other lines are ignored.

8
src/modules/shellfilter-0.1.9.tm

@ -1658,6 +1658,14 @@ namespace eval shellfilter {
return [list $idout $iderr] return [list $idout $iderr]
} }
#eg try: set v [list #a b c]
#vs set v {#a b c}
proc list_is_canonical l {
#courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl
if {[catch {llength $l}]} {return 0}
string equal $l [list {*}$l]
}
#return a dict keyed on numerical list index showing info about each element #return a dict keyed on numerical list index showing info about each element
# - particularly # - particularly
# 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list

214
src/project_layouts/custom/_project/punk.basic/src/make.tcl

@ -13,7 +13,7 @@ namespace eval ::punkmake {
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k] variable non_help_flags [list -k]
variable help_flags [list -help --help /?] variable help_flags [list -help --help /?]
variable known_commands [list project get-project-info shell vendorupdate bootsupport vfscommonupdate] variable known_commands [list project modules info check shell vendorupdate bootsupport vfscommonupdate]
} }
if {"::try" ni [info commands ::try]} { if {"::try" ni [info commands ::try]} {
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting"
@ -21,7 +21,7 @@ if {"::try" ni [info commands ::try]} {
} }
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
#Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder #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 the there is a folder under the current directory /src/bootsupport/modules which contains .tm files
# - then it will attempt to preference these modules # - then it will attempt to preference these modules
@ -35,8 +35,10 @@ if {[file exists [file join $startdir src bootsupport]]} {
set bootsupport_mod [file join $startdir bootsupport modules] set bootsupport_mod [file join $startdir bootsupport modules]
set bootsupport_lib [file join $startdir bootsupport lib] set bootsupport_lib [file join $startdir bootsupport lib]
} }
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
set package_paths_modified 0
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
set original_tm_list [tcl::tm::list] set original_tm_list [tcl::tm::list]
tcl::tm::remove {*}$original_tm_list tcl::tm::remove {*}$original_tm_list
set original_auto_path $::auto_path set original_auto_path $::auto_path
@ -63,8 +65,18 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
} }
if {[file exists [pwd]/modules]} { #we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir.
tcl::tm::add [pwd]/modules #The <projectdir>/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 <projectdir/src is also likely to be common
# but we need to be loud about what's going on.
puts stderr "------------------------------------------------------------------"
puts stderr "Launched from within a folder ending in 'src'"
puts stderr " - modules in $startdir/modules may override bootsupport modules"
puts stderr "------------------------------------------------------------------"
tcl::tm::add $startdir/modules
}
} }
#package require Thread #package require Thread
@ -81,16 +93,8 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
package require punkcheck package require punkcheck
package require punk::lib package require punk::lib
set package_paths_modified 1
#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]
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
} }
@ -106,6 +110,8 @@ try {
} }
package require punk::mix package require punk::mix
package require punk::repo package require punk::repo
package require punk::ansi
package require overtype
} finally { } finally {
catch {rename ::package ""} catch {rename ::package ""}
catch {rename ::punkmake::package_temp_aside ::package} catch {rename ::punkmake::package_temp_aside ::package}
@ -129,18 +135,24 @@ proc punkmake_gethelp {args} {
append h "Usage:" \n append h "Usage:" \n
append h "" \n append h "" \n
append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n
append h " - This help." \n \n append h " - This help." \n \n
append h " $scriptname project ?-k?" \n append h " $scriptname project ?-k?" \n
append h " - this is the literal word project - and confirms you want to run the project build" \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 \n append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n
append h " - built modules go into <projectdir>/modules <projectdir>/lib etc." \n \n
append h " $scriptname modules" \n
append h " - build modules from src/modules etc without scanning src/runtime and src/vfs folders to build kit/zipkit executables" \n \n
append h " $scriptname bootsupport" \n append h " $scriptname bootsupport" \n
append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n \n append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n
append h " - bootsupport modules are available to make.tcl" \n \n
append h " $scriptname vendorupdate" \n append h " $scriptname vendorupdate" \n
append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n
append h " $scriptname vfscommonupdate" \n append h " $scriptname vfscommonupdate" \n
append h " - update the src/vfs/_vfscommon from compiled src/modules and src/lib" \n \n append h " - update the src/vfs/_vfscommon from compiled src/modules and src/lib etc" \n
append h " $scriptname get-project-info" \n append h " - before calling this (followed by make project) - you can test using '<builtexe>(.exe) dev'" \n
append h " - show the name and base folder of the project to be built" \n append h " this will load modules from your <projectdir>/module <projectdir>/lib paths instead of from the kit/zipkit" \n \n
append h " $scriptname info" \n
append h " - show the name and base folder of the project to be built" \n
append h "" \n append h "" \n
if {[llength $::punkmake::pkg_missing]} { if {[llength $::punkmake::pkg_missing]} {
append h "* ** NOTE ** ***" \n append h "* ** NOTE ** ***" \n
@ -220,12 +232,68 @@ if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]}
} }
set sourcefolder $projectroot/src set sourcefolder $projectroot/src
if {$::punkmake::command eq "check"} {
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 v [package require punk::mix::base]
puts stdout "punk::mix::base version $v\n[package ifneeded punk::mix::base $v]"
exit 0
}
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]
}
if {$::punkmake::command eq "get-project-info"} { if {$::punkmake::command eq "info"} {
puts stdout "- -- --- --- --- --- --- --- --- --- ---" puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
puts stdout "- -- get-project-info -- -" puts stdout "- -- info -- -"
puts stdout "- -- --- --- --- --- --- --- --- --- ---" puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
puts stdout "- projectroot : $projectroot" puts stdout "- projectroot : $projectroot"
set sourcefolder $projectroot/src
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*]
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*]
puts stdout "- vendorlib folders: ([llength $vendorlibfolders])"
foreach fld $vendorlibfolders {
puts stdout " src/$fld"
}
puts stdout "- vendormodule folders: ([llength $vendormodulefolders])"
foreach fld $vendormodulefolders {
puts stdout " src/$fld"
}
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot]
puts stdout "- source module paths: [llength $source_module_folderlist]"
foreach fld $source_module_folderlist {
puts stdout " $fld"
}
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*]
lappend projectlibfolders lib
puts stdout "- source libary paths: [llength $projectlibfolders]"
foreach fld $projectlibfolders {
puts stdout " src/$fld"
}
if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} {
set vc "fossil" set vc "fossil"
set rev [punk::repo::fossil_revision $scriptfolder] set rev [punk::repo::fossil_revision $scriptfolder]
@ -241,8 +309,11 @@ if {$::punkmake::command eq "get-project-info"} {
} }
puts stdout "- version control : $vc" puts stdout "- version control : $vc"
puts stdout "- revision : $rev" puts stdout "- revision : $rev"
puts stdout "- remote : $rem" puts stdout "- remote"
puts stdout "- -- --- --- --- --- --- --- --- --- ---" foreach ln [split $rem \n] {
puts stdout " $ln"
}
puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
exit 0 exit 0
} }
@ -564,7 +635,7 @@ if {$::punkmake::command eq "bootsupport"} {
if {$::punkmake::command ne "project"} { if {$::punkmake::command ni {project modules}} {
puts stderr "Command $::punkmake::command not implemented - aborting." puts stderr "Command $::punkmake::command not implemented - aborting."
flush stderr flush stderr
after 100 after 100
@ -803,6 +874,19 @@ if {[punk::repo::is_fossil_root $projectroot]} {
$installer destroy $installer destroy
} }
if {$::punkmake::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"
puts stdout " - use 'make.tcl project' to build executable kits/zipkits from vfs folders as well if you have runtimes installed"
puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but"
puts stdout " without the latest built modules."
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'"
puts stdout "-done-"
exit 0
}
set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder]
if {$buildfolder ne "$sourcefolder/_build"} { if {$buildfolder ne "$sourcefolder/_build"} {
puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure" puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure"
@ -832,10 +916,12 @@ if {![llength $runtimes]} {
exit 0 exit 0
} }
set has_sdx 1
if {[catch {exec sdx help} errM]} { if {[catch {exec sdx help} errM]} {
puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" puts stderr "FAILED to find usable sdx command - check that sdx executable is on path"
puts stderr "err: $errM" puts stderr "err: $errM"
exit 1 #exit 1
set has_sdx 0
} }
# -- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- ---
@ -1025,6 +1111,8 @@ foreach runtimefile $runtimes {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set failed_kits [list] set failed_kits [list]
set installed_kits [list] set installed_kits [list]
set skipped_kits [list]
set skipped_kit_installs [list]
proc ::make_file_traversal_error {args} { proc ::make_file_traversal_error {args} {
error "file_traverse error: $args" error "file_traverse error: $args"
@ -1304,30 +1392,39 @@ foreach vfstail $vfs_tails {
} }
} }
kit { kit {
if {[catch { if {!$has_sdx} {
if {$rtname ne "-"} { puts stderr "no sdx available to wrap $targetkit"
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"]
} else {
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose
}
} result]} {
if {$rtname ne "-"} {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result"
} else {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose failed with msg: $result"
}
puts stderr "sdx wrap $targetkit failed"
lappend failed_kits [list kit $targetkit reason $sdxmsg]
$vfs_event targetset_end FAILED $vfs_event targetset_end FAILED
$vfs_event destroy $vfs_event destroy
$vfs_installer destroy $vfs_installer destroy
continue continue
} else { } else {
puts stdout "ok - finished sdx" if {[catch {
set separator [string repeat = 40] if {$rtname ne "-"} {
puts stdout $separator exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose
puts stdout $result } else {
puts stdout $separator exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose
}
} result]} {
if {$rtname ne "-"} {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result"
} else {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose failed with msg: $result"
}
puts stderr "sdx wrap $targetkit failed"
lappend failed_kits [list kit $targetkit reason $sdxmsg]
$vfs_event targetset_end FAILED
$vfs_event destroy
$vfs_installer destroy
continue
} else {
puts stdout "ok - finished sdx"
set separator [string repeat = 40]
puts stdout $separator
puts stdout $result
puts stdout $separator
}
} }
} }
} }
@ -1435,6 +1532,7 @@ foreach vfstail $vfs_tails {
set skipped_vfs_build 1 set skipped_vfs_build 1
puts stderr "." puts stderr "."
puts stdout "Skipping build for vfs $vfstail with runtime $rtname - no change detected" puts stdout "Skipping build for vfs $vfstail with runtime $rtname - no change detected"
lappend skipped_kits [list kit $targetkit reason "no change detected"]
$vfs_event targetset_end SKIPPED $vfs_event targetset_end SKIPPED
} }
$vfs_event destroy $vfs_event destroy
@ -1489,6 +1587,7 @@ foreach vfstail $vfs_tails {
set skipped_kit_install 1 set skipped_kit_install 1
puts stderr "." puts stderr "."
puts stdout "Skipping kit install for $targetkit with vfs $vfstail runtime $rtname - no change detected" puts stdout "Skipping kit install for $targetkit with vfs $vfstail runtime $rtname - no change detected"
lappend skipped_kit_installs [list kit $targetkit reason "no change detected"]
$bin_event targetset_end SKIPPED $bin_event targetset_end SKIPPED
} }
$bin_event destroy $bin_event destroy
@ -1510,8 +1609,21 @@ if {[llength $failed_kits]} {
punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@* punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@*
#puts stderr [join $failed_kits \n] #puts stderr [join $failed_kits \n]
} }
set had_kits [expr {[llength $installed_kits] || [llength $failed_kits] || [llength $skipped_kits]}]
puts stdout "done" if {$had_kits} {
puts stdout " module builds and kit/zipkit builds processed (vfs config: src/runtime/mapvfs.config)"
puts stdout " - use 'make.tcl modules' to build modules without scanning/building the vfs folders into executable kits/zipkits"
puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into the base vfs folder"
puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but"
puts stdout " without the latest built modules."
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'"
} else {
puts stdout " module builds processed"
puts stdout ""
puts stdout " If kit/zipkit based executables required - create src/vfs/<somename>.vfs folders containing lib,modules,modules_tcl9 etc folders"
puts stdout " Also ensure appropriate executables exist in src/runtime along with src/runtime/mapvfs.config"
}
puts stdout "-done-"
exit 0 exit 0

200
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/oolib-0.1.1.tm

@ -1,200 +0,0 @@
#JMN - api should be kept in sync with package patternlib where possible
#
package provide oolib [namespace eval oolib {
variable version
set version 0.1.1
}]
namespace eval oolib {
oo::class create collection {
variable o_data ;#dict
variable o_alias
constructor {} {
set o_data [dict create]
}
method info {} {
return [dict info $o_data]
}
method count {} {
return [dict size $o_data]
}
method isEmpty {} {
expr {[dict size $o_data] == 0}
}
method names {{globOrIdx {}}} {
if {[llength $globOrIdx]} {
if {[string is integer -strict $globOrIdx]} {
set idx $globOrIdx
if {$idx < 0} {
set idx "end-[expr {abs($idx + 1)}]"
}
if {[catch {lindex [dict keys $o_data] $idx} result]} {
error "[self object] no such index : '$idx'"
} else {
return $result
}
} else {
#glob
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx]
}
} else {
return [dict keys $o_data]
}
}
#like names but without globbing
method keys {} {
dict keys $o_data
}
method key {{posn 0}} {
if {$posn < 0} {
set posn "end-[expr {abs($posn + 1)}]"
}
if {[catch {lindex [dict keys $o_data] $posn} result]} {
error "[self object] no such index : '$posn'"
} else {
return $result
}
}
method hasKey {key} {
dict exists $o_data $key
}
method get {} {
return $o_data
}
method items {} {
return [dict values $o_data]
}
method item {key} {
if {[string is integer -strict $key]} {
if {$key >= 0} {
set valposn [expr {(2*$key) +1}]
return [lindex $o_data $valposn]
} else {
set key "end-[expr {abs($key + 1)}]"
return [lindex $o_data $key]
#return [lindex [dict keys $o_data] $key]
}
}
if {[dict exists $o_data $key]} {
return [dict get $o_data $key]
}
}
#inverse lookup
method itemKeys {value} {
set value_indices [lsearch -all [dict values $o_data] $value]
set keylist [list]
foreach i $value_indices {
set idx [expr {(($i + 1) *2) -2}]
lappend keylist [lindex $o_data $idx]
}
return $keylist
}
method search {value args} {
set matches [lsearch {*}$args [dict values $o_data] $value]
if {"-inline" in $args} {
return $matches
} else {
set keylist [list]
foreach i $matches {
set idx [expr {(($i + 1) *2) -2}]
lappend keylist [lindex $o_data $idx]
}
return $keylist
}
}
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists?
method alias {newAlias existingKeyOrAlias} {
if {[string is integer -strict $newAlias]} {
error "[self object] collection key alias cannot be integer"
}
if {[string length $existingKeyOrAlias]} {
set o_alias($newAlias) $existingKeyOrAlias
} else {
unset o_alias($newAlias)
}
}
method aliases {{key ""}} {
if {[string length $key]} {
set result [list]
foreach {n v} [array get o_alias] {
if {$v eq $key} {
lappend result $n $v
}
}
return $result
} else {
return [array get o_alias]
}
}
#if the supplied index is an alias, return the underlying key; else return the index supplied.
method realKey {idx} {
if {[catch {set o_alias($idx)} key]} {
return $idx
} else {
return $key
}
}
method add {value key} {
if {[string is integer -strict $key]} {
error "[self object] collection key must not be an integer. Use another structure if integer keys required"
}
if {[dict exists $o_data $key]} {
error "[self object] col_processors object error: key '$key' already exists in collection"
}
dict set o_data $key $value
return [expr {[dict size $o_data] - 1}] ;#return index of item
}
method remove {idx {endRange ""}} {
if {[string length $endRange]} {
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time"
}
if {[string is integer -strict $idx]} {
if {$idx < 0} {
set idx "end-[expr {abs($idx+1)}]"
}
set key [lindex [dict keys $o_data] $idx]
set posn $idx
} else {
set key $idx
set posn [lsearch -exact [dict keys $o_data] $key]
if {$posn < 0} {
error "[self object] no such index: '$idx' in this collection"
}
}
dict unset o_data $key
return
}
method clear {} {
set o_data [dict create]
return
}
method reverse_the_collection {} {
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy.
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations.
set dictnew [dict create]
foreach k [lreverse [dict keys $o_data]] {
dict set dictnew $k [dict get $o_data $k]
}
set o_data $dictnew
return
}
#review - cmd as list vs cmd as script?
method map {cmd} {
set seed [list]
dict for {k v} $o_data {
lappend seed [uplevel #0 [list {*}$cmd $v]]
}
return $seed
}
method objectmap {cmd} {
set seed [list]
dict for {k v} $o_data {
lappend seed [uplevel #0 [list $v {*}$cmd]]
}
return $seed
}
}
}

3685
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.4.tm

File diff suppressed because it is too large Load Diff

18
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/overtype-1.6.5.tm

@ -439,7 +439,8 @@ tcl::namespace::eval overtype {
if {[llength $lflines]} { if {[llength $lflines]} {
lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1]
} }
set inputchunks $lflines[unset lflines] #set inputchunks $lflines[unset lflines]
set inputchunks [lindex [list $lflines [unset lflines]] 0]
} }
} }
@ -2115,6 +2116,7 @@ tcl::namespace::eval overtype {
if {[llength $undercols]< $opt_width} { if {[llength $undercols]< $opt_width} {
set diff [expr {$opt_width- [llength $undercols]}] set diff [expr {$opt_width- [llength $undercols]}]
if {$diff > 0} { if {$diff > 0} {
#set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower
lappend undercols {*}[lrepeat $diff "\u0000"] lappend undercols {*}[lrepeat $diff "\u0000"]
lappend understacks {*}[lrepeat $diff $cs] lappend understacks {*}[lrepeat $diff $cs]
lappend understacks_gx {*}[lrepeat $diff $gs] lappend understacks_gx {*}[lrepeat $diff $gs]
@ -3889,7 +3891,19 @@ tcl::namespace::eval overtype {
#OSC 4 - set colour palette #OSC 4 - set colour palette
#can take multiple params #can take multiple params
#e.g \x1b\]4\;1\;red\;2\;green\x1b\\ #e.g \x1b\]4\;1\;red\;2\;green\x1b\\
set params [tcl::string::range $code_content 1 end] set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon
set cmap [dict create]
foreach {cnum spec} [split $params {;}] {
if {$cnum >= 0 and $cnum <= 255} {
#todo - parse spec from names like 'red' to RGB
#todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc)
#also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ?
dict set cmap $cnum $spec
} else {
#todo - log
puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"

28
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/console-0.1.1.tm

@ -183,7 +183,9 @@ namespace eval punk::console {
variable previous_stty_state_$channel variable previous_stty_state_$channel
set sttycmd [auto_execok stty] set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} { if {[set previous_stty_state_$channel] eq ""} {
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] if {[catch {{*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
} }
exec {*}$sttycmd raw -echo <@$channel exec {*}$sttycmd raw -echo <@$channel
@ -253,13 +255,21 @@ namespace eval punk::console {
return "line" return "line"
} }
} elseif {$raw_or_line eq "raw"} { } elseif {$raw_or_line eq "raw"} {
punk::console::enableRaw if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} { if {[can_ansi]} {
punk::console::enableVirtualTerminal both punk::console::enableVirtualTerminal both
} }
} elseif {$raw_or_line eq "line"} { } elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
punk::console::disableRaw if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} { if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes punk::console::enableVirtualTerminal output ;#display/use ansi codes
@ -290,12 +300,15 @@ namespace eval punk::console {
set loadstate [zzzload::pkg_require twapi] set loadstate [zzzload::pkg_require twapi]
#loadstate could also be stuck on loading? - review - zzzload not very ripe #loadstate could also be stuck on loading? - review - zzzload not very ripe
#Twapi is relatively slow to load - can be 1s plus in normal cases - and much longer if there are disk performance issues. #Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues.
if {$loadstate ni [list failed]} { if {$loadstate ni [list failed]} {
#possibly still 'loading'
#review zzzload usage #review zzzload usage
#puts stdout "=========== console loading twapi =============" #puts stdout "=========== console loading twapi ============="
zzzload::pkg_wait twapi set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait
}
if {$loadstate ni [list failed]} {
package require twapi ;#should be fast once twapi dll loaded in zzzload thread package require twapi ;#should be fast once twapi dll loaded in zzzload thread
set ::punk::console::has_twapi 1 set ::punk::console::has_twapi 1
@ -523,6 +536,9 @@ namespace eval punk::console {
set is_raw 0 set is_raw 0
return [list stdin [list from $oldmode to $newmode]] return [list stdin [list from $oldmode to $newmode]]
} elseif {[set sttycmd [auto_execok stty]] ne ""} { } elseif {[set sttycmd [auto_execok stty]] ne ""} {
#stty can return info on windows - but doesn't seem to be able to set anything.
#review - is returned info even valid?
set sttycmd [auto_execok stty] set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} { if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel] exec {*}$sttycmd [set previous_stty_state_$channel]

165
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm

@ -339,6 +339,92 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}] set has_twapi [expr {![catch {package require twapi}]}]
} }
# -- ---
#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
#8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows
# Review and retest as new versions come out.
# -- ---
proc list_multi_append1 {lvar1 lvar2} {
#clear winner in 2024
upvar $lvar1 l1 $lvar2 l2
lappend l1 {*}$l2
return $l1
}
proc list_multi_append2 {lvar1 lvar2} {
upvar $lvar1 l1 $lvar2 l2
set l1 [list {*}$l1 {*}$l2]
}
proc list_multi_append3 {lvar1 lvar2} {
upvar $lvar1 l1 $lvar2 l2
set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0]
}
#testing e.g
#set l1_reset {a b c}
#set l2 {a b c d e f g}
#set l1 $l1_reset
#time {list_multi_append1 l1 l2} 1000
#set l1 $l1_reset
#time {list_multi_append2 l1 l2} 1000
# -- ---
proc lswap {lvar a z} {
upvar $lvar l
if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} {
#if we didn't do this check - we could raise an error on second lset - leaving list corrupted because only one lset occurred
#(e.g using: lswap mylist end-2 end on a two element list)
#on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report
set a_index [lindex_resolve $l $a]
set a_msg ""
switch -- $a_index {
-2 {
"$a is greater th
}
-3 {
}
}
error "lswap cannot indices $a and $z $a is out of range"
}
set item2 [lindex $l $z]
lset l $z [lindex $l $a]
lset l $a $item2
return $l
}
#proc lswap2 {lvar a z} {
# upvar $lvar l
# #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower
# set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]]
#}
proc lswap2 {lvar a z} {
upvar $lvar l
#if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower
set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]]
}
#an experimental test of swapping vars without intermediate variables
#It's an interesting idea - but probably of little to no practical use
# - the swap_intvars3 version using intermediate var is faster in Tcl
# - This is probably unsurprising - as it's simpler code.
# Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks.
#proc swap_intvars {swapv1 swapv2} {
# upvar $swapv1 _x $swapv2 _y
# set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}]
#}
#proc swap_intvars2 {swapv1 swapv2} {
# upvar $swapv1 _x $swapv2 _y
# set _x [expr {$_x ^ $_y}]
# set _y [expr {$_x ^ $_y}]
# set _x [expr {$_x ^ $_y}]
#}
#proc swap_intvars3 {swapv1 swapv2} {
# #using intermediate variable
# upvar $swapv1 _x $swapv2 _y
# set z $_x
# set _x $_y
# set _y $z
#}
#*** !doctools #*** !doctools
#[subsection {Namespace punk::lib}] #[subsection {Namespace punk::lib}]
@ -347,6 +433,7 @@ namespace eval punk::lib {
if {[info commands lseq] ne ""} { if {[info commands lseq] ne ""} {
#tcl 8.7+ lseq significantly faster, especially for larger ranges #tcl 8.7+ lseq significantly faster, especially for larger ranges
#The internal rep can be an 'arithseries' with no string representation
#support minimal set from to #support minimal set from to
proc range {from to} { proc range {from to} {
lseq $from $to lseq $from $to
@ -1009,24 +1096,28 @@ namespace eval punk::lib {
} }
set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high
#keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds
if {${lower_resolve} == -1} { if {${lower_resolve} == -2} {
##x
#lower bound is above upper list range #lower bound is above upper list range
#match with decreasing indices is still possible #match with decreasing indices is still possible
set lower [expr {[llength $dval]-1}] ;#set to max set lower [expr {[llength $dval]-1}] ;#set to max
} elseif {$lower_resolve == -2} { } elseif {$lower_resolve == -3} {
##x
set lower 0 set lower 0
} else { } else {
set lower $lower_resolve set lower $lower_resolve
} }
set upper [punk::lib::lindex_resolve $dval $b] set upper [punk::lib::lindex_resolve $dval $b]
if {$upper == -2} { if {$upper == -3} {
##x
#upper bound is below list range - #upper bound is below list range -
if {$lower_resolve >=-1} { if {$lower_resolve >=-2} {
##x
set upper 0 set upper 0
} else { } else {
continue continue
} }
} elseif {$upper == -1} { } elseif {$upper == -2} {
#use max #use max
set upper [expr {[llength $dval]-1}] set upper [expr {[llength $dval]-1}]
#assert - upper >=0 because we have ruled out empty lists #assert - upper >=0 because we have ruled out empty lists
@ -1670,6 +1761,7 @@ namespace eval punk::lib {
} }
} }
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side
proc lindex_resolve {list index} { proc lindex_resolve {list index} {
#*** !doctools #*** !doctools
#[call [fun lindex_resolve] [arg list] [arg index]] #[call [fun lindex_resolve] [arg list] [arg index]]
@ -1679,11 +1771,13 @@ namespace eval punk::lib {
#[para]Sometimes the actual integer index is desired. #[para]Sometimes the actual integer index is desired.
#[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks.
#[para]lindex_resolve will parse the index expression and return: #[para]lindex_resolve will parse the index expression and return:
#[para] a) -2 if the supplied index expression is below the lower bound for the supplied list. (< 0) #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
#[para] b) -1 if the supplied index expression is above the upper bound for the supplied list. (> end) #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end)
#[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list
#[para]Otherwise it will return an integer corresponding to the position in the list. #[para]Otherwise it will return an integer corresponding to the position in the list.
#[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway. #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway.
#[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable
#[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2
#Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr
#if {![llength $list]} { #if {![llength $list]} {
@ -1694,9 +1788,9 @@ namespace eval punk::lib {
if {[string is integer -strict $index]} { if {[string is integer -strict $index]} {
#can match +i -i #can match +i -i
if {$index < 0} { if {$index < 0} {
return -2 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= [llength $list]} {
return -1 return -2
} else { } else {
#integer may still have + sign - normalize with expr #integer may still have + sign - normalize with expr
return [expr {$index}] return [expr {$index}]
@ -1708,14 +1802,14 @@ namespace eval punk::lib {
set offset [string range $index 4 end] set offset [string range $index 4 end]
if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"}
if {$op eq "+" && $offset != 0} { if {$op eq "+" && $offset != 0} {
return -1 return -2
} }
} else { } else {
#end #index is 'end'
set index [expr {[llength $list]-1}] set index [expr {[llength $list]-1}]
if {$index < 0} { if {$index < 0} {
#special case - end with empty list - treat end like a positive number out of bounds #special case - 'end' with empty list - treat end like a positive number out of bounds
return -1 return -2
} else { } else {
return $index return $index
} }
@ -1723,7 +1817,7 @@ namespace eval punk::lib {
if {$offset == 0} { if {$offset == 0} {
set index [expr {[llength $list]-1}] set index [expr {[llength $list]-1}]
if {$index < 0} { if {$index < 0} {
return -1 ;#special case return -2 ;#special case as above
} else { } else {
return $index return $index
} }
@ -1732,7 +1826,7 @@ namespace eval punk::lib {
set index [expr {([llength $list]-1) - $offset}] set index [expr {([llength $list]-1) - $offset}]
} }
if {$index < 0} { if {$index < 0} {
return -2 return -3
} else { } else {
return $index return $index
} }
@ -1753,26 +1847,50 @@ namespace eval punk::lib {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
} }
if {$index < 0} { if {$index < 0} {
return -2 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= [llength $list]} {
return -1 return -2
} }
return $index return $index
} }
} }
} }
proc lindex_resolve2 {list index} { proc lindex_resolve_basic {list index} {
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. #*** !doctools
#[call [fun lindex_resolve_basic] [arg list] [arg index]]
#[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2)
#[para] returns -1 for out of range at either end, or a valid integer index
#[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound
#[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command
#[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1
#[para] For pure integer indices the performance should be equivalent
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+
# - which
#for {set i 0} {$i < [llength $list]} {incr i} { #for {set i 0} {$i < [llength $list]} {incr i} {
# lappend indices $i # lappend indices $i
#} #}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
#avoid even the lseq overhead when the index is simple
if {$index < 0 || ($index >= [llength $list])} {
#even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method.
return -1
} else {
#integer may still have + sign - normalize with expr
return [expr {$index}]
}
}
if {[llength $list]} { if {[llength $list]} {
set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback.
#if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?)
} else { } else {
set indices [list] set indices [list]
} }
set idx [lindex $indices $index] set idx [lindex $indices $index]
if {$idx eq ""} { if {$idx eq ""} {
#we have no way to determine if out of bounds is at lower vs upper end
return -1 return -1
} else { } else {
return $idx return $idx
@ -2334,13 +2452,6 @@ namespace eval punk::lib {
} }
return $prefix return $prefix
} }
#test example of the technique - not necessarily particularly useful as a function, except maybe for brevity/clarity. todo - test if inlined version gives any perf advantage compared to a temp var
proc swapnumvars {namea nameb} {
upvar $namea a $nameb b
set a [expr {$a ^ $b}]
set b [expr {$a ^ $b}]
set a [expr {$a ^ $b}]
}
#e.g linesort -decreasing $data #e.g linesort -decreasing $data
proc linesort {args} { proc linesort {args} {
@ -2956,7 +3067,7 @@ namespace eval punk::lib {
# and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]*
proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} {
set number [punk::objclone $unformattednumber] set number [objclone $unformattednumber]
set number [string map {_ ""} $number] set number [string map {_ ""} $number]
#normalize using expr - e.g 2e4 -> 20000.0 #normalize using expr - e.g 2e4 -> 20000.0
set number [expr {$number}] set number [expr {$number}]

35
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm

@ -4,6 +4,7 @@ package provide punk::mix::base [namespace eval punk::mix::base {
}] }]
package require punk::path package require punk::path
package require punk::lib ;#format_number etc
#base internal plumbing functions #base internal plumbing functions
namespace eval punk::mix::base { namespace eval punk::mix::base {
@ -657,16 +658,38 @@ namespace eval punk::mix::base {
#temp emission to stdout.. todo - repl telemetry channel #temp emission to stdout.. todo - repl telemetry channel
puts stdout "cksum_path: creating temporary tar archive for $path" puts stdout "cksum_path: creating temporary tar archive for $path"
puts stdout " at: $archivename .." puts -nonewline stdout " at: $archivename ..."
tar::create $archivename $target set tsstart [clock millis]
if {[set tarpath [auto_execok tar]] ne ""} {
#using an external binary is *significantly* faster than tar::create - but comes with some risks
#review - need to check behaviour/flag variances across platforms
#don't use -z flag. On at least some tar versions the zipped file will contain a timestamped subfolder of filename.tar - which ruins the checksum
#also - tar is generally faster without the compression (although this may vary depending on file size and disk speed?)
exec {*}$tarpath -cf $archivename $target ;#{*} needed in case spaces in tarpath
set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " tar -cf done ($ms ms)"
} else {
set tsstart [clock millis] ;#don't include auto_exec search time for tar::create
tar::create $archivename $target
set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " tar::create done ($ms ms)"
puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing"
}
if {$ftype eq "file"} { if {$ftype eq "file"} {
set sizeinfo "(size [file size $target])" set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)"
} else { } else {
set sizeinfo "(file type $ftype - size unknown)" set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)"
} }
puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." set tsstart [clock millis]
puts -nonewline stdout "cksum_path: calculating cksum for $target $sizeinfo ... "
set cksum [{*}$cksum_command $archivename] set cksum [{*}$cksum_command $archivename]
#puts stdout "cksum_path: cleaning up.. " set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " cksum done ($ms ms)"
puts stdout " cksum: $cksum"
file delete -force $archivename file delete -force $archivename
cd $startdir cd $startdir

6
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm

@ -157,6 +157,9 @@ namespace eval punk::mix::commandset::project {
set opt_force [dict get $opts -force] set opt_force [dict get $opts -force]
set opt_confirm [string tolower [dict get $opts -confirm]] set opt_confirm [string tolower [dict get $opts -confirm]]
# -- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_layout [dict get $opts -layout]
set opt_update [dict get $opts -update]
# -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_modules [dict get $opts -modules] set opt_modules [dict get $opts -modules]
if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} {
#if not specified - add a single module matching project name #if not specified - add a single module matching project name
@ -169,9 +172,6 @@ namespace eval punk::mix::commandset::project {
} }
} }
# -- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_layout [dict get $opts -layout]
set opt_update [dict get $opts -update]
# -- --- --- --- --- --- --- --- --- --- --- --- ---
#todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache

68
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm

@ -1707,6 +1707,7 @@ tcl::namespace::eval punk::ns {
lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs
set use_vars [expr {"-vars" in $runopts}] set use_vars [expr {"-vars" in $runopts}]
set no_warnings [expr {"-nowarnings" in $runopts}] set no_warnings [expr {"-nowarnings" in $runopts}]
set ver ""
#todo support leading solo flags such as -capture to control whether we do a static capture of local vars in the ns #todo support leading solo flags such as -capture to control whether we do a static capture of local vars in the ns
@ -1717,15 +1718,68 @@ tcl::namespace::eval punk::ns {
} }
default { default {
if {[string match ::* $pkg_or_existing_ns]} { if {[string match ::* $pkg_or_existing_ns]} {
set pkg_unqualified [string range $pkg_or_existing_ns 2 end]
if {![tcl::namespace::exists $pkg_or_existing_ns]} { if {![tcl::namespace::exists $pkg_or_existing_ns]} {
set ver [package require [string range $pkg_or_existing_ns 2 end]] set ver [package require $pkg_unqualified]
} else { } else {
set ver "" set ver ""
} }
set ns $pkg_or_existing_ns set ns $pkg_or_existing_ns
} else { } else {
set ver [package require $pkg_or_existing_ns] set pkg_unqualified $pkg_or_existing_ns
set ns ::$pkg_or_existing_ns set ver [package require $pkg_unqualified]
set ns ::$pkg_unqualified
}
#some packages don't create their namespace immediately and/or don't populate it with commands and instead put entries in ::auto_index
set previous_command_count 0
if {[namespace exists $ns]} {
set previous_command_count [llength [info commands ${ns}::*]]
}
#also if a sub package was loaded first - then the namespace for the base or lower package may exist but have no commands
#for the purposes of pkguse - which most commonly interactive - we want the namespace populated
#It may still not be *fully* populated because we stop at first source that adds commands - REVIEW
set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}]
if {!$ns_populated} {
#we will catch-run an auto_index entry if any
#auto_index entry may or may not be prefixed with ::
set keys [list]
#first look for exact pkg_unqualified and ::pkg_unqualified
#leave these at beginning of keys list
if {[array exists ::auto_index($pkg_unqualified)]} {
lappend keys $pkg_unqualified
}
if {[array exists ::auto_index(::$pkg_unqualified)]} {
lappend keys ::$pkg_unqualified
}
#as auto_index is an array - we could get keys in arbitrary order
set matches [lsort [array names ::auto_index ${pkg_unqualified}::*]]
lappend keys {*}$matches
set matches [lsort [array names ::auto_index ::${pkg_unqualified}::*]]
lappend keys {*}$matches
set ns_populated 0
set i 0
set already_sourced [list] ;#often multiple triggers for the same source - don't waste time re-sourcing
set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]]
while {!$ns_populated && $i < [llength $keys]} {
#todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base
#e.g if we are loading ::x::y
#only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc
set k [lindex $keys $i]
set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]]
if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} {
set auto_source [set ::auto_index($k)]
if {$auto_source ni $already_sourced} {
uplevel 1 $auto_source
lappend already_sourced $auto_source
set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}]
}
}
incr i
}
} }
} }
} }
@ -1799,7 +1853,13 @@ tcl::namespace::eval punk::ns {
return $out return $out
} }
} else { } else {
error "Namespace $ns not found." if {$ver eq ""} {
error "Namespace $ns not found. No package version found."
} else {
set out "(no package namespace found) remaining in [uplevel 1 {namespace current}]"
append out \n $ver
return $out
}
} }
return $out return $out
} }

2
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm

@ -468,7 +468,7 @@ namespace eval punk::repo {
set path [string trim [string range $ln [string length "MISSING "] end]] set path [string trim [string range $ln [string length "MISSING "] end]]
dict set pathdict $path "missing" dict set pathdict $path "missing"
} }
"EXTRA * " { "EXTRA *" {
#fossil will explicitly list files in a new folder - as opposed to git which shows just the folder #fossil will explicitly list files in a new folder - as opposed to git which shows just the folder
set path [string trim [string range $ln [string length "EXTRA "] end]] set path [string trim [string range $ln [string length "EXTRA "] end]]
dict set pathdict $path "extra" dict set pathdict $path "extra"

BIN
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm

Binary file not shown.

3658
src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/tomlish-1.1.1.tm

File diff suppressed because it is too large Load Diff

214
src/project_layouts/custom/_project/punk.project-0.1/src/make.tcl

@ -13,7 +13,7 @@ namespace eval ::punkmake {
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k] variable non_help_flags [list -k]
variable help_flags [list -help --help /?] variable help_flags [list -help --help /?]
variable known_commands [list project get-project-info shell vendorupdate bootsupport vfscommonupdate] variable known_commands [list project modules info check shell vendorupdate bootsupport vfscommonupdate]
} }
if {"::try" ni [info commands ::try]} { if {"::try" ni [info commands ::try]} {
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting"
@ -21,7 +21,7 @@ if {"::try" ni [info commands ::try]} {
} }
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
#Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder #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 the there is a folder under the current directory /src/bootsupport/modules which contains .tm files
# - then it will attempt to preference these modules # - then it will attempt to preference these modules
@ -35,8 +35,10 @@ if {[file exists [file join $startdir src bootsupport]]} {
set bootsupport_mod [file join $startdir bootsupport modules] set bootsupport_mod [file join $startdir bootsupport modules]
set bootsupport_lib [file join $startdir bootsupport lib] set bootsupport_lib [file join $startdir bootsupport lib]
} }
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
set package_paths_modified 0
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
set original_tm_list [tcl::tm::list] set original_tm_list [tcl::tm::list]
tcl::tm::remove {*}$original_tm_list tcl::tm::remove {*}$original_tm_list
set original_auto_path $::auto_path set original_auto_path $::auto_path
@ -63,8 +65,18 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
} }
if {[file exists [pwd]/modules]} { #we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir.
tcl::tm::add [pwd]/modules #The <projectdir>/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 <projectdir/src is also likely to be common
# but we need to be loud about what's going on.
puts stderr "------------------------------------------------------------------"
puts stderr "Launched from within a folder ending in 'src'"
puts stderr " - modules in $startdir/modules may override bootsupport modules"
puts stderr "------------------------------------------------------------------"
tcl::tm::add $startdir/modules
}
} }
#package require Thread #package require Thread
@ -81,16 +93,8 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
package require punkcheck package require punkcheck
package require punk::lib package require punk::lib
set package_paths_modified 1
#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]
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
} }
@ -106,6 +110,8 @@ try {
} }
package require punk::mix package require punk::mix
package require punk::repo package require punk::repo
package require punk::ansi
package require overtype
} finally { } finally {
catch {rename ::package ""} catch {rename ::package ""}
catch {rename ::punkmake::package_temp_aside ::package} catch {rename ::punkmake::package_temp_aside ::package}
@ -129,18 +135,24 @@ proc punkmake_gethelp {args} {
append h "Usage:" \n append h "Usage:" \n
append h "" \n append h "" \n
append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n
append h " - This help." \n \n append h " - This help." \n \n
append h " $scriptname project ?-k?" \n append h " $scriptname project ?-k?" \n
append h " - this is the literal word project - and confirms you want to run the project build" \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 \n append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n
append h " - built modules go into <projectdir>/modules <projectdir>/lib etc." \n \n
append h " $scriptname modules" \n
append h " - build modules from src/modules etc without scanning src/runtime and src/vfs folders to build kit/zipkit executables" \n \n
append h " $scriptname bootsupport" \n append h " $scriptname bootsupport" \n
append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n \n append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n
append h " - bootsupport modules are available to make.tcl" \n \n
append h " $scriptname vendorupdate" \n append h " $scriptname vendorupdate" \n
append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n
append h " $scriptname vfscommonupdate" \n append h " $scriptname vfscommonupdate" \n
append h " - update the src/vfs/_vfscommon from compiled src/modules and src/lib" \n \n append h " - update the src/vfs/_vfscommon from compiled src/modules and src/lib etc" \n
append h " $scriptname get-project-info" \n append h " - before calling this (followed by make project) - you can test using '<builtexe>(.exe) dev'" \n
append h " - show the name and base folder of the project to be built" \n append h " this will load modules from your <projectdir>/module <projectdir>/lib paths instead of from the kit/zipkit" \n \n
append h " $scriptname info" \n
append h " - show the name and base folder of the project to be built" \n
append h "" \n append h "" \n
if {[llength $::punkmake::pkg_missing]} { if {[llength $::punkmake::pkg_missing]} {
append h "* ** NOTE ** ***" \n append h "* ** NOTE ** ***" \n
@ -220,12 +232,68 @@ if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]}
} }
set sourcefolder $projectroot/src set sourcefolder $projectroot/src
if {$::punkmake::command eq "check"} {
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 v [package require punk::mix::base]
puts stdout "punk::mix::base version $v\n[package ifneeded punk::mix::base $v]"
exit 0
}
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]
}
if {$::punkmake::command eq "get-project-info"} { if {$::punkmake::command eq "info"} {
puts stdout "- -- --- --- --- --- --- --- --- --- ---" puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
puts stdout "- -- get-project-info -- -" puts stdout "- -- info -- -"
puts stdout "- -- --- --- --- --- --- --- --- --- ---" puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
puts stdout "- projectroot : $projectroot" puts stdout "- projectroot : $projectroot"
set sourcefolder $projectroot/src
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*]
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*]
puts stdout "- vendorlib folders: ([llength $vendorlibfolders])"
foreach fld $vendorlibfolders {
puts stdout " src/$fld"
}
puts stdout "- vendormodule folders: ([llength $vendormodulefolders])"
foreach fld $vendormodulefolders {
puts stdout " src/$fld"
}
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot]
puts stdout "- source module paths: [llength $source_module_folderlist]"
foreach fld $source_module_folderlist {
puts stdout " $fld"
}
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*]
lappend projectlibfolders lib
puts stdout "- source libary paths: [llength $projectlibfolders]"
foreach fld $projectlibfolders {
puts stdout " src/$fld"
}
if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} {
set vc "fossil" set vc "fossil"
set rev [punk::repo::fossil_revision $scriptfolder] set rev [punk::repo::fossil_revision $scriptfolder]
@ -241,8 +309,11 @@ if {$::punkmake::command eq "get-project-info"} {
} }
puts stdout "- version control : $vc" puts stdout "- version control : $vc"
puts stdout "- revision : $rev" puts stdout "- revision : $rev"
puts stdout "- remote : $rem" puts stdout "- remote"
puts stdout "- -- --- --- --- --- --- --- --- --- ---" foreach ln [split $rem \n] {
puts stdout " $ln"
}
puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
exit 0 exit 0
} }
@ -564,7 +635,7 @@ if {$::punkmake::command eq "bootsupport"} {
if {$::punkmake::command ne "project"} { if {$::punkmake::command ni {project modules}} {
puts stderr "Command $::punkmake::command not implemented - aborting." puts stderr "Command $::punkmake::command not implemented - aborting."
flush stderr flush stderr
after 100 after 100
@ -803,6 +874,19 @@ if {[punk::repo::is_fossil_root $projectroot]} {
$installer destroy $installer destroy
} }
if {$::punkmake::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"
puts stdout " - use 'make.tcl project' to build executable kits/zipkits from vfs folders as well if you have runtimes installed"
puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but"
puts stdout " without the latest built modules."
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'"
puts stdout "-done-"
exit 0
}
set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder]
if {$buildfolder ne "$sourcefolder/_build"} { if {$buildfolder ne "$sourcefolder/_build"} {
puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure" puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure"
@ -832,10 +916,12 @@ if {![llength $runtimes]} {
exit 0 exit 0
} }
set has_sdx 1
if {[catch {exec sdx help} errM]} { if {[catch {exec sdx help} errM]} {
puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" puts stderr "FAILED to find usable sdx command - check that sdx executable is on path"
puts stderr "err: $errM" puts stderr "err: $errM"
exit 1 #exit 1
set has_sdx 0
} }
# -- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- ---
@ -1025,6 +1111,8 @@ foreach runtimefile $runtimes {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set failed_kits [list] set failed_kits [list]
set installed_kits [list] set installed_kits [list]
set skipped_kits [list]
set skipped_kit_installs [list]
proc ::make_file_traversal_error {args} { proc ::make_file_traversal_error {args} {
error "file_traverse error: $args" error "file_traverse error: $args"
@ -1304,30 +1392,39 @@ foreach vfstail $vfs_tails {
} }
} }
kit { kit {
if {[catch { if {!$has_sdx} {
if {$rtname ne "-"} { puts stderr "no sdx available to wrap $targetkit"
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"]
} else {
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose
}
} result]} {
if {$rtname ne "-"} {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result"
} else {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose failed with msg: $result"
}
puts stderr "sdx wrap $targetkit failed"
lappend failed_kits [list kit $targetkit reason $sdxmsg]
$vfs_event targetset_end FAILED $vfs_event targetset_end FAILED
$vfs_event destroy $vfs_event destroy
$vfs_installer destroy $vfs_installer destroy
continue continue
} else { } else {
puts stdout "ok - finished sdx" if {[catch {
set separator [string repeat = 40] if {$rtname ne "-"} {
puts stdout $separator exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose
puts stdout $result } else {
puts stdout $separator exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose
}
} result]} {
if {$rtname ne "-"} {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result"
} else {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose failed with msg: $result"
}
puts stderr "sdx wrap $targetkit failed"
lappend failed_kits [list kit $targetkit reason $sdxmsg]
$vfs_event targetset_end FAILED
$vfs_event destroy
$vfs_installer destroy
continue
} else {
puts stdout "ok - finished sdx"
set separator [string repeat = 40]
puts stdout $separator
puts stdout $result
puts stdout $separator
}
} }
} }
} }
@ -1435,6 +1532,7 @@ foreach vfstail $vfs_tails {
set skipped_vfs_build 1 set skipped_vfs_build 1
puts stderr "." puts stderr "."
puts stdout "Skipping build for vfs $vfstail with runtime $rtname - no change detected" puts stdout "Skipping build for vfs $vfstail with runtime $rtname - no change detected"
lappend skipped_kits [list kit $targetkit reason "no change detected"]
$vfs_event targetset_end SKIPPED $vfs_event targetset_end SKIPPED
} }
$vfs_event destroy $vfs_event destroy
@ -1489,6 +1587,7 @@ foreach vfstail $vfs_tails {
set skipped_kit_install 1 set skipped_kit_install 1
puts stderr "." puts stderr "."
puts stdout "Skipping kit install for $targetkit with vfs $vfstail runtime $rtname - no change detected" puts stdout "Skipping kit install for $targetkit with vfs $vfstail runtime $rtname - no change detected"
lappend skipped_kit_installs [list kit $targetkit reason "no change detected"]
$bin_event targetset_end SKIPPED $bin_event targetset_end SKIPPED
} }
$bin_event destroy $bin_event destroy
@ -1510,8 +1609,21 @@ if {[llength $failed_kits]} {
punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@* punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@*
#puts stderr [join $failed_kits \n] #puts stderr [join $failed_kits \n]
} }
set had_kits [expr {[llength $installed_kits] || [llength $failed_kits] || [llength $skipped_kits]}]
puts stdout "done" if {$had_kits} {
puts stdout " module builds and kit/zipkit builds processed (vfs config: src/runtime/mapvfs.config)"
puts stdout " - use 'make.tcl modules' to build modules without scanning/building the vfs folders into executable kits/zipkits"
puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into the base vfs folder"
puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but"
puts stdout " without the latest built modules."
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'"
} else {
puts stdout " module builds processed"
puts stdout ""
puts stdout " If kit/zipkit based executables required - create src/vfs/<somename>.vfs folders containing lib,modules,modules_tcl9 etc folders"
puts stdout " Also ensure appropriate executables exist in src/runtime along with src/runtime/mapvfs.config"
}
puts stdout "-done-"
exit 0 exit 0

18
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/overtype-1.6.5.tm

@ -439,7 +439,8 @@ tcl::namespace::eval overtype {
if {[llength $lflines]} { if {[llength $lflines]} {
lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1]
} }
set inputchunks $lflines[unset lflines] #set inputchunks $lflines[unset lflines]
set inputchunks [lindex [list $lflines [unset lflines]] 0]
} }
} }
@ -2115,6 +2116,7 @@ tcl::namespace::eval overtype {
if {[llength $undercols]< $opt_width} { if {[llength $undercols]< $opt_width} {
set diff [expr {$opt_width- [llength $undercols]}] set diff [expr {$opt_width- [llength $undercols]}]
if {$diff > 0} { if {$diff > 0} {
#set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower
lappend undercols {*}[lrepeat $diff "\u0000"] lappend undercols {*}[lrepeat $diff "\u0000"]
lappend understacks {*}[lrepeat $diff $cs] lappend understacks {*}[lrepeat $diff $cs]
lappend understacks_gx {*}[lrepeat $diff $gs] lappend understacks_gx {*}[lrepeat $diff $gs]
@ -3889,7 +3891,19 @@ tcl::namespace::eval overtype {
#OSC 4 - set colour palette #OSC 4 - set colour palette
#can take multiple params #can take multiple params
#e.g \x1b\]4\;1\;red\;2\;green\x1b\\ #e.g \x1b\]4\;1\;red\;2\;green\x1b\\
set params [tcl::string::range $code_content 1 end] set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon
set cmap [dict create]
foreach {cnum spec} [split $params {;}] {
if {$cnum >= 0 and $cnum <= 255} {
#todo - parse spec from names like 'red' to RGB
#todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc)
#also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ?
dict set cmap $cnum $spec
} else {
#todo - log
puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"

28
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/console-0.1.1.tm

@ -183,7 +183,9 @@ namespace eval punk::console {
variable previous_stty_state_$channel variable previous_stty_state_$channel
set sttycmd [auto_execok stty] set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} { if {[set previous_stty_state_$channel] eq ""} {
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] if {[catch {{*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
} }
exec {*}$sttycmd raw -echo <@$channel exec {*}$sttycmd raw -echo <@$channel
@ -253,13 +255,21 @@ namespace eval punk::console {
return "line" return "line"
} }
} elseif {$raw_or_line eq "raw"} { } elseif {$raw_or_line eq "raw"} {
punk::console::enableRaw if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} { if {[can_ansi]} {
punk::console::enableVirtualTerminal both punk::console::enableVirtualTerminal both
} }
} elseif {$raw_or_line eq "line"} { } elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
punk::console::disableRaw if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} { if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes punk::console::enableVirtualTerminal output ;#display/use ansi codes
@ -290,12 +300,15 @@ namespace eval punk::console {
set loadstate [zzzload::pkg_require twapi] set loadstate [zzzload::pkg_require twapi]
#loadstate could also be stuck on loading? - review - zzzload not very ripe #loadstate could also be stuck on loading? - review - zzzload not very ripe
#Twapi is relatively slow to load - can be 1s plus in normal cases - and much longer if there are disk performance issues. #Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues.
if {$loadstate ni [list failed]} { if {$loadstate ni [list failed]} {
#possibly still 'loading'
#review zzzload usage #review zzzload usage
#puts stdout "=========== console loading twapi =============" #puts stdout "=========== console loading twapi ============="
zzzload::pkg_wait twapi set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait
}
if {$loadstate ni [list failed]} {
package require twapi ;#should be fast once twapi dll loaded in zzzload thread package require twapi ;#should be fast once twapi dll loaded in zzzload thread
set ::punk::console::has_twapi 1 set ::punk::console::has_twapi 1
@ -523,6 +536,9 @@ namespace eval punk::console {
set is_raw 0 set is_raw 0
return [list stdin [list from $oldmode to $newmode]] return [list stdin [list from $oldmode to $newmode]]
} elseif {[set sttycmd [auto_execok stty]] ne ""} { } elseif {[set sttycmd [auto_execok stty]] ne ""} {
#stty can return info on windows - but doesn't seem to be able to set anything.
#review - is returned info even valid?
set sttycmd [auto_execok stty] set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} { if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel] exec {*}$sttycmd [set previous_stty_state_$channel]

165
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/lib-0.1.1.tm

@ -339,6 +339,92 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}] set has_twapi [expr {![catch {package require twapi}]}]
} }
# -- ---
#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
#8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows
# Review and retest as new versions come out.
# -- ---
proc list_multi_append1 {lvar1 lvar2} {
#clear winner in 2024
upvar $lvar1 l1 $lvar2 l2
lappend l1 {*}$l2
return $l1
}
proc list_multi_append2 {lvar1 lvar2} {
upvar $lvar1 l1 $lvar2 l2
set l1 [list {*}$l1 {*}$l2]
}
proc list_multi_append3 {lvar1 lvar2} {
upvar $lvar1 l1 $lvar2 l2
set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0]
}
#testing e.g
#set l1_reset {a b c}
#set l2 {a b c d e f g}
#set l1 $l1_reset
#time {list_multi_append1 l1 l2} 1000
#set l1 $l1_reset
#time {list_multi_append2 l1 l2} 1000
# -- ---
proc lswap {lvar a z} {
upvar $lvar l
if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} {
#if we didn't do this check - we could raise an error on second lset - leaving list corrupted because only one lset occurred
#(e.g using: lswap mylist end-2 end on a two element list)
#on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report
set a_index [lindex_resolve $l $a]
set a_msg ""
switch -- $a_index {
-2 {
"$a is greater th
}
-3 {
}
}
error "lswap cannot indices $a and $z $a is out of range"
}
set item2 [lindex $l $z]
lset l $z [lindex $l $a]
lset l $a $item2
return $l
}
#proc lswap2 {lvar a z} {
# upvar $lvar l
# #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower
# set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]]
#}
proc lswap2 {lvar a z} {
upvar $lvar l
#if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower
set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]]
}
#an experimental test of swapping vars without intermediate variables
#It's an interesting idea - but probably of little to no practical use
# - the swap_intvars3 version using intermediate var is faster in Tcl
# - This is probably unsurprising - as it's simpler code.
# Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks.
#proc swap_intvars {swapv1 swapv2} {
# upvar $swapv1 _x $swapv2 _y
# set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}]
#}
#proc swap_intvars2 {swapv1 swapv2} {
# upvar $swapv1 _x $swapv2 _y
# set _x [expr {$_x ^ $_y}]
# set _y [expr {$_x ^ $_y}]
# set _x [expr {$_x ^ $_y}]
#}
#proc swap_intvars3 {swapv1 swapv2} {
# #using intermediate variable
# upvar $swapv1 _x $swapv2 _y
# set z $_x
# set _x $_y
# set _y $z
#}
#*** !doctools #*** !doctools
#[subsection {Namespace punk::lib}] #[subsection {Namespace punk::lib}]
@ -347,6 +433,7 @@ namespace eval punk::lib {
if {[info commands lseq] ne ""} { if {[info commands lseq] ne ""} {
#tcl 8.7+ lseq significantly faster, especially for larger ranges #tcl 8.7+ lseq significantly faster, especially for larger ranges
#The internal rep can be an 'arithseries' with no string representation
#support minimal set from to #support minimal set from to
proc range {from to} { proc range {from to} {
lseq $from $to lseq $from $to
@ -1009,24 +1096,28 @@ namespace eval punk::lib {
} }
set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high
#keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds
if {${lower_resolve} == -1} { if {${lower_resolve} == -2} {
##x
#lower bound is above upper list range #lower bound is above upper list range
#match with decreasing indices is still possible #match with decreasing indices is still possible
set lower [expr {[llength $dval]-1}] ;#set to max set lower [expr {[llength $dval]-1}] ;#set to max
} elseif {$lower_resolve == -2} { } elseif {$lower_resolve == -3} {
##x
set lower 0 set lower 0
} else { } else {
set lower $lower_resolve set lower $lower_resolve
} }
set upper [punk::lib::lindex_resolve $dval $b] set upper [punk::lib::lindex_resolve $dval $b]
if {$upper == -2} { if {$upper == -3} {
##x
#upper bound is below list range - #upper bound is below list range -
if {$lower_resolve >=-1} { if {$lower_resolve >=-2} {
##x
set upper 0 set upper 0
} else { } else {
continue continue
} }
} elseif {$upper == -1} { } elseif {$upper == -2} {
#use max #use max
set upper [expr {[llength $dval]-1}] set upper [expr {[llength $dval]-1}]
#assert - upper >=0 because we have ruled out empty lists #assert - upper >=0 because we have ruled out empty lists
@ -1670,6 +1761,7 @@ namespace eval punk::lib {
} }
} }
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side
proc lindex_resolve {list index} { proc lindex_resolve {list index} {
#*** !doctools #*** !doctools
#[call [fun lindex_resolve] [arg list] [arg index]] #[call [fun lindex_resolve] [arg list] [arg index]]
@ -1679,11 +1771,13 @@ namespace eval punk::lib {
#[para]Sometimes the actual integer index is desired. #[para]Sometimes the actual integer index is desired.
#[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks.
#[para]lindex_resolve will parse the index expression and return: #[para]lindex_resolve will parse the index expression and return:
#[para] a) -2 if the supplied index expression is below the lower bound for the supplied list. (< 0) #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
#[para] b) -1 if the supplied index expression is above the upper bound for the supplied list. (> end) #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end)
#[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list
#[para]Otherwise it will return an integer corresponding to the position in the list. #[para]Otherwise it will return an integer corresponding to the position in the list.
#[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway. #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway.
#[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable
#[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2
#Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr
#if {![llength $list]} { #if {![llength $list]} {
@ -1694,9 +1788,9 @@ namespace eval punk::lib {
if {[string is integer -strict $index]} { if {[string is integer -strict $index]} {
#can match +i -i #can match +i -i
if {$index < 0} { if {$index < 0} {
return -2 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= [llength $list]} {
return -1 return -2
} else { } else {
#integer may still have + sign - normalize with expr #integer may still have + sign - normalize with expr
return [expr {$index}] return [expr {$index}]
@ -1708,14 +1802,14 @@ namespace eval punk::lib {
set offset [string range $index 4 end] set offset [string range $index 4 end]
if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"}
if {$op eq "+" && $offset != 0} { if {$op eq "+" && $offset != 0} {
return -1 return -2
} }
} else { } else {
#end #index is 'end'
set index [expr {[llength $list]-1}] set index [expr {[llength $list]-1}]
if {$index < 0} { if {$index < 0} {
#special case - end with empty list - treat end like a positive number out of bounds #special case - 'end' with empty list - treat end like a positive number out of bounds
return -1 return -2
} else { } else {
return $index return $index
} }
@ -1723,7 +1817,7 @@ namespace eval punk::lib {
if {$offset == 0} { if {$offset == 0} {
set index [expr {[llength $list]-1}] set index [expr {[llength $list]-1}]
if {$index < 0} { if {$index < 0} {
return -1 ;#special case return -2 ;#special case as above
} else { } else {
return $index return $index
} }
@ -1732,7 +1826,7 @@ namespace eval punk::lib {
set index [expr {([llength $list]-1) - $offset}] set index [expr {([llength $list]-1) - $offset}]
} }
if {$index < 0} { if {$index < 0} {
return -2 return -3
} else { } else {
return $index return $index
} }
@ -1753,26 +1847,50 @@ namespace eval punk::lib {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
} }
if {$index < 0} { if {$index < 0} {
return -2 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= [llength $list]} {
return -1 return -2
} }
return $index return $index
} }
} }
} }
proc lindex_resolve2 {list index} { proc lindex_resolve_basic {list index} {
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. #*** !doctools
#[call [fun lindex_resolve_basic] [arg list] [arg index]]
#[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2)
#[para] returns -1 for out of range at either end, or a valid integer index
#[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound
#[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command
#[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1
#[para] For pure integer indices the performance should be equivalent
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+
# - which
#for {set i 0} {$i < [llength $list]} {incr i} { #for {set i 0} {$i < [llength $list]} {incr i} {
# lappend indices $i # lappend indices $i
#} #}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
#avoid even the lseq overhead when the index is simple
if {$index < 0 || ($index >= [llength $list])} {
#even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method.
return -1
} else {
#integer may still have + sign - normalize with expr
return [expr {$index}]
}
}
if {[llength $list]} { if {[llength $list]} {
set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback.
#if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?)
} else { } else {
set indices [list] set indices [list]
} }
set idx [lindex $indices $index] set idx [lindex $indices $index]
if {$idx eq ""} { if {$idx eq ""} {
#we have no way to determine if out of bounds is at lower vs upper end
return -1 return -1
} else { } else {
return $idx return $idx
@ -2334,13 +2452,6 @@ namespace eval punk::lib {
} }
return $prefix return $prefix
} }
#test example of the technique - not necessarily particularly useful as a function, except maybe for brevity/clarity. todo - test if inlined version gives any perf advantage compared to a temp var
proc swapnumvars {namea nameb} {
upvar $namea a $nameb b
set a [expr {$a ^ $b}]
set b [expr {$a ^ $b}]
set a [expr {$a ^ $b}]
}
#e.g linesort -decreasing $data #e.g linesort -decreasing $data
proc linesort {args} { proc linesort {args} {
@ -2956,7 +3067,7 @@ namespace eval punk::lib {
# and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]*
proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} {
set number [punk::objclone $unformattednumber] set number [objclone $unformattednumber]
set number [string map {_ ""} $number] set number [string map {_ ""} $number]
#normalize using expr - e.g 2e4 -> 20000.0 #normalize using expr - e.g 2e4 -> 20000.0
set number [expr {$number}] set number [expr {$number}]

35
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/base-0.1.tm

@ -4,6 +4,7 @@ package provide punk::mix::base [namespace eval punk::mix::base {
}] }]
package require punk::path package require punk::path
package require punk::lib ;#format_number etc
#base internal plumbing functions #base internal plumbing functions
namespace eval punk::mix::base { namespace eval punk::mix::base {
@ -657,16 +658,38 @@ namespace eval punk::mix::base {
#temp emission to stdout.. todo - repl telemetry channel #temp emission to stdout.. todo - repl telemetry channel
puts stdout "cksum_path: creating temporary tar archive for $path" puts stdout "cksum_path: creating temporary tar archive for $path"
puts stdout " at: $archivename .." puts -nonewline stdout " at: $archivename ..."
tar::create $archivename $target set tsstart [clock millis]
if {[set tarpath [auto_execok tar]] ne ""} {
#using an external binary is *significantly* faster than tar::create - but comes with some risks
#review - need to check behaviour/flag variances across platforms
#don't use -z flag. On at least some tar versions the zipped file will contain a timestamped subfolder of filename.tar - which ruins the checksum
#also - tar is generally faster without the compression (although this may vary depending on file size and disk speed?)
exec {*}$tarpath -cf $archivename $target ;#{*} needed in case spaces in tarpath
set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " tar -cf done ($ms ms)"
} else {
set tsstart [clock millis] ;#don't include auto_exec search time for tar::create
tar::create $archivename $target
set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " tar::create done ($ms ms)"
puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing"
}
if {$ftype eq "file"} { if {$ftype eq "file"} {
set sizeinfo "(size [file size $target])" set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)"
} else { } else {
set sizeinfo "(file type $ftype - size unknown)" set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)"
} }
puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." set tsstart [clock millis]
puts -nonewline stdout "cksum_path: calculating cksum for $target $sizeinfo ... "
set cksum [{*}$cksum_command $archivename] set cksum [{*}$cksum_command $archivename]
#puts stdout "cksum_path: cleaning up.. " set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " cksum done ($ms ms)"
puts stdout " cksum: $cksum"
file delete -force $archivename file delete -force $archivename
cd $startdir cd $startdir

6
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm

@ -157,6 +157,9 @@ namespace eval punk::mix::commandset::project {
set opt_force [dict get $opts -force] set opt_force [dict get $opts -force]
set opt_confirm [string tolower [dict get $opts -confirm]] set opt_confirm [string tolower [dict get $opts -confirm]]
# -- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_layout [dict get $opts -layout]
set opt_update [dict get $opts -update]
# -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_modules [dict get $opts -modules] set opt_modules [dict get $opts -modules]
if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} {
#if not specified - add a single module matching project name #if not specified - add a single module matching project name
@ -169,9 +172,6 @@ namespace eval punk::mix::commandset::project {
} }
} }
# -- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- ---
set opt_layout [dict get $opts -layout]
set opt_update [dict get $opts -update]
# -- --- --- --- --- --- --- --- --- --- --- --- ---
#todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache #todo - install support binaries on a per-project basis in a way that doesn't impact machine (e.g not added to path) - cache in user config dir if possible, supply mechanism to clear cache

68
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm

@ -1707,6 +1707,7 @@ tcl::namespace::eval punk::ns {
lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs
set use_vars [expr {"-vars" in $runopts}] set use_vars [expr {"-vars" in $runopts}]
set no_warnings [expr {"-nowarnings" in $runopts}] set no_warnings [expr {"-nowarnings" in $runopts}]
set ver ""
#todo support leading solo flags such as -capture to control whether we do a static capture of local vars in the ns #todo support leading solo flags such as -capture to control whether we do a static capture of local vars in the ns
@ -1717,15 +1718,68 @@ tcl::namespace::eval punk::ns {
} }
default { default {
if {[string match ::* $pkg_or_existing_ns]} { if {[string match ::* $pkg_or_existing_ns]} {
set pkg_unqualified [string range $pkg_or_existing_ns 2 end]
if {![tcl::namespace::exists $pkg_or_existing_ns]} { if {![tcl::namespace::exists $pkg_or_existing_ns]} {
set ver [package require [string range $pkg_or_existing_ns 2 end]] set ver [package require $pkg_unqualified]
} else { } else {
set ver "" set ver ""
} }
set ns $pkg_or_existing_ns set ns $pkg_or_existing_ns
} else { } else {
set ver [package require $pkg_or_existing_ns] set pkg_unqualified $pkg_or_existing_ns
set ns ::$pkg_or_existing_ns set ver [package require $pkg_unqualified]
set ns ::$pkg_unqualified
}
#some packages don't create their namespace immediately and/or don't populate it with commands and instead put entries in ::auto_index
set previous_command_count 0
if {[namespace exists $ns]} {
set previous_command_count [llength [info commands ${ns}::*]]
}
#also if a sub package was loaded first - then the namespace for the base or lower package may exist but have no commands
#for the purposes of pkguse - which most commonly interactive - we want the namespace populated
#It may still not be *fully* populated because we stop at first source that adds commands - REVIEW
set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}]
if {!$ns_populated} {
#we will catch-run an auto_index entry if any
#auto_index entry may or may not be prefixed with ::
set keys [list]
#first look for exact pkg_unqualified and ::pkg_unqualified
#leave these at beginning of keys list
if {[array exists ::auto_index($pkg_unqualified)]} {
lappend keys $pkg_unqualified
}
if {[array exists ::auto_index(::$pkg_unqualified)]} {
lappend keys ::$pkg_unqualified
}
#as auto_index is an array - we could get keys in arbitrary order
set matches [lsort [array names ::auto_index ${pkg_unqualified}::*]]
lappend keys {*}$matches
set matches [lsort [array names ::auto_index ::${pkg_unqualified}::*]]
lappend keys {*}$matches
set ns_populated 0
set i 0
set already_sourced [list] ;#often multiple triggers for the same source - don't waste time re-sourcing
set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]]
while {!$ns_populated && $i < [llength $keys]} {
#todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base
#e.g if we are loading ::x::y
#only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc
set k [lindex $keys $i]
set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]]
if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} {
set auto_source [set ::auto_index($k)]
if {$auto_source ni $already_sourced} {
uplevel 1 $auto_source
lappend already_sourced $auto_source
set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}]
}
}
incr i
}
} }
} }
} }
@ -1799,7 +1853,13 @@ tcl::namespace::eval punk::ns {
return $out return $out
} }
} else { } else {
error "Namespace $ns not found." if {$ver eq ""} {
error "Namespace $ns not found. No package version found."
} else {
set out "(no package namespace found) remaining in [uplevel 1 {namespace current}]"
append out \n $ver
return $out
}
} }
return $out return $out
} }

2
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/repo-0.1.1.tm

@ -468,7 +468,7 @@ namespace eval punk::repo {
set path [string trim [string range $ln [string length "MISSING "] end]] set path [string trim [string range $ln [string length "MISSING "] end]]
dict set pathdict $path "missing" dict set pathdict $path "missing"
} }
"EXTRA * " { "EXTRA *" {
#fossil will explicitly list files in a new folder - as opposed to git which shows just the folder #fossil will explicitly list files in a new folder - as opposed to git which shows just the folder
set path [string trim [string range $ln [string length "EXTRA "] end]] set path [string trim [string range $ln [string length "EXTRA "] end]]
dict set pathdict $path "extra" dict set pathdict $path "extra"

BIN
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/test/tomlish-1.1.1.tm

Binary file not shown.

3658
src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/tomlish-1.1.1.tm

File diff suppressed because it is too large Load Diff

214
src/project_layouts/custom/_project/punk.shell-0.1/src/make.tcl

@ -13,7 +13,7 @@ namespace eval ::punkmake {
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k] variable non_help_flags [list -k]
variable help_flags [list -help --help /?] variable help_flags [list -help --help /?]
variable known_commands [list project get-project-info shell vendorupdate bootsupport vfscommonupdate] variable known_commands [list project modules info check shell vendorupdate bootsupport vfscommonupdate]
} }
if {"::try" ni [info commands ::try]} { if {"::try" ni [info commands ::try]} {
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting"
@ -21,7 +21,7 @@ if {"::try" ni [info commands ::try]} {
} }
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
#Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder #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 the there is a folder under the current directory /src/bootsupport/modules which contains .tm files
# - then it will attempt to preference these modules # - then it will attempt to preference these modules
@ -35,8 +35,10 @@ if {[file exists [file join $startdir src bootsupport]]} {
set bootsupport_mod [file join $startdir bootsupport modules] set bootsupport_mod [file join $startdir bootsupport modules]
set bootsupport_lib [file join $startdir bootsupport lib] set bootsupport_lib [file join $startdir bootsupport lib]
} }
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
set package_paths_modified 0
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
set original_tm_list [tcl::tm::list] set original_tm_list [tcl::tm::list]
tcl::tm::remove {*}$original_tm_list tcl::tm::remove {*}$original_tm_list
set original_auto_path $::auto_path set original_auto_path $::auto_path
@ -63,8 +65,18 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
} }
if {[file exists [pwd]/modules]} { #we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir.
tcl::tm::add [pwd]/modules #The <projectdir>/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 <projectdir/src is also likely to be common
# but we need to be loud about what's going on.
puts stderr "------------------------------------------------------------------"
puts stderr "Launched from within a folder ending in 'src'"
puts stderr " - modules in $startdir/modules may override bootsupport modules"
puts stderr "------------------------------------------------------------------"
tcl::tm::add $startdir/modules
}
} }
#package require Thread #package require Thread
@ -81,16 +93,8 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
package require punkcheck package require punkcheck
package require punk::lib package require punk::lib
set package_paths_modified 1
#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]
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
} }
@ -106,6 +110,8 @@ try {
} }
package require punk::mix package require punk::mix
package require punk::repo package require punk::repo
package require punk::ansi
package require overtype
} finally { } finally {
catch {rename ::package ""} catch {rename ::package ""}
catch {rename ::punkmake::package_temp_aside ::package} catch {rename ::punkmake::package_temp_aside ::package}
@ -129,18 +135,24 @@ proc punkmake_gethelp {args} {
append h "Usage:" \n append h "Usage:" \n
append h "" \n append h "" \n
append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n
append h " - This help." \n \n append h " - This help." \n \n
append h " $scriptname project ?-k?" \n append h " $scriptname project ?-k?" \n
append h " - this is the literal word project - and confirms you want to run the project build" \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 \n append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n
append h " - built modules go into <projectdir>/modules <projectdir>/lib etc." \n \n
append h " $scriptname modules" \n
append h " - build modules from src/modules etc without scanning src/runtime and src/vfs folders to build kit/zipkit executables" \n \n
append h " $scriptname bootsupport" \n append h " $scriptname bootsupport" \n
append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n \n append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n
append h " - bootsupport modules are available to make.tcl" \n \n
append h " $scriptname vendorupdate" \n append h " $scriptname vendorupdate" \n
append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n
append h " $scriptname vfscommonupdate" \n append h " $scriptname vfscommonupdate" \n
append h " - update the src/vfs/_vfscommon from compiled src/modules and src/lib" \n \n append h " - update the src/vfs/_vfscommon from compiled src/modules and src/lib etc" \n
append h " $scriptname get-project-info" \n append h " - before calling this (followed by make project) - you can test using '<builtexe>(.exe) dev'" \n
append h " - show the name and base folder of the project to be built" \n append h " this will load modules from your <projectdir>/module <projectdir>/lib paths instead of from the kit/zipkit" \n \n
append h " $scriptname info" \n
append h " - show the name and base folder of the project to be built" \n
append h "" \n append h "" \n
if {[llength $::punkmake::pkg_missing]} { if {[llength $::punkmake::pkg_missing]} {
append h "* ** NOTE ** ***" \n append h "* ** NOTE ** ***" \n
@ -220,12 +232,68 @@ if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]}
} }
set sourcefolder $projectroot/src set sourcefolder $projectroot/src
if {$::punkmake::command eq "check"} {
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 v [package require punk::mix::base]
puts stdout "punk::mix::base version $v\n[package ifneeded punk::mix::base $v]"
exit 0
}
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]
}
if {$::punkmake::command eq "get-project-info"} { if {$::punkmake::command eq "info"} {
puts stdout "- -- --- --- --- --- --- --- --- --- ---" puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
puts stdout "- -- get-project-info -- -" puts stdout "- -- info -- -"
puts stdout "- -- --- --- --- --- --- --- --- --- ---" puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
puts stdout "- projectroot : $projectroot" puts stdout "- projectroot : $projectroot"
set sourcefolder $projectroot/src
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*]
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*]
puts stdout "- vendorlib folders: ([llength $vendorlibfolders])"
foreach fld $vendorlibfolders {
puts stdout " src/$fld"
}
puts stdout "- vendormodule folders: ([llength $vendormodulefolders])"
foreach fld $vendormodulefolders {
puts stdout " src/$fld"
}
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot]
puts stdout "- source module paths: [llength $source_module_folderlist]"
foreach fld $source_module_folderlist {
puts stdout " $fld"
}
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*]
lappend projectlibfolders lib
puts stdout "- source libary paths: [llength $projectlibfolders]"
foreach fld $projectlibfolders {
puts stdout " src/$fld"
}
if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} {
set vc "fossil" set vc "fossil"
set rev [punk::repo::fossil_revision $scriptfolder] set rev [punk::repo::fossil_revision $scriptfolder]
@ -241,8 +309,11 @@ if {$::punkmake::command eq "get-project-info"} {
} }
puts stdout "- version control : $vc" puts stdout "- version control : $vc"
puts stdout "- revision : $rev" puts stdout "- revision : $rev"
puts stdout "- remote : $rem" puts stdout "- remote"
puts stdout "- -- --- --- --- --- --- --- --- --- ---" foreach ln [split $rem \n] {
puts stdout " $ln"
}
puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
exit 0 exit 0
} }
@ -564,7 +635,7 @@ if {$::punkmake::command eq "bootsupport"} {
if {$::punkmake::command ne "project"} { if {$::punkmake::command ni {project modules}} {
puts stderr "Command $::punkmake::command not implemented - aborting." puts stderr "Command $::punkmake::command not implemented - aborting."
flush stderr flush stderr
after 100 after 100
@ -803,6 +874,19 @@ if {[punk::repo::is_fossil_root $projectroot]} {
$installer destroy $installer destroy
} }
if {$::punkmake::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"
puts stdout " - use 'make.tcl project' to build executable kits/zipkits from vfs folders as well if you have runtimes installed"
puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but"
puts stdout " without the latest built modules."
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'"
puts stdout "-done-"
exit 0
}
set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder]
if {$buildfolder ne "$sourcefolder/_build"} { if {$buildfolder ne "$sourcefolder/_build"} {
puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure" puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure"
@ -832,10 +916,12 @@ if {![llength $runtimes]} {
exit 0 exit 0
} }
set has_sdx 1
if {[catch {exec sdx help} errM]} { if {[catch {exec sdx help} errM]} {
puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" puts stderr "FAILED to find usable sdx command - check that sdx executable is on path"
puts stderr "err: $errM" puts stderr "err: $errM"
exit 1 #exit 1
set has_sdx 0
} }
# -- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- ---
@ -1025,6 +1111,8 @@ foreach runtimefile $runtimes {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set failed_kits [list] set failed_kits [list]
set installed_kits [list] set installed_kits [list]
set skipped_kits [list]
set skipped_kit_installs [list]
proc ::make_file_traversal_error {args} { proc ::make_file_traversal_error {args} {
error "file_traverse error: $args" error "file_traverse error: $args"
@ -1304,30 +1392,39 @@ foreach vfstail $vfs_tails {
} }
} }
kit { kit {
if {[catch { if {!$has_sdx} {
if {$rtname ne "-"} { puts stderr "no sdx available to wrap $targetkit"
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"]
} else {
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose
}
} result]} {
if {$rtname ne "-"} {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result"
} else {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose failed with msg: $result"
}
puts stderr "sdx wrap $targetkit failed"
lappend failed_kits [list kit $targetkit reason $sdxmsg]
$vfs_event targetset_end FAILED $vfs_event targetset_end FAILED
$vfs_event destroy $vfs_event destroy
$vfs_installer destroy $vfs_installer destroy
continue continue
} else { } else {
puts stdout "ok - finished sdx" if {[catch {
set separator [string repeat = 40] if {$rtname ne "-"} {
puts stdout $separator exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose
puts stdout $result } else {
puts stdout $separator exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose
}
} result]} {
if {$rtname ne "-"} {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result"
} else {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose failed with msg: $result"
}
puts stderr "sdx wrap $targetkit failed"
lappend failed_kits [list kit $targetkit reason $sdxmsg]
$vfs_event targetset_end FAILED
$vfs_event destroy
$vfs_installer destroy
continue
} else {
puts stdout "ok - finished sdx"
set separator [string repeat = 40]
puts stdout $separator
puts stdout $result
puts stdout $separator
}
} }
} }
} }
@ -1435,6 +1532,7 @@ foreach vfstail $vfs_tails {
set skipped_vfs_build 1 set skipped_vfs_build 1
puts stderr "." puts stderr "."
puts stdout "Skipping build for vfs $vfstail with runtime $rtname - no change detected" puts stdout "Skipping build for vfs $vfstail with runtime $rtname - no change detected"
lappend skipped_kits [list kit $targetkit reason "no change detected"]
$vfs_event targetset_end SKIPPED $vfs_event targetset_end SKIPPED
} }
$vfs_event destroy $vfs_event destroy
@ -1489,6 +1587,7 @@ foreach vfstail $vfs_tails {
set skipped_kit_install 1 set skipped_kit_install 1
puts stderr "." puts stderr "."
puts stdout "Skipping kit install for $targetkit with vfs $vfstail runtime $rtname - no change detected" puts stdout "Skipping kit install for $targetkit with vfs $vfstail runtime $rtname - no change detected"
lappend skipped_kit_installs [list kit $targetkit reason "no change detected"]
$bin_event targetset_end SKIPPED $bin_event targetset_end SKIPPED
} }
$bin_event destroy $bin_event destroy
@ -1510,8 +1609,21 @@ if {[llength $failed_kits]} {
punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@* punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@*
#puts stderr [join $failed_kits \n] #puts stderr [join $failed_kits \n]
} }
set had_kits [expr {[llength $installed_kits] || [llength $failed_kits] || [llength $skipped_kits]}]
puts stdout "done" if {$had_kits} {
puts stdout " module builds and kit/zipkit builds processed (vfs config: src/runtime/mapvfs.config)"
puts stdout " - use 'make.tcl modules' to build modules without scanning/building the vfs folders into executable kits/zipkits"
puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into the base vfs folder"
puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but"
puts stdout " without the latest built modules."
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'"
} else {
puts stdout " module builds processed"
puts stdout ""
puts stdout " If kit/zipkit based executables required - create src/vfs/<somename>.vfs folders containing lib,modules,modules_tcl9 etc folders"
puts stdout " Also ensure appropriate executables exist in src/runtime along with src/runtime/mapvfs.config"
}
puts stdout "-done-"
exit 0 exit 0

646
src/project_layouts/vendor/punk/project-0.1/src/make.tcl vendored

@ -13,7 +13,7 @@ namespace eval ::punkmake {
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list]
variable non_help_flags [list -k] variable non_help_flags [list -k]
variable help_flags [list -help --help /?] variable help_flags [list -help --help /?]
variable known_commands [list project get-project-info shell vendorupdate bootsupport] variable known_commands [list project modules info check shell vendorupdate bootsupport vfscommonupdate]
} }
if {"::try" ni [info commands ::try]} { if {"::try" ni [info commands ::try]} {
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting"
@ -21,7 +21,7 @@ if {"::try" ni [info commands ::try]} {
} }
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
#Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder #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 the there is a folder under the current directory /src/bootsupport/modules which contains .tm files
# - then it will attempt to preference these modules # - then it will attempt to preference these modules
@ -35,8 +35,10 @@ if {[file exists [file join $startdir src bootsupport]]} {
set bootsupport_mod [file join $startdir bootsupport modules] set bootsupport_mod [file join $startdir bootsupport modules]
set bootsupport_lib [file join $startdir bootsupport lib] set bootsupport_lib [file join $startdir bootsupport lib]
} }
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
set package_paths_modified 0
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
set original_tm_list [tcl::tm::list] set original_tm_list [tcl::tm::list]
tcl::tm::remove {*}$original_tm_list tcl::tm::remove {*}$original_tm_list
set original_auto_path $::auto_path set original_auto_path $::auto_path
@ -63,8 +65,18 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
} }
if {[file exists [pwd]/modules]} { #we deliberately don't use [pwd]/modules because commonly the launch dir may be the project dir.
tcl::tm::add [pwd]/modules #The <projectdir>/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 <projectdir/src is also likely to be common
# but we need to be loud about what's going on.
puts stderr "------------------------------------------------------------------"
puts stderr "Launched from within a folder ending in 'src'"
puts stderr " - modules in $startdir/modules may override bootsupport modules"
puts stderr "------------------------------------------------------------------"
tcl::tm::add $startdir/modules
}
} }
#package require Thread #package require Thread
@ -74,22 +86,15 @@ if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} {
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list # tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list
#These are strong dependencies #These are strong dependencies
package forget punk::mix package forget punk::mix
package require punk::mix
package forget punk::repo package forget punk::repo
package require punk::repo
package forget punkcheck package forget punkcheck
package require punk::mix
package require punk::repo
package require punkcheck package require punkcheck
package require punk::lib
set package_paths_modified 1
#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]
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
} }
@ -105,6 +110,8 @@ try {
} }
package require punk::mix package require punk::mix
package require punk::repo package require punk::repo
package require punk::ansi
package require overtype
} finally { } finally {
catch {rename ::package ""} catch {rename ::package ""}
catch {rename ::punkmake::package_temp_aside ::package} catch {rename ::punkmake::package_temp_aside ::package}
@ -128,16 +135,24 @@ proc punkmake_gethelp {args} {
append h "Usage:" \n append h "Usage:" \n
append h "" \n append h "" \n
append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n
append h " - This help." \n \n append h " - This help." \n \n
append h " $scriptname project ?-k?" \n append h " $scriptname project ?-k?" \n
append h " - this is the literal word project - and confirms you want to run the project build" \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 \n append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n
append h " - built modules go into <projectdir>/modules <projectdir>/lib etc." \n \n
append h " $scriptname modules" \n
append h " - build modules from src/modules etc without scanning src/runtime and src/vfs folders to build kit/zipkit executables" \n \n
append h " $scriptname bootsupport" \n append h " $scriptname bootsupport" \n
append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n \n append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n
append h " - bootsupport modules are available to make.tcl" \n \n
append h " $scriptname vendorupdate" \n append h " $scriptname vendorupdate" \n
append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n
append h " $scriptname get-project-info" \n append h " $scriptname vfscommonupdate" \n
append h " - show the name and base folder of the project to be built" \n append h " - update the src/vfs/_vfscommon from compiled src/modules and src/lib etc" \n
append h " - before calling this (followed by make project) - you can test using '<builtexe>(.exe) dev'" \n
append h " this will load modules from your <projectdir>/module <projectdir>/lib paths instead of from the kit/zipkit" \n \n
append h " $scriptname info" \n
append h " - show the name and base folder of the project to be built" \n
append h "" \n append h "" \n
if {[llength $::punkmake::pkg_missing]} { if {[llength $::punkmake::pkg_missing]} {
append h "* ** NOTE ** ***" \n append h "* ** NOTE ** ***" \n
@ -217,12 +232,68 @@ if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]}
} }
set sourcefolder $projectroot/src set sourcefolder $projectroot/src
if {$::punkmake::command eq "check"} {
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 v [package require punk::mix::base]
puts stdout "punk::mix::base version $v\n[package ifneeded punk::mix::base $v]"
exit 0
}
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]
}
if {$::punkmake::command eq "get-project-info"} {
puts stdout "- -- --- --- --- --- --- --- --- --- ---" if {$::punkmake::command eq "info"} {
puts stdout "- -- get-project-info -- -" puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
puts stdout "- -- --- --- --- --- --- --- --- --- ---" puts stdout "- -- info -- -"
puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
puts stdout "- projectroot : $projectroot" puts stdout "- projectroot : $projectroot"
set sourcefolder $projectroot/src
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*]
set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*]
puts stdout "- vendorlib folders: ([llength $vendorlibfolders])"
foreach fld $vendorlibfolders {
puts stdout " src/$fld"
}
puts stdout "- vendormodule folders: ([llength $vendormodulefolders])"
foreach fld $vendormodulefolders {
puts stdout " src/$fld"
}
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot]
puts stdout "- source module paths: [llength $source_module_folderlist]"
foreach fld $source_module_folderlist {
puts stdout " $fld"
}
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*]
lappend projectlibfolders lib
puts stdout "- source libary paths: [llength $projectlibfolders]"
foreach fld $projectlibfolders {
puts stdout " src/$fld"
}
if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} {
set vc "fossil" set vc "fossil"
set rev [punk::repo::fossil_revision $scriptfolder] set rev [punk::repo::fossil_revision $scriptfolder]
@ -238,8 +309,11 @@ if {$::punkmake::command eq "get-project-info"} {
} }
puts stdout "- version control : $vc" puts stdout "- version control : $vc"
puts stdout "- revision : $rev" puts stdout "- revision : $rev"
puts stdout "- remote : $rem" puts stdout "- remote"
puts stdout "- -- --- --- --- --- --- --- --- --- ---" foreach ln [split $rem \n] {
puts stdout " $ln"
}
puts stdout "- -- --- --- --- --- --- --- --- --- -- -"
exit 0 exit 0
} }
@ -253,6 +327,41 @@ if {$::punkmake::command eq "shell"} {
exit 1 exit 1
} }
if {$::punkmake::command eq "vfscommonupdate"} {
puts "projectroot: $projectroot"
puts "script: [info script]"
puts stdout "Updating vfs/_vfscommon"
puts stdout "REPLACE src/vfs/_vfscommon/* with project's modules and libs?? y|n"
if {[gets stdin] eq "y"} {
puts proceeding...
proc vfscommonupdate {projectroot} {
file delete -force $projectroot/src/vfs/_vfscommon/modules
file copy $projectroot/modules $projectroot/src/vfs/_vfscommon/
#temp? (avoid zipfs mkimg windows dotfile bug)
file delete $projectroot/src/vfs/_vfscommon/modules/.punkcheck
file delete -force $projectroot/src/vfs/_vfscommon/lib
file copy $projectroot/lib $projectroot/src/vfs/_vfscommon/
#temp?
file delete $projectroot/src/vfs/_vfscommon/lib/.punkcheck
}
vfscommonupdate $projectroot
} else {
puts aborting...
}
puts stdout "\nvfscommonupdate done "
flush stderr
flush stdout
::exit 0
}
if {$::punkmake::command eq "vendorupdate"} { if {$::punkmake::command eq "vendorupdate"} {
puts "projectroot: $projectroot" puts "projectroot: $projectroot"
puts "script: [info script]" puts "script: [info script]"
@ -295,18 +404,22 @@ if {$::punkmake::command eq "vendorupdate"} {
puts stderr "Unable to use punkcheck for vendormodules$which update. Error: $errM" puts stderr "Unable to use punkcheck for vendormodules$which update. Error: $errM"
set installation_event "" set installation_event ""
} }
foreach {relpath module} $local_modules { foreach {relpath requested_module} $local_modules {
set module [string trim $module :] set requested_module [string trim $requested_module :]
set module_subpath [string map {:: /} [namespace qualifiers $module]] set module_subpath [string map {:: /} [namespace qualifiers $requested_module]]
set srclocation [file join $projectroot $relpath $module_subpath] set srclocation [file join $projectroot $relpath $module_subpath]
#puts stdout "$relpath $module $module_subpath $srclocation" #puts stdout "$relpath $module $module_subpath $srclocation"
set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*]
#todo - check if requested_module has version extension and allow explicit versions instead of just latest
#allow modulename-* literal in .config to request all versions
set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $requested_module]-*]
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1
if {![llength $pkgmatches]} { if {![llength $pkgmatches]} {
puts stderr "Missing local source for vendor module $module - not found in $srclocation" puts stderr "Missing local source for requested vendor module $requested_module - not found in $srclocation"
continue continue
} }
set latestfile [lindex $pkgmatches 0] set latestfile [lindex $pkgmatches 0] ;#default
set latestver [lindex [split [file rootname $latestfile] -] 1] set latestver [lindex [split [file rootname $latestfile] -] 1]
foreach m $pkgmatches { foreach m $pkgmatches {
lassign [split [file rootname $m] -] _pkg ver lassign [split [file rootname $m] -] _pkg ver
@ -316,6 +429,7 @@ if {$::punkmake::command eq "vendorupdate"} {
set latestfile $m set latestfile $m
} }
} }
set srcfile [file join $srclocation $latestfile] set srcfile [file join $srclocation $latestfile]
set tgtfile [file join $targetroot $module_subpath $latestfile] set tgtfile [file join $targetroot $module_subpath $latestfile]
if {$installation_event ne ""} { if {$installation_event ne ""} {
@ -521,7 +635,7 @@ if {$::punkmake::command eq "bootsupport"} {
if {$::punkmake::command ne "project"} { if {$::punkmake::command ni {project modules}} {
puts stderr "Command $::punkmake::command not implemented - aborting." puts stderr "Command $::punkmake::command not implemented - aborting."
flush stderr flush stderr
after 100 after 100
@ -536,7 +650,6 @@ if {$::punkmake::command ne "project"} {
set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*]
lappend vendorlibfolders vendorlib lappend vendorlibfolders vendorlib
foreach lf $vendorlibfolders { foreach lf $vendorlibfolders {
if {[file exists $sourcefolder/$lf]} { if {[file exists $sourcefolder/$lf]} {
lassign [split $lf _] _vm tclx lassign [split $lf _] _vm tclx
@ -547,7 +660,6 @@ foreach lf $vendorlibfolders {
} }
set target_lib_folder $projectroot/lib$which set target_lib_folder $projectroot/lib$which
file mkdir $projectroot/lib$which file mkdir $projectroot/lib$which
#exclude README.md from source folder - but only the root one #exclude README.md from source folder - but only the root one
#-antiglob_paths takes relative patterns e.g #-antiglob_paths takes relative patterns e.g
# */test.txt will only match test.txt exactly one level deep. # */test.txt will only match test.txt exactly one level deep.
@ -556,7 +668,6 @@ foreach lf $vendorlibfolders {
set antipaths [list\ set antipaths [list\
README.md\ README.md\
] ]
puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths]
puts stdout [punkcheck::summarize_install_resultdict $resultdict] puts stdout [punkcheck::summarize_install_resultdict $resultdict]
@ -658,6 +769,34 @@ foreach layoutbase $layout_bases {
} }
} }
######################################################## ########################################################
set projectlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails lib_tcl*]
lappend projectlibfolders lib
foreach lf $projectlibfolders {
if {[file exists $sourcefolder/$lf]} {
lassign [split $lf _] _vm tclx
if {$tclx ne ""} {
set which _$tclx
} else {
set which ""
}
set target_lib_folder $projectroot/lib$which
file mkdir $projectroot/lib$which
#exclude README.md from source folder - but only the root one
#-antiglob_paths takes relative patterns e.g
# */test.txt will only match test.txt exactly one level deep.
# */*/*.foo will match any path ending in .foo that is exactly 2 levels deep.
# **/test.txt will match at any level below the root (but not in the root)
set antipaths [list\
README.md\
]
puts stdout "PROJECTLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)"
set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths]
puts stdout [punkcheck::summarize_install_resultdict $resultdict]
}
}
if {![llength $projectlibfolders]} {
puts stderr "PROJECTLIB: No src/lib or src/lib_tcl* folder found."
}
#consolidated /modules /modules_tclX folder used for target where X is tcl major version #consolidated /modules /modules_tclX folder used for target where X is tcl major version
#the make process will process for any _tclX not just the major version of the current interpreter #the make process will process for any _tclX not just the major version of the current interpreter
@ -735,6 +874,19 @@ if {[punk::repo::is_fossil_root $projectroot]} {
$installer destroy $installer destroy
} }
if {$::punkmake::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"
puts stdout " - use 'make.tcl project' to build executable kits/zipkits from vfs folders as well if you have runtimes installed"
puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but"
puts stdout " without the latest built modules."
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'"
puts stdout "-done-"
exit 0
}
set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder]
if {$buildfolder ne "$sourcefolder/_build"} { if {$buildfolder ne "$sourcefolder/_build"} {
puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure" puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure"
@ -764,10 +916,12 @@ if {![llength $runtimes]} {
exit 0 exit 0
} }
set has_sdx 1
if {[catch {exec sdx help} errM]} { if {[catch {exec sdx help} errM]} {
puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" puts stderr "FAILED to find usable sdx command - check that sdx executable is on path"
puts stderr "err: $errM" puts stderr "err: $errM"
exit 1 #exit 1
set has_sdx 0
} }
# -- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- ---
@ -806,31 +960,26 @@ if {[file exists $mapfile]} {
lappend missing $runtime lappend missing $runtime
} }
} }
foreach vfspair $vfs_specs { foreach vfsconfig $vfs_specs {
switch -- [llength $vfspair] { switch -- [llength $vfsconfig] {
1 { 1 - 2 - 3 {
set vfs [lindex $vfspair 0] lassign $vfsconfig vfstail appname kit_type
if {![file isdirectory [file join $sourcefolder $vfs]]} { if {![file isdirectory [file join $sourcefolder vfs $vfstail]]} {
puts stderr "WARNING: Missing vfs folder [file join $sourcefolder $vfs] specified in mapvfs.config for runtime $runtime" puts stderr "WARNING: Missing vfs folder [file join $sourcefolder vfs $vfstail] specified in mapvfs.config for runtime $runtime"
lappend missing $vfs lappend missing $vfstail
} else {
set appname [file rootname $vfs]
dict lappend vfs_runtime_map $vfs [list $runtime $appname]
}
}
2 {
lassign $vfspair vfs appname
if {![file isdirectory [file join $sourcefolder $vfs]]} {
puts stderr "WARNING: Missing vfs folder [file join $sourcefolder $vfs] specified in mapvfs.config for runtime $runtime"
lappend missing $vfs
} else { } else {
dict lappend vfs_runtime_map $vfs [list $runtime $appname] if {$appname eq ""} {
set appname [file rootname $vfstail]
}
dict lappend vfs_runtime_map $vfstail [list $runtime $appname $kit_type]
} }
} }
default { default {
puts stderr "bad entry in mapvfs.config - expected each entry after the runtime name to be of length 1 or length 2. got: $vfspair ([llength $vfspair])" puts stderr "bad entry in mapvfs.config - expected each entry after the runtime name to be of length 1 or length 2. got: $vfsconfig ([llength $vfsconfig])"
} }
} }
} }
if {[dict exists $runtime_vfs_map $runtime]} { if {[dict exists $runtime_vfs_map $runtime]} {
puts stderr "CONFIG FILE ERROR. runtime: $runtime was specified more than once in $mapfile." puts stderr "CONFIG FILE ERROR. runtime: $runtime was specified more than once in $mapfile."
@ -881,23 +1030,30 @@ foreach runtime [dict keys $runtime_vfs_map] {
puts -nonewline stdout $caps puts -nonewline stdout $caps
exit 0 exit 0
} }
lassign [punk::lib::invoke [list $rtfolder/$runtime <<$capscript]] stdout stderr exitcode #invoke can fail if runtime not an executable file for the current platform
if {$exitcode == 0} { if {![catch {
dict set runtime_caps $runtime $stdout lassign [punk::lib::invoke [list $rtfolder/$runtime <<$capscript]] stdout stderr exitcode
} errM]} {
if {$exitcode == 0} {
dict set runtime_caps $runtime $stdout
}
dict set runtime_caps $runtime exitcode $exitcode
} else {
dict set runtime_caps $runtime exitcode -1 error "launch-fail"
} }
} }
puts stdout "Runtime capabilities:" puts stdout "Runtime capabilities:"
punk::lib::pdict runtime_caps punk::lib::pdict runtime_caps
set vfs_folders [glob -nocomplain -dir $sourcefolder -types d -tail *.vfs] set vfs_tails [glob -nocomplain -dir $sourcefolder/vfs -types d -tail *.vfs]
#add any extra .vfs folders found in runtime/mapvfs.config file (e.g myotherruntimes/something.vfs) #add any extra .vfs folders found in runtime/mapvfs.config file (e.g myotherruntimes/something.vfs)
dict for {vfs -} $vfs_runtime_map { dict for {vfstail -} $vfs_runtime_map {
if {$vfs ni $vfs_folders} { if {$vfstail ni $vfs_tails} {
lappend vfs_folders $vfs lappend vfs_tails $vfstail
} }
} }
if {![llength $vfs_folders]} { if {![llength $vfs_tails]} {
puts stdout "No .vfs folders found at '$sourcefolder' - no kits to build" puts stdout "No .vfs folders found at '$sourcefolder/vfs' - no kits to build"
puts stdout " -done- " puts stdout " -done- "
exit 0 exit 0
} }
@ -955,13 +1111,66 @@ foreach runtimefile $runtimes {
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set failed_kits [list] set failed_kits [list]
set installed_kits [list] set installed_kits [list]
# set skipped_kits [list]
# loop over vfs_folders and for each one, loop over configured (or matching) runtimes - build with sdx if source .vfs or source runtime exe has changed. set skipped_kit_installs [list]
# we are using punkcheck to install result to buildfolder so we create a .punkcheck file at the target folder to store metadata.
# punkcheck allows us to not rely purely on timestamps (which may be unreliable) proc ::make_file_traversal_error {args} {
# error "file_traverse error: $args"
}
proc merge_over {sourcedir targetdir} {
package require fileutil
package require fileutil::traverse
package require control
if {![file exists $sourcedir]} {
puts stderr "merge_over sourcedir '$sourcedir' not found"
return
}
if {![file exists $targetdir]} {
puts stderr "merge_over targetdir '$targetdir' not found - target folder must already exist"
return
}
puts stdout "merge vfs $sourcedir over $targetdir STARTING"
#The tails should be unique enough for clarity in progress emissions to stdout
set sourcename [file tail $sourcedir]
set targetname [file tail $targetdir]
set t [fileutil::traverse %AUTO% $sourcedir -errorcmd ::make_file_traversal_error]
set last_type "-"
$t foreach file_or_dir {
set relpath [fileutil::stripPath $sourcedir $file_or_dir]
set target [file join $targetdir $relpath]
set this_type [file type $file_or_dir]
switch -exact -- $this_type {
directory {
if {$last_type ne "directory"} {
puts -nonewline stdout \n
}
if {![file exists $target]} {
#puts stdout "-- mkdir $target"
puts stdout "$sourcename -> $targetname mkdir $relpath"
file mkdir $target
file mtime $target [file mtime $file_or_dir]
} else {
puts stdout "$sourcename -> $targetname existing dir $relpath"
}
}
file {
puts -nonewline stdout "."
file copy -force $file_or_dir $target
}
default {
puts stderr "merge vfs $sourcedir !!! unhandled file type $this_type !!!"
}
}
set last_type $this_type
}
$t destroy
puts stdout "\nmerge vfs $sourcedir over $targetdir done."
}
set startdir [pwd] set startdir [pwd]
puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..." puts stdout "Found [llength $vfs_tails] .vfs folders - checking each for executables that may need to be built"
cd [file dirname $buildfolder] cd [file dirname $buildfolder]
#root folder mtime is insufficient for change detection. Tree mtime of folders only is a barely passable mechanism for vfs change detection in some circumstances - e.g if files added/removed but never edited in place #root folder mtime is insufficient for change detection. Tree mtime of folders only is a barely passable mechanism for vfs change detection in some circumstances - e.g if files added/removed but never edited in place
#a hash of full tree file & dir mtime may be more reasonable - but it remains to be seen if just tar & checksum is any/much slower. #a hash of full tree file & dir mtime may be more reasonable - but it remains to be seen if just tar & checksum is any/much slower.
@ -969,11 +1178,18 @@ cd [file dirname $buildfolder]
#Using first mtime encountered that is later than target is another option - but likely to be highly variable in speed. Last file in the tree could happen to be the latest, and this mechanism doesn't handle build on reversion to older source. #Using first mtime encountered that is later than target is another option - but likely to be highly variable in speed. Last file in the tree could happen to be the latest, and this mechanism doesn't handle build on reversion to older source.
set exe_names_seen [list] set exe_names_seen [list]
set path_cksum_cache [dict create] set path_cksum_cache [dict create]
foreach vfs $vfs_folders { dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/_vfscommon]
#
# loop over vfs_tails and for each one, loop over configured (or matching) runtimes - build with sdx or zipfs if source .vfs or source runtime exe has changed.
# we are using punkcheck to install result to buildfolder so we create a .punkcheck file at the target folder to store metadata.
# punkcheck allows us to not rely purely on timestamps (which may be unreliable)
#
foreach vfstail $vfs_tails {
set vfsname [file rootname $vfs] set vfsname [file rootname $vfstail]
puts stdout " Processing vfs $sourcefolder/$vfs"
puts stdout " ------------------------------------" puts stdout " ------------------------------------"
puts stdout " checking vfs $sourcefolder/vfs/$vfstail for configured runtimes"
set skipped_vfs_build 0 set skipped_vfs_build 0
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
set basedir $buildfolder set basedir $buildfolder
@ -981,14 +1197,12 @@ foreach vfs $vfs_folders {
-make-step build_vfs\ -make-step build_vfs\
] ]
#e.g punk87.vfs {cksum xxxx cksum_all_opts {-cksum_content 1 ... -cksum_algorithm sha1}}
dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/$vfs]
set runtimes [list] set runtimes [list]
if {[dict exists $vfs_runtime_map $vfs]} { if {[dict exists $vfs_runtime_map $vfstail]} {
#set runtimes [dict get $vfs_runtime_map $vfs] #set runtimes [dict get $vfs_runtime_map $vfstail]
#runtimes in vfs_runtime_map_vfs dict are unsuffixed (.exe stripped or was not present) #runtimes in vfs_runtime_map_vfs dict are unsuffixed (.exe stripped or was not present)
set applist [dict get $vfs_runtime_map $vfs] set applist [dict get $vfs_runtime_map $vfstail]
foreach rt_app $applist { foreach rt_app $applist {
lappend runtimes [lindex $rt_app 0] lappend runtimes [lindex $rt_app 0]
} }
@ -1004,7 +1218,7 @@ foreach vfs $vfs_folders {
} }
} else { } else {
#only match this vfs to a correspondingly named runtime if there was no explicit entry for that runtime #only match this vfs to a correspondingly named runtime if there was no explicit entry for that runtime
set matchrt [file rootname [file tail $vfs]] ;#e.g project.vfs -> project set matchrt [file rootname [file tail $vfstail]] ;#e.g project.vfs -> project
if {![dict exists $runtime_vfs_map $matchrt]} { if {![dict exists $runtime_vfs_map $matchrt]} {
if {"windows" eq $::tcl_platform(platform)} { if {"windows" eq $::tcl_platform(platform)} {
if {[file exists $rtfolder/$matchrt.exe]} { if {[file exists $rtfolder/$matchrt.exe]} {
@ -1017,7 +1231,7 @@ foreach vfs $vfs_folders {
} }
#assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config #assert $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config
puts " vfs: [file tail $vfs] runtimes to process: $runtimes" puts " vfs: $vfstail runtimes to process ([llength $runtimes]): $runtimes"
#todo - non kit based - zipkit? #todo - non kit based - zipkit?
# $runtimes may now include a dash entry "-" (from mapvfs.config file) # $runtimes may now include a dash entry "-" (from mapvfs.config file)
foreach runtime_fullname $runtimes { foreach runtime_fullname $runtimes {
@ -1032,13 +1246,16 @@ foreach vfs $vfs_folders {
if {[dict exists $runtime_vfs_map $rtname]} { if {[dict exists $runtime_vfs_map $rtname]} {
set applist [dict get $runtime_vfs_map $rtname] set applist [dict get $runtime_vfs_map $rtname]
foreach vfs_app $applist { foreach vfs_app $applist {
lassign $vfs_app configured_vfs appname lassign $vfs_app configured_vfs appname kit_type
if {$configured_vfs ne $vfs} { if {$configured_vfs ne $vfstail} {
continue continue
} }
if {$appname eq ""} { if {$appname eq ""} {
set appname $vfsname set appname $vfsname
} }
if {$kit_type eq ""} {
set kit_type "kit" ;#review - we should probably move to defaulting to zip (zipkit)
}
if {$rtname eq "-"} { if {$rtname eq "-"} {
set targetkit $appname.kit set targetkit $appname.kit
} else { } else {
@ -1055,68 +1272,167 @@ foreach vfs $vfs_folders {
} }
} }
lappend exe_names_seen $targetkit lappend exe_names_seen $targetkit
lappend targetkits $targetkit lappend targetkits [list $targetkit $kit_type]
} }
} }
puts stdout " vfs: [file tail $vfs] runtime: $rtname targetkits: $targetkits" puts stdout " vfs: $vfstail runtime: $rtname targetkits: $targetkits"
foreach targetkit $targetkits { foreach targetkit_info $targetkits {
puts stdout " processing targetkit: $targetkit_info"
lassign $targetkit_info targetkit kit_type
# -- ---------- # -- ----------
set vfs_installer [punkcheck::installtrack new $installername $basedir/.punkcheck] set vfs_installer [punkcheck::installtrack new $installername $basedir/.punkcheck]
$vfs_installer set_source_target $sourcefolder $buildfolder $vfs_installer set_source_target $sourcefolder $buildfolder
set vfs_event [$vfs_installer start_event {-make-step build_vfs}] set vfs_event [$vfs_installer start_event {-make-step build_vfs}]
$vfs_event targetset_init INSTALL $buildfolder/$targetkit $vfs_event targetset_init INSTALL $buildfolder/$targetkit
set relvfs [punkcheck::lib::path_relative $basedir $sourcefolder/vfs/$vfstail]
if {![dict exists $path_cksum_cache $relvfs]} {
#e.g ../vfs/punk87.vfs {cksum xxxx cksum_all_opts {-cksum_content 1 ... -cksum_algorithm sha1}}
dict set path_cksum_cache {*}[punk::mix::base::lib::get_relativecksum_from_base $basedir $sourcefolder/vfs/$vfstail]
}
$vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder $vfs_event targetset_cksumcache_set $path_cksum_cache ;#cached cksum entries for .vfs folder
$vfs_event targetset_addsource $sourcefolder/$vfs $vfs_event targetset_addsource $sourcefolder/vfs/_vfscommon
$vfs_event targetset_addsource $sourcefolder/vfs/$vfstail
if {$rtname ne "-"} { if {$rtname ne "-"} {
$vfs_event targetset_addsource $buildfolder/build_$runtime_fullname $vfs_event targetset_addsource $buildfolder/build_$runtime_fullname ;#working copy of runtime executable
} }
# -- ---------- # -- ----------
set rtmountpoint //zipfs:/rtmounts/$runtime_fullname
set changed_unchanged [$vfs_event targetset_source_changes] set changed_unchanged [$vfs_event targetset_source_changes]
set vfs_or_runtime_changed [expr {[llength [dict get $changed_unchanged changed]] || [llength [$vfs_event get_targets_exist]] < [llength [$vfs_event get_targets]]}]
if {[llength [dict get $changed_unchanged changed]] || [llength [$vfs_event get_targets_exist]] < [llength [$vfs_event get_targets]]} { if {$vfs_or_runtime_changed} {
#source .vfs folder has changes #source .vfs folder has changes
$vfs_event targetset_started $vfs_event targetset_started
# -- --- --- --- --- --- # -- --- --- --- --- ---
#use
if {[file exists $buildfolder/$vfsname.new]} { if {[file exists $buildfolder/$vfsname.new]} {
puts stderr "deleting existing $buildfolder/$vfsname.new" puts stderr "deleting existing $buildfolder/$vfsname.new"
file delete $buildfolder/$vfsname.new file delete $buildfolder/$vfsname.new
} }
puts stdout "building $vfsname.new with sdx.. vfsdir:$vfs cwd: [pwd]" package require fileutil
package require fileutil::traverse
package require control
set targetvfs $buildfolder/buildvfs_$targetkit.vfs
file delete -force $targetvfs
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
if {![file exists $rtmountpoint]} {
if {[catch {
tcl::zipfs::mount $buildfolder/build_$runtime_fullname rtmounts/$runtime_fullname
} errM]} {
tcl::zipfs::mount rtmounts/$runtime_fullname $buildfolder/build_$runtime_fullname
}
}
if {[file exists $rtmountpoint]} {
merge_over $rtmountpoint $targetvfs
}
merge_over $sourcefolder/vfs/_vfscommon $targetvfs
if {[catch {
if {$rtname ne "-"} {
exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$runtime_fullname -verbose
} else {
exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -verbose
} }
} result]} { kit {
if {$rtname ne "-"} { #for a kit, we don't need to extract the existing vfs from the runtime.
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result" # - the sdx merge process can merge our .vfs folder with the existing contents.
} else { puts stdout "building $vfsname.new with sdx.. vfsdir:$vfstail cwd: [pwd]"
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -verbose failed with msg: $result" if {[file exists $sourcefolder/vfs/_vfscommon]} {
file copy $sourcefolder/vfs/_vfscommon $targetvfs
} else {
file mkdir $targetvfs
}
}
}
set sourcevfs [file join $sourcefolder vfs $vfstail]
merge_over $sourcevfs $targetvfs
#set wrapvfs $sourcefolder/$vfs
set wrapvfs $targetvfs
switch -- $kit_type {
zip {
if {[catch {
if {[dict exists $runtime_caps $rtname]} {
if {[dict get $runtime_caps $rtname exitcode] == 0} {
if {![dict get $runtime_caps $rtname has_zipfs]} {
error "runtime $rtname doesn't have zipfs capability"
}
} else {
#could be runtime for another platform
puts stderr "RUNTIME capabilities unknown. Unsure if zip supported. trying anyway.."
}
}
#note - as at 2024-08 - there is some discussion about the interface to mkimg - it is considered unstable (may change to -option value syntax)
puts stderr "calling: tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs \"\" $buildfolder/build_$runtime_fullname"
tcl::zipfs::mkimg $buildfolder/$vfsname.new $wrapvfs $wrapvfs "" $buildfolder/build_$runtime_fullname
} result ]} {
set failmsg "zipfs mkimg failed with msg: $result"
puts stderr "tcl::zipfs::mkimg $targetkit failed"
lappend failed_kits [list kit $targetkit reason $failmsg]
$vfs_event targetset_end FAILED
$vfs_event destroy
$vfs_installer destroy
continue
} else {
puts stdout "ok - finished tcl::zipfs::mkimg"
set separator [string repeat = 40]
puts stdout $separator
puts stdout $result
puts stdout $separator
}
}
kit {
if {!$has_sdx} {
puts stderr "no sdx available to wrap $targetkit"
lappend failed_kits [list kit $targetkit reason "sdx_executable_unavailable"]
$vfs_event targetset_end FAILED
$vfs_event destroy
$vfs_installer destroy
continue
} else {
if {[catch {
if {$rtname ne "-"} {
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose
} else {
exec sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose
}
} result]} {
if {$rtname ne "-"} {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -runtime $buildfolder/build_$runtime_fullname -verbose failed with msg: $result"
} else {
set sdxmsg "sdx wrap $buildfolder/$vfsname.new -vfs $wrapvfs -verbose failed with msg: $result"
}
puts stderr "sdx wrap $targetkit failed"
lappend failed_kits [list kit $targetkit reason $sdxmsg]
$vfs_event targetset_end FAILED
$vfs_event destroy
$vfs_installer destroy
continue
} else {
puts stdout "ok - finished sdx"
set separator [string repeat = 40]
puts stdout $separator
puts stdout $result
puts stdout $separator
}
}
} }
puts stderr "sdx wrap $targetkit failed"
lappend failed_kits [list kit $targetkit reason $sdxmsg]
$vfs_event targetset_end FAILED
$vfs_event destroy
$vfs_installer destroy
continue
} else {
puts stdout "ok - finished sdx"
set separator [string repeat = 40]
puts stdout $separator
puts stdout $result
puts stdout $separator
} }
if {![file exists $buildfolder/$vfsname.new]} { if {![file exists $buildfolder/$vfsname.new]} {
puts stderr "|err> make.tcl build didn't seem to produce output at $sourcefolder/_build/$vfsname.new" puts stderr "|err> make.tcl build didn't seem to produce output at $buildfolder/$vfsname.new"
lappend failed_kits [list kit $targetkit reason "build failed to produce output at $sourcefolder/_build/$vfsname.new"] lappend failed_kits [list kit $targetkit reason "build failed to produce output at $buildfolder/$vfsname.new"]
$vfs_event targetset_end FAILED $vfs_event targetset_end FAILED
$vfs_event destroy $vfs_event destroy
$vfs_installer destroy $vfs_installer destroy
@ -1135,9 +1451,10 @@ foreach vfs $vfs_folders {
if {![catch { if {![catch {
exec $pscmd | grep $targetkit exec $pscmd | grep $targetkit
} still_running]} { } still_running]} {
set still_running_lines [split [string trim $still_running] \n]
puts stdout "found $targetkit instances still running\n" puts stdout "found ([llength $still_running_lines]) $targetkit instances still running\n"
set count_killed 0 set count_killed 0
set num_to_kill [llength $still_running_lines]
foreach ln [split $still_running \n] { foreach ln [split $still_running \n] {
puts stdout " $ln" puts stdout " $ln"
@ -1170,9 +1487,6 @@ foreach vfs $vfs_folders {
#review - *no running instance* works with windows taskkill - "*No such process*" works with kill -9 on FreeBSD and linux - other platforms? #review - *no running instance* works with windows taskkill - "*No such process*" works with kill -9 on FreeBSD and linux - other platforms?
if {![string match "*no running instance*" $errMsg] && ![string match "*No such process*" $errMsg]} { if {![string match "*no running instance*" $errMsg] && ![string match "*No such process*" $errMsg]} {
lappend failed_kits [list kit $targetkit reason "could not kill running process for $targetkit (using '$killcmd')"] lappend failed_kits [list kit $targetkit reason "could not kill running process for $targetkit (using '$killcmd')"]
$vfs_event targetset_end FAILED
$vfs_event destroy
$vfs_installer destroy
continue continue
} }
} else { } else {
@ -1180,10 +1494,15 @@ foreach vfs $vfs_folders {
incr count_killed incr count_killed
} }
} }
if {$count_killed > 0} { if {$count_killed < $num_to_kill} {
puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" $vfs_event targetset_end FAILED
after 1000 $vfs_event destroy
$vfs_installer destroy
continue
} }
puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable"
after 1000
} else { } else {
puts stderr "Ok.. no running '$targetkit' processes found" puts stderr "Ok.. no running '$targetkit' processes found"
} }
@ -1203,28 +1522,42 @@ foreach vfs $vfs_folders {
} }
} }
#WINDOWS filesystem 'tunneling' (file replacement within 15secs) could cause targetkit to copy ctime & shortname metadata from previous file! #WINDOWS filesystem 'tunnelling' (file replacement within 15secs) could cause targetkit to copy ctime & shortname metadata from previous file!
#This is probably harmless - but worth being aware of. #This is probably harmless - but worth being aware of.
file rename $buildfolder/$vfsname.new $buildfolder/$targetkit file rename $buildfolder/$vfsname.new $buildfolder/$targetkit
# -- --- --- --- --- --- # -- --- --- --- --- ---
$vfs_event targetset_end OK $vfs_event targetset_end OK
} else {
set skipped_vfs_build 1
puts stderr "."
puts stdout "Skipping build for vfs $vfstail with runtime $rtname - no change detected"
lappend skipped_kits [list kit $targetkit reason "no change detected"]
$vfs_event targetset_end SKIPPED
}
$vfs_event destroy
$vfs_installer destroy
after 200 after 200
set deployment_folder [file dirname $sourcefolder]/bin set deployment_folder [file dirname $sourcefolder]/bin
file mkdir $deployment_folder file mkdir $deployment_folder
# -- ---------- # -- ----------
set bin_installer [punkcheck::installtrack new "make.tcl" $deployment_folder/.punkcheck] set bin_installer [punkcheck::installtrack new "make.tcl" $deployment_folder/.punkcheck]
$bin_installer set_source_target $buildfolder $deployment_folder $bin_installer set_source_target $buildfolder $deployment_folder
set bin_event [$bin_installer start_event {-make-step final_kit_install}] set bin_event [$bin_installer start_event {-make-step final_kit_install}]
$bin_event targetset_init INSTALL $deployment_folder/$targetkit $bin_event targetset_init INSTALL $deployment_folder/$targetkit
#todo - move final deployment step outside of the build vfs loop? (final deployment can fail and then isn't rerun even though _build and deployed versions differ, unless .vfs modified again) #todo - move final deployment step outside of the build vfs loop? (final deployment can fail and then isn't rerun even though _build and deployed versions differ, unless .vfs modified again)
#set last_completion [$bin_event targetset_last_complete] #set last_completion [$bin_event targetset_last_complete]
$bin_event targetset_addsource $buildfolder/$targetkit $bin_event targetset_addsource $deployment_folder/$targetkit ;#add target as a source of metadata for change detection
$bin_event targetset_started $bin_event targetset_addsource $buildfolder/$targetkit
# -- ---------- $bin_event targetset_started
# -- ----------
set changed_unchanged [$bin_event targetset_source_changes]
set built_or_installed_kit_changed [expr {[llength [dict get $changed_unchanged changed]] || [llength [$bin_event get_targets_exist]] < [llength [$bin_event get_targets]]}]
if {$built_or_installed_kit_changed} {
if {[file exists $deployment_folder/$targetkit]} { if {[file exists $deployment_folder/$targetkit]} {
puts stderr "deleting existing deployed at $deployment_folder/$targetkit" puts stderr "deleting existing deployed at $deployment_folder/$targetkit"
@ -1250,19 +1583,17 @@ foreach vfs $vfs_folders {
# -- ---------- # -- ----------
$bin_event targetset_end OK $bin_event targetset_end OK
# -- ---------- # -- ----------
$bin_event destroy
$bin_installer destroy
} else { } else {
set skipped_vfs_build 1 set skipped_kit_install 1
puts stderr "." puts stderr "."
puts stdout "Skipping build for vfs $vfs with runtime $rtname - no change detected" puts stdout "Skipping kit install for $targetkit with vfs $vfstail runtime $rtname - no change detected"
$vfs_event targetset_end SKIPPED lappend skipped_kit_installs [list kit $targetkit reason "no change detected"]
$bin_event targetset_end SKIPPED
} }
$bin_event destroy
$bin_installer destroy
$vfs_event destroy
$vfs_installer destroy
} ;#end foreach targetkit } ;#end foreach targetkit
} ;#end foreach rtname in runtimes } ;#end foreach rtname in runtimes
@ -1278,8 +1609,21 @@ if {[llength $failed_kits]} {
punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@* punk::lib::showdict -channel stderr -roottype list $failed_kits */@*.@*
#puts stderr [join $failed_kits \n] #puts stderr [join $failed_kits \n]
} }
set had_kits [expr {[llength $installed_kits] || [llength $failed_kits] || [llength $skipped_kits]}]
puts stdout "done" if {$had_kits} {
puts stdout " module builds and kit/zipkit builds processed (vfs config: src/runtime/mapvfs.config)"
puts stdout " - use 'make.tcl modules' to build modules without scanning/building the vfs folders into executable kits/zipkits"
puts stdout " - use 'make.tcl vfscommonupdate' to copy built modules into the base vfs folder"
puts stdout " Note that without the vfscommonupdate step, 'make.tcl project' will include any manual changes in the *custom* vfs folders but"
puts stdout " without the latest built modules."
puts stdout " calling 'builtexename(.exe) dev' will allow testing of built modules before they are put into the kits/zipkits via 'vfscommonupdate' then 'project'"
} else {
puts stdout " module builds processed"
puts stdout ""
puts stdout " If kit/zipkit based executables required - create src/vfs/<somename>.vfs folders containing lib,modules,modules_tcl9 etc folders"
puts stdout " Also ensure appropriate executables exist in src/runtime along with src/runtime/mapvfs.config"
}
puts stdout "-done-"
exit 0 exit 0

336
src/vendormodules/fauxlink-0.1.0.tm

@ -0,0 +1,336 @@
# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt
#
# 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) 2024
#
# @@ Meta Begin
# Application fauxlink 0.1.0
# Meta platform tcl
# Meta license <unspecified>
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# doctools header
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[manpage_begin fauxlink_module_fauxlink 0 0.1.0]
#[copyright "2024"]
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}]
#[moddesc {-}] [comment {-- Description at end of page heading --}]
#[require fauxlink]
#[keywords module]
#[description]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Overview]
#[para] overview of fauxlink
#[subsection Concepts]
#[para] -
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[subsection dependencies]
#[para] packages used by fauxlink
#[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
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval fauxlink::class {
#*** !doctools
#[subsection {Namespace fauxlink::class}]
#[para] class definitions
if {[info commands [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
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval fauxlink {
namespace export {[a-z]*}; # Convention: export all lowercase
#todo - enforce utf-8
#literal unicode chars supported by modern filesystems - leave as is - REVIEW
variable encode_map
variable decode_map
#most filesystems don't allow NULL - map to empty string
#Make sure % is not in encode_map
set encode_map [dict create\
\x00 ""\
{ } %20\
\t %09\
+ %2B\
# %23\
* %2A\
? %3F\
\\ %5C\
/ %2F\
| %7C\
: %3A\
{;} %3B\
{"} %22\
< %3C\
> %3E\
]
#must_encode
# + # * ? \ / | : ; " < > <sp> \t
# also NUL to empty string
# also ctrl chars 01 to 1F (1..31)
for {set i 1} {$i < 32} {incr i} {
set ch [format %c $i]
set enc "%[format %02X $i]"
set enc_lower [string tolower $enc]
dict set encode_map $ch $enc
dict set decode_map $enc $ch
dict set decode_map $enc_lower $ch
}
variable must_encode
set must_encode [dict keys $encode_map]
set decode_map [dict create\
%20 { }\
%21 "!"\
%22 {"}\
%23 "#"\
%24 "$"\
%25 "%"\
%26 "&"\
%27 "'"\
%28 "("\
%29 ")"\
%2A "*"\
%2a "*"\
%2B "+"\
%2b "+"\
%2C ","\
%2c ","\
%2F "/"\
%2f "/"\
%3A ":"\
%3a ":"\
%3B {;}\
%3b {;}\
%3D "="\
%3C "<"\
%3c "<"\
%3d "="\
%3E ">"\
%3e ">"\
%3F "?"\
%3f "?"\
%40 "@"\
%5B "\["\
%5b "\["\
%5C "\\"\
%5c "\\"\
%5D "\]"\
%5d "\]"\
%5E "^"\
%5e "^"\
%60 "`"\
%7B "{"\
%7b "{"\
%7C "|"\
%7c "|"\
%7D "}"\
%7d "}"\
%7E "~"\
%7e "~"\
]
#*** !doctools
#[subsection {Namespace fauxlink}]
#[para] Core API functions for fauxlink
#[list_begin definitions]
proc resolve {link} {
variable decode_map
variable encode_map
variable must_encode
set ftail [file tail $link]
if {[file extension $ftail] ne ".fauxlink"} {
error "fauxlink::resolve refusing to process link $link - file extension must be .fauxlink"
}
set linkspec [file rootname $ftail]
# - any # or + within the target path or name should have been uri encoded as %23 and %2b
if {[tcl::string::first # $linkspec] < 0} {
error "fauxlink::resolve error. Link must contain a # (usually at start if name matches target)"
}
#only the 1st 2 parts of split on # are significant.
#if there are more # chars present - the subsequent parts are effectively a comment
#check namepec already has required chars encoded
lassign [split $linkspec #] namespec targetspec
#puts stderr "-->namespec $namespec"
set nametest [tcl::string::map $encode_map $namespec]
#puts stderr "-->nametest $nametest"
#nothing should be changed - if there are unencoded chars that must be encoded it is an error
if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} {
set err "fauxlink::resolve invalid chars in name part (section prior to first #)"
set idx 0
foreach ch [split $namespec ""] {
if {$ch in $must_encode} {
set enc [dict get $encode_map $ch]
append err " char $idx should be encoded as $enc" \n
}
incr idx
}
error $err
}
set name [tcl::string::map $decode_map $namespec]
#puts stderr "-->name: $name"
set targetsegment [split $targetspec +]
#check each + delimited part of targetspec already has required chars encoded
set s 0 ;#segment index
set result_segments [list]
foreach segment $targetsegment {
set targettest [tcl::string::map $encode_map $segment]
if {[tcl::string::length $targettest] ne [tcl::string::length $segment]} {
set err "fauxlink::resolve invalid chars in targetpath (section following first #)"
set idx 0
foreach ch [split $segment ""] {
if {$ch in $must_encode} {
set enc [dict get $encode_map $ch]
append err " segment $s char $idx should be encoded as $enc" \n
}
incr idx
}
error $err
}
lappend result_segments [tcl::string::map $decode_map $segment]
incr s
}
set targetpath [join $result_segments /]
return [dict create name $name targetpath $targetpath]
}
proc link_as {name target} {
}
#proc sample1 {p1 args} {
# #*** !doctools
# #[call [fun sample1] [arg p1] [opt {?option value...?}]]
# #[para]Description of sample1
# return "ok"
#}
#*** !doctools
#[list_end] [comment {--- end definitions namespace fauxlink ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# Secondary API namespace
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval fauxlink::lib {
namespace export {[a-z]*}; # Convention: export all lowercase
namespace path [namespace parent]
#*** !doctools
#[subsection {Namespace fauxlink::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 fauxlink::lib ---}]
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
#*** !doctools
#[section Internal]
namespace eval fauxlink::system {
#*** !doctools
#[subsection {Namespace fauxlink::system}]
#[para] Internal functions that are not part of the API
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide fauxlink [namespace eval fauxlink {
variable pkg fauxlink
variable version
set version 0.1.0
}]
return
#*** !doctools
#[manpage_end]

3
src/vendormodules/include_modules.config

@ -8,7 +8,8 @@ set local_modules [list\
c:/repo/jn/tclmodules/tablelist/modules tablelist\ c:/repo/jn/tclmodules/tablelist/modules tablelist\
c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\ c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\
c:/repo/jn/tclmodules/tomlish/modules tomlish\ c:/repo/jn/tclmodules/tomlish/modules tomlish\
c:/repo/jn/tclmodules/tomlish/modules test::tomlish\ c:/repo/jn/tclmodules/overtype/modules overtype\
c:/repo/jn/tclmodules/fauxlink/modules fauxlink\
] ]
set fossil_modules [dict create\ set fossil_modules [dict create\

18
src/vendormodules/overtype-1.6.5.tm

@ -439,7 +439,8 @@ tcl::namespace::eval overtype {
if {[llength $lflines]} { if {[llength $lflines]} {
lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1]
} }
set inputchunks $lflines[unset lflines] #set inputchunks $lflines[unset lflines]
set inputchunks [lindex [list $lflines [unset lflines]] 0]
} }
} }
@ -2115,6 +2116,7 @@ tcl::namespace::eval overtype {
if {[llength $undercols]< $opt_width} { if {[llength $undercols]< $opt_width} {
set diff [expr {$opt_width- [llength $undercols]}] set diff [expr {$opt_width- [llength $undercols]}]
if {$diff > 0} { if {$diff > 0} {
#set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower
lappend undercols {*}[lrepeat $diff "\u0000"] lappend undercols {*}[lrepeat $diff "\u0000"]
lappend understacks {*}[lrepeat $diff $cs] lappend understacks {*}[lrepeat $diff $cs]
lappend understacks_gx {*}[lrepeat $diff $gs] lappend understacks_gx {*}[lrepeat $diff $gs]
@ -3889,7 +3891,19 @@ tcl::namespace::eval overtype {
#OSC 4 - set colour palette #OSC 4 - set colour palette
#can take multiple params #can take multiple params
#e.g \x1b\]4\;1\;red\;2\;green\x1b\\ #e.g \x1b\]4\;1\;red\;2\;green\x1b\\
set params [tcl::string::range $code_content 1 end] set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon
set cmap [dict create]
foreach {cnum spec} [split $params {;}] {
if {$cnum >= 0 and $cnum <= 255} {
#todo - parse spec from names like 'red' to RGB
#todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc)
#also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ?
dict set cmap $cnum $spec
} else {
#todo - log
puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"

BIN
src/vendormodules/test/tomlish-1.1.1.tm

Binary file not shown.

2952
src/vendormodules/tomlish-1.1.1.tm

File diff suppressed because it is too large Load Diff

540
src/vfs/_vfscommon/modules/calculator_test-0.1.tm

@ -0,0 +1,540 @@
## -*- tcl -*-
##
## OO-based Tcl/PARAM implementation of the parsing
## expression grammar
##
## calculator grammar
##
## Generated from file calctest.tcl
## for user jnoble
##
# # ## ### ##### ######## ############# #####################
## Requirements
package require Tcl 8.5 9
package require TclOO
package require pt::rde::oo ; # OO-based implementation of the
# PARAM virtual machine
# underlying the Tcl/PARAM code
# used below.
# # ## ### ##### ######## ############# #####################
##
oo::class create calculator_test {
# # ## ### ##### ######## #############
## Public API
superclass pt::rde::oo ; # TODO - Define this class.
# Or can we inherit from a snit
# class too ?
method parse {channel} {
my reset $channel
my MAIN ; # Entrypoint for the generated code.
return [my complete]
}
method parset {text} {
my reset {}
my data $text
my MAIN ; # Entrypoint for the generated code.
return [my complete]
}
# # ## ### ###### ######## #############
## BEGIN of GENERATED CODE. DO NOT EDIT.
#
# Grammar Start Expression
#
method MAIN {} {
my sym_Expression
return
}
#
# value Symbol 'AddOp'
#
method sym_AddOp {} {
# [+-]
my si:void_symbol_start AddOp
my si:next_class +-
my si:void_leaf_symbol_end AddOp
return
}
#
# value Symbol 'Digit'
#
method sym_Digit {} {
# [0123456789]
my si:void_symbol_start Digit
my si:next_class 0123456789
my si:void_leaf_symbol_end Digit
return
}
#
# value Symbol 'Expression'
#
method sym_Expression {} {
# x
# (Term)
# *
# x
# *
# '<blank>'
# (AddOp)
# *
# '<blank>'
# (Term)
my si:value_symbol_start Expression
my sequence_18
my si:reduce_symbol_end Expression
return
}
method sequence_18 {} {
# x
# (Term)
# *
# x
# *
# '<blank>'
# (AddOp)
# *
# '<blank>'
# (Term)
my si:value_state_push
my sym_Term
my si:valuevalue_part
my kleene_16
my si:value_state_merge
return
}
method kleene_16 {} {
# *
# x
# *
# '<blank>'
# (AddOp)
# *
# '<blank>'
# (Term)
while {1} {
my si:void2_state_push
my sequence_14
my si:kleene_close
}
return
}
method sequence_14 {} {
# x
# *
# '<blank>'
# (AddOp)
# *
# '<blank>'
# (Term)
my si:void_state_push
my kleene_8
my si:voidvalue_part
my sym_AddOp
my si:valuevalue_part
my kleene_8
my si:valuevalue_part
my sym_Term
my si:value_state_merge
return
}
method kleene_8 {} {
# *
# '<blank>'
while {1} {
my si:void2_state_push
my si:next_char \40
my si:kleene_close
}
return
}
#
# value Symbol 'Factor'
#
method sym_Factor {} {
# x
# (Fragment)
# *
# x
# *
# '<blank>'
# (PowOp)
# *
# '<blank>'
# (Fragment)
my si:value_symbol_start Factor
my sequence_32
my si:reduce_symbol_end Factor
return
}
method sequence_32 {} {
# x
# (Fragment)
# *
# x
# *
# '<blank>'
# (PowOp)
# *
# '<blank>'
# (Fragment)
my si:value_state_push
my sym_Fragment
my si:valuevalue_part
my kleene_30
my si:value_state_merge
return
}
method kleene_30 {} {
# *
# x
# *
# '<blank>'
# (PowOp)
# *
# '<blank>'
# (Fragment)
while {1} {
my si:void2_state_push
my sequence_28
my si:kleene_close
}
return
}
method sequence_28 {} {
# x
# *
# '<blank>'
# (PowOp)
# *
# '<blank>'
# (Fragment)
my si:void_state_push
my kleene_8
my si:voidvalue_part
my sym_PowOp
my si:valuevalue_part
my kleene_8
my si:valuevalue_part
my sym_Fragment
my si:value_state_merge
return
}
#
# value Symbol 'Fragment'
#
method sym_Fragment {} {
# /
# x
# '\('
# *
# '<blank>'
# (Expression)
# *
# '<blank>'
# '\)'
# (Number)
# (Var)
my si:value_symbol_start Fragment
my choice_46
my si:reduce_symbol_end Fragment
return
}
method choice_46 {} {
# /
# x
# '\('
# *
# '<blank>'
# (Expression)
# *
# '<blank>'
# '\)'
# (Number)
# (Var)
my si:value_state_push
my sequence_42
my si:valuevalue_branch
my sym_Number
my si:valuevalue_branch
my sym_Var
my si:value_state_merge
return
}
method sequence_42 {} {
# x
# '\('
# *
# '<blank>'
# (Expression)
# *
# '<blank>'
# '\)'
my si:void_state_push
my si:next_char \50
my si:voidvoid_part
my kleene_8
my si:voidvalue_part
my sym_Expression
my si:valuevalue_part
my kleene_8
my si:valuevalue_part
my si:next_char \51
my si:value_state_merge
return
}
#
# value Symbol 'MulOp'
#
method sym_MulOp {} {
# [*/]
my si:void_symbol_start MulOp
my si:next_class */
my si:void_leaf_symbol_end MulOp
return
}
#
# value Symbol 'Number'
#
method sym_Number {} {
# x
# ?
# (Sign)
# +
# (Digit)
my si:value_symbol_start Number
my sequence_57
my si:reduce_symbol_end Number
return
}
method sequence_57 {} {
# x
# ?
# (Sign)
# +
# (Digit)
my si:value_state_push
my optional_52
my si:valuevalue_part
my poskleene_55
my si:value_state_merge
return
}
method optional_52 {} {
# ?
# (Sign)
my si:void2_state_push
my sym_Sign
my si:void_state_merge_ok
return
}
method poskleene_55 {} {
# +
# (Digit)
my i_loc_push
my sym_Digit
my si:kleene_abort
while {1} {
my si:void2_state_push
my sym_Digit
my si:kleene_close
}
return
}
#
# value Symbol 'PowOp'
#
method sym_PowOp {} {
# "**"
my si:void_symbol_start PowOp
my si:next_str **
my si:void_leaf_symbol_end PowOp
return
}
#
# value Symbol 'Sign'
#
method sym_Sign {} {
# [-+]
my si:void_symbol_start Sign
my si:next_class -+
my si:void_leaf_symbol_end Sign
return
}
#
# value Symbol 'Term'
#
method sym_Term {} {
# x
# (Factor)
# *
# x
# *
# '<blank>'
# (MulOp)
# *
# '<blank>'
# (Factor)
my si:value_symbol_start Term
my sequence_75
my si:reduce_symbol_end Term
return
}
method sequence_75 {} {
# x
# (Factor)
# *
# x
# *
# '<blank>'
# (MulOp)
# *
# '<blank>'
# (Factor)
my si:value_state_push
my sym_Factor
my si:valuevalue_part
my kleene_73
my si:value_state_merge
return
}
method kleene_73 {} {
# *
# x
# *
# '<blank>'
# (MulOp)
# *
# '<blank>'
# (Factor)
while {1} {
my si:void2_state_push
my sequence_71
my si:kleene_close
}
return
}
method sequence_71 {} {
# x
# *
# '<blank>'
# (MulOp)
# *
# '<blank>'
# (Factor)
my si:void_state_push
my kleene_8
my si:voidvalue_part
my sym_MulOp
my si:valuevalue_part
my kleene_8
my si:valuevalue_part
my sym_Factor
my si:value_state_merge
return
}
#
# value Symbol 'Var'
#
method sym_Var {} {
# x
# '$'
# [xyz]
my si:void_symbol_start Var
my sequence_80
my si:void_leaf_symbol_end Var
return
}
method sequence_80 {} {
# x
# '$'
# [xyz]
my si:void_state_push
my si:next_char $
my si:voidvoid_part
my si:next_class xyz
my si:void_state_merge
return
}
## END of GENERATED CODE. DO NOT EDIT.
# # ## ### ###### ######## #############
}
# # ## ### ##### ######## ############# #####################
## Ready
package provide calculator_test 0.1
return

BIN
src/vfs/_vfscommon/modules/modpodtest-0.1.0.tm

Binary file not shown.

18
src/vfs/_vfscommon/modules/overtype-1.6.5.tm

@ -439,7 +439,8 @@ tcl::namespace::eval overtype {
if {[llength $lflines]} { if {[llength $lflines]} {
lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1]
} }
set inputchunks $lflines[unset lflines] #set inputchunks $lflines[unset lflines]
set inputchunks [lindex [list $lflines [unset lflines]] 0]
} }
} }
@ -2115,6 +2116,7 @@ tcl::namespace::eval overtype {
if {[llength $undercols]< $opt_width} { if {[llength $undercols]< $opt_width} {
set diff [expr {$opt_width- [llength $undercols]}] set diff [expr {$opt_width- [llength $undercols]}]
if {$diff > 0} { if {$diff > 0} {
#set undercols [list {*}$undercols {*}[lrepeat $diff "\u0000"]] ;#2024 - much slower
lappend undercols {*}[lrepeat $diff "\u0000"] lappend undercols {*}[lrepeat $diff "\u0000"]
lappend understacks {*}[lrepeat $diff $cs] lappend understacks {*}[lrepeat $diff $cs]
lappend understacks_gx {*}[lrepeat $diff $gs] lappend understacks_gx {*}[lrepeat $diff $gs]
@ -3889,7 +3891,19 @@ tcl::namespace::eval overtype {
#OSC 4 - set colour palette #OSC 4 - set colour palette
#can take multiple params #can take multiple params
#e.g \x1b\]4\;1\;red\;2\;green\x1b\\ #e.g \x1b\]4\;1\;red\;2\;green\x1b\\
set params [tcl::string::range $code_content 1 end] set params [tcl::string::range $code_content 2 end] ;#strip 4 and first semicolon
set cmap [dict create]
foreach {cnum spec} [split $params {;}] {
if {$cnum >= 0 and $cnum <= 255} {
#todo - parse spec from names like 'red' to RGB
#todo - accept rgb:ab/cd/ef as well as rgb:/a/b/c (as alias for aa/bb/cc)
#also - what about rgb:abcd/defg/hijk and 12-bit abc/def/ghi ?
dict set cmap $cnum $spec
} else {
#todo - log
puts stderr "overtype::renderline OSC 4 set colour palette - bad color number: $cnum must be from 0 to 255. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"
}
}
puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]" puts stderr "overtype::renderline OSC 4 set colour palette unimplemented. code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code]"

28
src/vfs/_vfscommon/modules/punk/console-0.1.1.tm

@ -183,7 +183,9 @@ namespace eval punk::console {
variable previous_stty_state_$channel variable previous_stty_state_$channel
set sttycmd [auto_execok stty] set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] eq ""} { if {[set previous_stty_state_$channel] eq ""} {
set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel] if {[catch {{*}$sttycmd -g <@$channel} previous_stty_state_$channel]} {
set previous_stty_state_$channel ""
}
} }
exec {*}$sttycmd raw -echo <@$channel exec {*}$sttycmd raw -echo <@$channel
@ -253,13 +255,21 @@ namespace eval punk::console {
return "line" return "line"
} }
} elseif {$raw_or_line eq "raw"} { } elseif {$raw_or_line eq "raw"} {
punk::console::enableRaw if {[catch {
punk::console::enableRaw
} errM]} {
puts stderr "Warning punk::console::enableRaw failed - $errM"
}
if {[can_ansi]} { if {[can_ansi]} {
punk::console::enableVirtualTerminal both punk::console::enableVirtualTerminal both
} }
} elseif {$raw_or_line eq "line"} { } elseif {$raw_or_line eq "line"} {
#review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?) #review -order. disableRaw has memory from enableRaw.. but but for line mode we want vt disabled - so call it after disableRaw (?)
punk::console::disableRaw if {[catch {
punk::console::disableRaw
} errM]} {
puts stderr "Warning punk::console::disableRaw failed - $errM"
}
if {[can_ansi]} { if {[can_ansi]} {
punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc punk::console::disableVirtualTerminal input ;#default readline arrow behaviour etc
punk::console::enableVirtualTerminal output ;#display/use ansi codes punk::console::enableVirtualTerminal output ;#display/use ansi codes
@ -290,12 +300,15 @@ namespace eval punk::console {
set loadstate [zzzload::pkg_require twapi] set loadstate [zzzload::pkg_require twapi]
#loadstate could also be stuck on loading? - review - zzzload not very ripe #loadstate could also be stuck on loading? - review - zzzload not very ripe
#Twapi is relatively slow to load - can be 1s plus in normal cases - and much longer if there are disk performance issues. #Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues.
if {$loadstate ni [list failed]} { if {$loadstate ni [list failed]} {
#possibly still 'loading'
#review zzzload usage #review zzzload usage
#puts stdout "=========== console loading twapi =============" #puts stdout "=========== console loading twapi ============="
zzzload::pkg_wait twapi set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait
}
if {$loadstate ni [list failed]} {
package require twapi ;#should be fast once twapi dll loaded in zzzload thread package require twapi ;#should be fast once twapi dll loaded in zzzload thread
set ::punk::console::has_twapi 1 set ::punk::console::has_twapi 1
@ -523,6 +536,9 @@ namespace eval punk::console {
set is_raw 0 set is_raw 0
return [list stdin [list from $oldmode to $newmode]] return [list stdin [list from $oldmode to $newmode]]
} elseif {[set sttycmd [auto_execok stty]] ne ""} { } elseif {[set sttycmd [auto_execok stty]] ne ""} {
#stty can return info on windows - but doesn't seem to be able to set anything.
#review - is returned info even valid?
set sttycmd [auto_execok stty] set sttycmd [auto_execok stty]
if {[set previous_stty_state_$channel] ne ""} { if {[set previous_stty_state_$channel] ne ""} {
exec {*}$sttycmd [set previous_stty_state_$channel] exec {*}$sttycmd [set previous_stty_state_$channel]

165
src/vfs/_vfscommon/modules/punk/lib-0.1.1.tm

@ -339,6 +339,92 @@ namespace eval punk::lib {
set has_twapi [expr {![catch {package require twapi}]}] set has_twapi [expr {![catch {package require twapi}]}]
} }
# -- ---
#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
#8.6,8.7,9.0 - 'lappend first {*}$second' is many times faster - especially as list grows
# Review and retest as new versions come out.
# -- ---
proc list_multi_append1 {lvar1 lvar2} {
#clear winner in 2024
upvar $lvar1 l1 $lvar2 l2
lappend l1 {*}$l2
return $l1
}
proc list_multi_append2 {lvar1 lvar2} {
upvar $lvar1 l1 $lvar2 l2
set l1 [list {*}$l1 {*}$l2]
}
proc list_multi_append3 {lvar1 lvar2} {
upvar $lvar1 l1 $lvar2 l2
set l1 [lindex [list [list {*}$l1 {*}$l2] [unset l1]] 0]
}
#testing e.g
#set l1_reset {a b c}
#set l2 {a b c d e f g}
#set l1 $l1_reset
#time {list_multi_append1 l1 l2} 1000
#set l1 $l1_reset
#time {list_multi_append2 l1 l2} 1000
# -- ---
proc lswap {lvar a z} {
upvar $lvar l
if {[lindex_resolve_basic $l $a] < 0 || [lindex_resolve_basic $l $z] < 0} {
#if we didn't do this check - we could raise an error on second lset - leaving list corrupted because only one lset occurred
#(e.g using: lswap mylist end-2 end on a two element list)
#on the unhapy path we can take time to check the nature of the out-of-boundness to give a nicer report
set a_index [lindex_resolve $l $a]
set a_msg ""
switch -- $a_index {
-2 {
"$a is greater th
}
-3 {
}
}
error "lswap cannot indices $a and $z $a is out of range"
}
set item2 [lindex $l $z]
lset l $z [lindex $l $a]
lset l $a $item2
return $l
}
#proc lswap2 {lvar a z} {
# upvar $lvar l
# #if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower
# set l [concat [lrange $l 0 $a-1] [lindex $l $z] [lrange $l $a+1 $z-1] [lindex $l $a] [lrange $l $z+1 end]]
#}
proc lswap2 {lvar a z} {
upvar $lvar l
#if index a strictly less <= z we can do in one-liner for fun - but it's replacing whole list - so much slower
set l [list {*}[lrange $l 0 $a-1] [lindex $l $z] {*}[lrange $l $a+1 $z-1] [lindex $l $a] {*}[lrange $l $z+1 end]]
}
#an experimental test of swapping vars without intermediate variables
#It's an interesting idea - but probably of little to no practical use
# - the swap_intvars3 version using intermediate var is faster in Tcl
# - This is probably unsurprising - as it's simpler code.
# Even if we tried this technique in c - the compiler would probably do a better job with the intermediate variable than with the math tricks.
#proc swap_intvars {swapv1 swapv2} {
# upvar $swapv1 _x $swapv2 _y
# set _x [expr {[expr {$_x + $_y}] - [set _y $_x]}]
#}
#proc swap_intvars2 {swapv1 swapv2} {
# upvar $swapv1 _x $swapv2 _y
# set _x [expr {$_x ^ $_y}]
# set _y [expr {$_x ^ $_y}]
# set _x [expr {$_x ^ $_y}]
#}
#proc swap_intvars3 {swapv1 swapv2} {
# #using intermediate variable
# upvar $swapv1 _x $swapv2 _y
# set z $_x
# set _x $_y
# set _y $z
#}
#*** !doctools #*** !doctools
#[subsection {Namespace punk::lib}] #[subsection {Namespace punk::lib}]
@ -347,6 +433,7 @@ namespace eval punk::lib {
if {[info commands lseq] ne ""} { if {[info commands lseq] ne ""} {
#tcl 8.7+ lseq significantly faster, especially for larger ranges #tcl 8.7+ lseq significantly faster, especially for larger ranges
#The internal rep can be an 'arithseries' with no string representation
#support minimal set from to #support minimal set from to
proc range {from to} { proc range {from to} {
lseq $from $to lseq $from $to
@ -1009,24 +1096,28 @@ namespace eval punk::lib {
} }
set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high
#keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds
if {${lower_resolve} == -1} { if {${lower_resolve} == -2} {
##x
#lower bound is above upper list range #lower bound is above upper list range
#match with decreasing indices is still possible #match with decreasing indices is still possible
set lower [expr {[llength $dval]-1}] ;#set to max set lower [expr {[llength $dval]-1}] ;#set to max
} elseif {$lower_resolve == -2} { } elseif {$lower_resolve == -3} {
##x
set lower 0 set lower 0
} else { } else {
set lower $lower_resolve set lower $lower_resolve
} }
set upper [punk::lib::lindex_resolve $dval $b] set upper [punk::lib::lindex_resolve $dval $b]
if {$upper == -2} { if {$upper == -3} {
##x
#upper bound is below list range - #upper bound is below list range -
if {$lower_resolve >=-1} { if {$lower_resolve >=-2} {
##x
set upper 0 set upper 0
} else { } else {
continue continue
} }
} elseif {$upper == -1} { } elseif {$upper == -2} {
#use max #use max
set upper [expr {[llength $dval]-1}] set upper [expr {[llength $dval]-1}]
#assert - upper >=0 because we have ruled out empty lists #assert - upper >=0 because we have ruled out empty lists
@ -1670,6 +1761,7 @@ namespace eval punk::lib {
} }
} }
# showdict uses lindex_resolve results -2 & -3 to determine whether index is out of bunds on upper vs lower side
proc lindex_resolve {list index} { proc lindex_resolve {list index} {
#*** !doctools #*** !doctools
#[call [fun lindex_resolve] [arg list] [arg index]] #[call [fun lindex_resolve] [arg list] [arg index]]
@ -1679,11 +1771,13 @@ namespace eval punk::lib {
#[para]Sometimes the actual integer index is desired. #[para]Sometimes the actual integer index is desired.
#[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks.
#[para]lindex_resolve will parse the index expression and return: #[para]lindex_resolve will parse the index expression and return:
#[para] a) -2 if the supplied index expression is below the lower bound for the supplied list. (< 0) #[para] a) -3 if the supplied index expression is below the lower bound for the supplied list. (< 0)
#[para] b) -1 if the supplied index expression is above the upper bound for the supplied list. (> end) #[para] b) -2 if the supplied index expression is above the upper bound for the supplied list. (> end)
#[para] We don't return -1 - as the similar function lindex_resolve_basic uses this to denote out of range at either end of the list
#[para]Otherwise it will return an integer corresponding to the position in the list. #[para]Otherwise it will return an integer corresponding to the position in the list.
#[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway. #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway.
#[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable
#[para]For empty lists, end and end+x indices are considered to be out of bounds on the upper side - thus returning -2
#Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr
#if {![llength $list]} { #if {![llength $list]} {
@ -1694,9 +1788,9 @@ namespace eval punk::lib {
if {[string is integer -strict $index]} { if {[string is integer -strict $index]} {
#can match +i -i #can match +i -i
if {$index < 0} { if {$index < 0} {
return -2 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= [llength $list]} {
return -1 return -2
} else { } else {
#integer may still have + sign - normalize with expr #integer may still have + sign - normalize with expr
return [expr {$index}] return [expr {$index}]
@ -1708,14 +1802,14 @@ namespace eval punk::lib {
set offset [string range $index 4 end] set offset [string range $index 4 end]
if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"} if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"}
if {$op eq "+" && $offset != 0} { if {$op eq "+" && $offset != 0} {
return -1 return -2
} }
} else { } else {
#end #index is 'end'
set index [expr {[llength $list]-1}] set index [expr {[llength $list]-1}]
if {$index < 0} { if {$index < 0} {
#special case - end with empty list - treat end like a positive number out of bounds #special case - 'end' with empty list - treat end like a positive number out of bounds
return -1 return -2
} else { } else {
return $index return $index
} }
@ -1723,7 +1817,7 @@ namespace eval punk::lib {
if {$offset == 0} { if {$offset == 0} {
set index [expr {[llength $list]-1}] set index [expr {[llength $list]-1}]
if {$index < 0} { if {$index < 0} {
return -1 ;#special case return -2 ;#special case as above
} else { } else {
return $index return $index
} }
@ -1732,7 +1826,7 @@ namespace eval punk::lib {
set index [expr {([llength $list]-1) - $offset}] set index [expr {([llength $list]-1) - $offset}]
} }
if {$index < 0} { if {$index < 0} {
return -2 return -3
} else { } else {
return $index return $index
} }
@ -1753,26 +1847,50 @@ namespace eval punk::lib {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
} }
if {$index < 0} { if {$index < 0} {
return -2 return -3
} elseif {$index >= [llength $list]} { } elseif {$index >= [llength $list]} {
return -1 return -2
} }
return $index return $index
} }
} }
} }
proc lindex_resolve2 {list index} { proc lindex_resolve_basic {list index} {
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. #*** !doctools
#[call [fun lindex_resolve_basic] [arg list] [arg index]]
#[para] Accepts index of the forms accepted by Tcl's list commands. (e.g compound indices such as 3+1 end-2)
#[para] returns -1 for out of range at either end, or a valid integer index
#[para] Unlike lindex_resolve; lindex_resolve_basic can't determine if an out of range index was out of range at the lower or upper bound
#[para] This is only likely to be faster than average over lindex_resolve for Tcl which has the builtin lseq command
#[para] The performance advantage is more likely to be present when using compound indexes such as $x+1 or end-1
#[para] For pure integer indices the performance should be equivalent
#set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+
# - which
#for {set i 0} {$i < [llength $list]} {incr i} { #for {set i 0} {$i < [llength $list]} {incr i} {
# lappend indices $i # lappend indices $i
#} #}
set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000
if {[string is integer -strict $index]} {
#can match +i -i
#avoid even the lseq overhead when the index is simple
if {$index < 0 || ($index >= [llength $list])} {
#even though in this case we could return -2 or -3 like lindex_resolve; for consistency we don't, as it's not always determinable for compound indices using the lseq method.
return -1
} else {
#integer may still have + sign - normalize with expr
return [expr {$index}]
}
}
if {[llength $list]} { if {[llength $list]} {
set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback.
#if lseq was available - $indices is an 'arithseries' - theoretically not taking up ram(?)
} else { } else {
set indices [list] set indices [list]
} }
set idx [lindex $indices $index] set idx [lindex $indices $index]
if {$idx eq ""} { if {$idx eq ""} {
#we have no way to determine if out of bounds is at lower vs upper end
return -1 return -1
} else { } else {
return $idx return $idx
@ -2334,13 +2452,6 @@ namespace eval punk::lib {
} }
return $prefix return $prefix
} }
#test example of the technique - not necessarily particularly useful as a function, except maybe for brevity/clarity. todo - test if inlined version gives any perf advantage compared to a temp var
proc swapnumvars {namea nameb} {
upvar $namea a $nameb b
set a [expr {$a ^ $b}]
set b [expr {$a ^ $b}]
set a [expr {$a ^ $b}]
}
#e.g linesort -decreasing $data #e.g linesort -decreasing $data
proc linesort {args} { proc linesort {args} {
@ -2956,7 +3067,7 @@ namespace eval punk::lib {
# and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]* # and possibly containing a decimal point, i.e.: [:space:]*[:digit:]*\.[:digit:]*
proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} { proc delimit_number {unformattednumber {delim ","} {GroupSize 3}} {
set number [punk::objclone $unformattednumber] set number [objclone $unformattednumber]
set number [string map {_ ""} $number] set number [string map {_ ""} $number]
#normalize using expr - e.g 2e4 -> 20000.0 #normalize using expr - e.g 2e4 -> 20000.0
set number [expr {$number}] set number [expr {$number}]

35
src/vfs/_vfscommon/modules/punk/mix/base-0.1.tm

@ -4,6 +4,7 @@ package provide punk::mix::base [namespace eval punk::mix::base {
}] }]
package require punk::path package require punk::path
package require punk::lib ;#format_number etc
#base internal plumbing functions #base internal plumbing functions
namespace eval punk::mix::base { namespace eval punk::mix::base {
@ -657,16 +658,38 @@ namespace eval punk::mix::base {
#temp emission to stdout.. todo - repl telemetry channel #temp emission to stdout.. todo - repl telemetry channel
puts stdout "cksum_path: creating temporary tar archive for $path" puts stdout "cksum_path: creating temporary tar archive for $path"
puts stdout " at: $archivename .." puts -nonewline stdout " at: $archivename ..."
tar::create $archivename $target set tsstart [clock millis]
if {[set tarpath [auto_execok tar]] ne ""} {
#using an external binary is *significantly* faster than tar::create - but comes with some risks
#review - need to check behaviour/flag variances across platforms
#don't use -z flag. On at least some tar versions the zipped file will contain a timestamped subfolder of filename.tar - which ruins the checksum
#also - tar is generally faster without the compression (although this may vary depending on file size and disk speed?)
exec {*}$tarpath -cf $archivename $target ;#{*} needed in case spaces in tarpath
set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " tar -cf done ($ms ms)"
} else {
set tsstart [clock millis] ;#don't include auto_exec search time for tar::create
tar::create $archivename $target
set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " tar::create done ($ms ms)"
puts stdout " NOTE: install tar executable for potentially *much* faster directory checksum processing"
}
if {$ftype eq "file"} { if {$ftype eq "file"} {
set sizeinfo "(size [file size $target])" set sizeinfo "(size [punk::lib::format_number [file size $target]] bytes)"
} else { } else {
set sizeinfo "(file type $ftype - size unknown)" set sizeinfo "(file type $ftype - tarred size [punk::lib::format_number [file size $archivename]] bytes)"
} }
puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." set tsstart [clock millis]
puts -nonewline stdout "cksum_path: calculating cksum for $target $sizeinfo ... "
set cksum [{*}$cksum_command $archivename] set cksum [{*}$cksum_command $archivename]
#puts stdout "cksum_path: cleaning up.. " set tsend [clock millis]
set ms [expr {$tsend - $tsstart}]
puts stdout " cksum done ($ms ms)"
puts stdout " cksum: $cksum"
file delete -force $archivename file delete -force $archivename
cd $startdir cd $startdir

6
src/vfs/_vfscommon/modules/punk/repl-0.1.tm

@ -416,7 +416,11 @@ proc repl::start {inchan args} {
variable codethread_cond variable codethread_cond
tsv::unset codethread_$codethread if {[catch {
tsv::unset codethread_$codethread
} errM]} {
puts stderr " repl::start temp warning - $errM"
}
thread::cancel $codethread thread::cancel $codethread
thread::cond destroy $codethread_cond ;#race if we destroy cond before child thread has exited - as it can send a -async quit thread::cond destroy $codethread_cond ;#race if we destroy cond before child thread has exited - as it can send a -async quit
set codethread "" set codethread ""

2
src/vfs/_vfscommon/modules/punk/repo-0.1.1.tm

@ -468,7 +468,7 @@ namespace eval punk::repo {
set path [string trim [string range $ln [string length "MISSING "] end]] set path [string trim [string range $ln [string length "MISSING "] end]]
dict set pathdict $path "missing" dict set pathdict $path "missing"
} }
"EXTRA * " { "EXTRA *" {
#fossil will explicitly list files in a new folder - as opposed to git which shows just the folder #fossil will explicitly list files in a new folder - as opposed to git which shows just the folder
set path [string trim [string range $ln [string length "EXTRA "] end]] set path [string trim [string range $ln [string length "EXTRA "] end]]
dict set pathdict $path "extra" dict set pathdict $path "extra"

8
src/vfs/_vfscommon/modules/shellfilter-0.1.9.tm

@ -1658,6 +1658,14 @@ namespace eval shellfilter {
return [list $idout $iderr] return [list $idout $iderr]
} }
#eg try: set v [list #a b c]
#vs set v {#a b c}
proc list_is_canonical l {
#courtesy DKF via wiki https://wiki.tcl-lang.org/page/BNF+for+Tcl
if {[catch {llength $l}]} {return 0}
string equal $l [list {*}$l]
}
#return a dict keyed on numerical list index showing info about each element #return a dict keyed on numerical list index showing info about each element
# - particularly # - particularly
# 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list # 'wouldbrace' to indicate that the item would get braced by Tcl when added to another list

BIN
src/vfs/_vfscommon/modules/test/tomlish-1.1.1.tm

Binary file not shown.

2557
src/vfs/_vfscommon/modules/tomlish-1.1.1.tm

File diff suppressed because it is too large Load Diff

BIN
src/vfs/_vfscommon/modules/zipper-0.11.tm

Binary file not shown.

75
src/vfs/punk86.vfs/main.tcl

@ -8,6 +8,15 @@
apply { args { apply { args {
set has_zipfs [expr {[info commands tcl::zipfs::root] ne ""}]
if {$has_zipfs} {
set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}]
} else {
set has_zipfs_attached 0
}
set tclmajorv [lindex [split [info tclversion] .] 0]
#here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'. #here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'.
#we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require. #we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require.
@ -17,7 +26,7 @@ apply { args {
set topdir [file dirname $normscript] set topdir [file dirname $normscript]
set found_starkit_tcl 0 set found_starkit_tcl 0
set possible_lib_vfs_folders [glob -dir [file join $topdir lib] -type d vfs*] set possible_lib_vfs_folders [glob -nocomplain -dir [file join $topdir lib] -type d vfs*]
foreach test_folder $possible_lib_vfs_folders { foreach test_folder $possible_lib_vfs_folders {
#e.g <name_of_exe>/lib/vfs1.4.1 #e.g <name_of_exe>/lib/vfs1.4.1
#we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders. #we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders.
@ -33,9 +42,9 @@ apply { args {
set found_starkit_tcl 1 set found_starkit_tcl 1
} }
if {!$found_starkit_tcl} { if {!$found_starkit_tcl} {
#our internal search for starkit failed. #our internal 'quick' search for starkit failed.
#either we are in a pure zipfs system - or the starkit package is somewhere unexpected #either we are in a pure zipfs system - or the starkit package is somewhere more devious
#for pure zipfs - it's wasteful to perform exhaustive search for starkit #for pure zipfs - it's a little wasteful to perform exhaustive search for starkit
#review - only keep searching if not 'dev' first arg? #review - only keep searching if not 'dev' first arg?
#Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit #Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit
@ -44,7 +53,6 @@ apply { args {
puts stderr [join [package names] \n] puts stderr [join [package names] \n]
set original_packages [package names] set original_packages [package names]
if {![catch {package require starkit}]} { if {![catch {package require starkit}]} {
#known side-effects of starkit::startup #known side-effects of starkit::startup
#sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced} #sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced}
@ -67,20 +75,21 @@ apply { args {
# -- --- --- # -- --- ---
#when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it #when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it. review - for what versions of Tcl does this apply?
#known to occur in old 8.6.8 kits as well as 8.7
#review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok #review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok
#we want to be able to launch a process from the interactive shell using the same name this one was launched with.
set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe
set thisexeroot [file rootname $thisexe] ;#e.g punk86 set thisexeroot [file rootname $thisexe] ;#e.g punk86
set ::auto_execs($thisexeroot) [info nameofexecutable] set ::auto_execs($thisexeroot) [info nameofexecutable]
if {$thisexe ne $thisexeroot} { if {$thisexe ne $thisexeroot} {
#on windows make the .exe point there too
set ::auto_execs($thisexe) [info nameofexecutable] set ::auto_execs($thisexe) [info nameofexecutable]
} }
# -- --- --- # -- --- ---
set tclmajorv [lindex [split [info tclversion] .] 0]
if {[info exists ::tcl::kitpath]} { if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} {
set kp $::tcl::kitpath set kp $::tcl::kitpath
set existing_module_paths [string tolower [tcl::tm::list]] set existing_module_paths [string tolower [tcl::tm::list]]
foreach p [list modules modules_tcl$tclmajorv] { foreach p [list modules modules_tcl$tclmajorv] {
@ -94,9 +103,10 @@ apply { args {
} }
} }
} }
if {[info commands tcl::zipfs::root] ne ""} { if {$has_zipfs_attached} {
#review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. #review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. (why?)
set zipbase [file join [tcl::zipfs::root] app] ;#zipfs root has trailing slash - but file join does the right thing #default 'zipfs root' has trailing slash (//zipfs:/) - but file join does the right thing
set zipbase [file join [tcl::zipfs::root] app]
if {"$zipbase" in [tcl::zipfs::mount]} { if {"$zipbase" in [tcl::zipfs::mount]} {
set existing_module_paths [string tolower [tcl::tm::list]] set existing_module_paths [string tolower [tcl::tm::list]]
foreach p [list modules modules_tcl$tclmajorv] { foreach p [list modules modules_tcl$tclmajorv] {
@ -111,12 +121,15 @@ apply { args {
} }
} }
} }
set internal_paths [list] set internal_paths [list]
if {[info commands tcl::zipfs::root] ne ""} { if {$has_zipfs} {
set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path
lappend internal_paths $ziproot lappend internal_paths $ziproot
} }
if {[info exists ::tcl::kitpath]} { if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} {
lappend internal_paths $::tcl::kitpath lappend internal_paths $::tcl::kitpath
} }
@ -438,16 +451,46 @@ apply { args {
} }
} }
} }
#force rescan #force rescan
#catch {package require flobrudder666_nonexistant} #catch {package require flobrudder666_nonexistant}
set arglist $args set arglist $args
} }
if {[llength $arglist]} { #assert arglist has had 'dev' first arg removed if it was present.
if {[llength $arglist] == 1 && [lindex $arglist 0] eq "tclsh"} {
#called as <executable> dev tclsh or <executable> tclsh
#we would like to drop through to standard tclsh repl without launching another process? how?
#tclMain.c doesn't seem to allow it.
if {![info exists ::env(TCLSH_PIPEREPL)]} {
set is_tclsh_piperepl_env_true 0
} else {
if {[string is boolean -strict $::env(TCLSH_PIPEREPL)]} {
set is_tclsh_piperepl_env_true $::env(TCLSH_PIPEREPL)
} else {
set is_tclsh_piperepl_env_true 0
}
}
if {!$is_tclsh_piperepl_env_true} {
puts stderr "tcl_interactive: $::tcl_interactive"
puts stderr "stdin: [chan configure stdin]"
puts stderr "Environment variable TCLSH_PIPEREPL is not set or is false or is not a boolean"
} else {
#according to env TCLSH_PIPEREPL and our commandline argument - tclsh repl is desired
#check if tclsh/punk has had the piperepl patch applied - in which case tclsh(istty) should exist
if {![info exists ::tclsh(istty)]} {
puts stderr "error: the runtime doesn't appear to have been compiled with the piperepl patch"
}
}
set ::tcl_interactive 1
set ::tclsh(dorepl) 1
} elseif {[llength $arglist]} {
#pass through to shellspy commandline processor
#puts stdout "main.tcl launching app-shellspy" #puts stdout "main.tcl launching app-shellspy"
package require app-shellspy package require app-shellspy
} else { } else {
#punk shell
puts stdout "main.tcl launching app-punk. pkg names count:[llength [package names]]" puts stdout "main.tcl launching app-punk. pkg names count:[llength [package names]]"
package require app-punk package require app-punk
#app-punk starts repl #app-punk starts repl

456
src/vfs/punk86.vfs/main.tcl.xxx

@ -0,0 +1,456 @@
#main.tcl - we expect to be in the context of a zipkit or tclkit vfs attached to a tcl executable.
#review - what happens if both are somehow attached and both vfs and zipfs are available?
# - if that's even possible - we have no control here over which main.tcl was selected as we're already here
#The logic below will add appropriate package paths from starkit and zipfs vfs paths
# - and restrict package paths to those coming from a vfs (if not launched with 'dev' first arg which allows external paths to remain)
apply { args {
#here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'.
#we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require.
#standard way to avoid symlinking issues - review!
set normscript [file dirname [file normalize [file join [info script] __dummy__]]]
set normexe [file dirname [file normalize [file join [info nameofexecutable] __dummy__]]]
set topdir [file dirname $normscript]
set found_starkit_tcl 0
set possible_lib_vfs_folders [glob -dir [file join $topdir lib] -type d vfs*]
foreach test_folder $possible_lib_vfs_folders {
#e.g <name_of_exe>/lib/vfs1.4.1
#we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders.
#order of folder processing shouldn't matter (rely on order returned by 'package versions' - review)
if {[file exists $test_folder/starkit.tcl] && [file exists $test_folder/pkgIndex.tcl]} {
set dir $test_folder
source $test_folder/pkgIndex.tcl
}
}
if {[set starkitv [lindex [package versions starkit] end]] ne ""} {
#run the ifneeded script for the latest found (assuming package versions ordering is correct)
eval [package ifneeded starkit $starkitv]
set found_starkit_tcl 1
}
if {!$found_starkit_tcl} {
#our internal search for starkit failed.
#either we are in a pure zipfs system - or the starkit package is somewhere unexpected
#for pure zipfs - it's wasteful to perform exhaustive search for starkit
#review - only keep searching if not 'dev' first arg?
#Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit
#retain it so we can 'forget' the difference after our first 'package require' forces a full scan which includes some paths we may not wish to include or at least include with different preferences
puts "main.tcl 1)--> package name count: [llength [package names]]"
puts stderr [join [package names] \n]
set original_packages [package names]
if {![catch {package require starkit}]} {
#known side-effects of starkit::startup
#sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced}
#set the ::starkit::topdir variable
#if mode not starpack, then:
# - adds $::starkit::topdir/lib to the auto_path if not already present
#
#In this context (vfs attached to tcl kit executable - we expect the launch mode to be 'starkit'
set starkit_startmode [starkit::startup]
puts stderr "STARKIT MODE: $starkit_startmode"
}
puts "main.tcl 2)--> package name count: [llength [package names]]"
foreach pkg [package names] {
if {$pkg ni $original_packages} {
package forget $pkg
}
}
puts "main.tcl 3)--> package name count: [llength [package names]]"
}
# -- --- ---
#when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it
#review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok
set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe
set thisexeroot [file rootname $thisexe] ;#e.g punk86
set ::auto_execs($thisexeroot) [info nameofexecutable]
if {$thisexe ne $thisexeroot} {
set ::auto_execs($thisexe) [info nameofexecutable]
}
# -- --- ---
set tclmajorv [lindex [split [info tclversion] .] 0]
if {[info exists ::tcl::kitpath]} {
set kp $::tcl::kitpath
set existing_module_paths [string tolower [tcl::tm::list]]
foreach p [list modules modules_tcl$tclmajorv] {
if {[string tolower [file join $kp $p]] ni $existing_module_paths} {
tcl::tm::add [file join $kp $p]
}
}
foreach l [list lib lib_tcl$tclmajorv] {
if {[string tolower [file join $kp $l]] ni [string tolower $::auto_path]} {
lappend ::auto_path [file join $kp $l]
}
}
}
if {[info commands tcl::zipfs::root] ne ""} {
#review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else.
set zipbase [file join [tcl::zipfs::root] app] ;#zipfs root has trailing slash - but file join does the right thing
if {"$zipbase" in [tcl::zipfs::mount]} {
set existing_module_paths [string tolower [tcl::tm::list]]
foreach p [list modules modules_tcl$tclmajorv] {
if {[string tolower [file join $zipbase $p]] ni $existing_module_paths} {
tcl::tm::add [file join $zipbase $p]
}
}
foreach l [list lib lib_tcl$tclmajorv] {
if {[string tolower [file join $zipbase $l]] ni [string tolower $::auto_path]} {
lappend ::auto_path [file join $zipbase $l]
}
}
}
}
set internal_paths [list]
if {[info commands tcl::zipfs::root] ne ""} {
set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path
lappend internal_paths $ziproot
}
if {[info exists ::tcl::kitpath]} {
lappend internal_paths $::tcl::kitpath
}
if {[lindex $args 0] in {dev devquiet}} {
set arglist [lassign $args devmode]
set ::argv $arglist
set ::argc [llength $arglist]
if {$devmode ne "devquiet"} {
puts stderr "DEV MODE - preferencing external libraries and modules"
}
#Note regarding the use of package forget and binary packages
#If the package has loaded a binary component - then a package forget and a subsequent package require can result in both binaries being present, as seen in 'info loaded' result - potentially resulting in anomalous behaviour
#In general package forget after a package has already been required may need special handling and should be avoided where possible.
#Only a limited set of package support unloading a binary component
#We limit the use of 'package forget' here to packages that have not been loaded (whether pure-tcl or not)
#ie in this context it is used only for manipulating preferences of which packages are loaded in the first place
#Unintuitive preferencing can occur if the same package version is for example present in a tclkit and in a module or lib folder external to the kit.
#It may be desired for performance or testing reasons to preference the library outside of the kit - and raising the version number may not always be possible/practical.
#If the executable is a kit - we don't know what packages it contains or whether it allows loading from env based external paths.
#For app-punk projects - the lib/module paths based on the project being run should take preference, even if the version number is the same.
#(these are the 'info nameofexecutable' or 'info script' or 'pwd' relative paths that are added here)
#Some kits will remove lib/module paths (from auto_path & tcl::tm::list) that have been added via TCLLIBPATH / TCLX_Y_TM_PATH environment variables
#Some kits will remove those env-provided lib paths but fail to remove the env-provided module paths
#(differences in boot.tcl in the kits)
#------------------------------------------------------------------------------
#Module loading
#------------------------------------------------------------------------------
#If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them
# - but first add our other known relative modules paths - as it won't make sense to use current directory as a modulepath if it's an ancestor of one of these..
#original tm list at this point consists of whatever the kit decided + some prepended internal kit paths that punk decided on.
#we want to bring the existing external paths to the front (probably from the kit looking at various env TCL* values)
#we want to maintain the order of the internal paths.
#we then want to add our external dev paths of the total list
#assert [llength [package names]] should be small at this point ~ <10 ?
set original_tm_list [tcl::tm::list]
tcl::tm::remove {*}$original_tm_list
# -- --- --- --- --- --- --- ---
#split existing paths into internal & external
set internal_tm_dirs [list] ;#
set external_tm_dirs [list]
set lcase_internal_paths [string tolower $internal_paths]
foreach tm $original_tm_list {
set tmlower [string tolower $tm]
set is_internal 0
foreach okprefix $lcase_internal_paths {
if {[string match "$okprefix*" $tmlower]} {
lappend internal_tm_dirs $tm
set is_internal 1
break
}
}
if {!$is_internal} {
lappend external_tm_dirs $tm
}
}
# -- --- --- --- --- --- --- ---
set original_external_tm_dirs $external_tm_dirs ;#we check some of our additions and bring to front - so we refer to external list as provided by kit
#assert internal_tm_dirs and external_tm_dirs have their case preserved..
set module_folders [list]
#review - the below statement doesn't seem to be true.
#tm list first added end up later in the list - and then override earlier ones if version the same - so add pwd-relative 1st to give higher priority
#(only if Tcl has scanned all paths - see below bogus package load)
#1
#2)
# .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder)
#using normexe under assumption [info name] might be symlink - and more likely to be where the modules are located.
#we will try both relative to symlink and relative to underlying exe - with those at symlink location earlier in the list
#review - a user may have other expectations.
#case differences could represent different paths on unix-like platforms.
#It's perhaps a little unwise to configure matching paths with only case differences for a cross-platform tool .. but we should support it for those who use it and have no interest in windows - todo! review
set normexe_dir [file dirname $normexe]
if {[file tail $normexe_dir] eq "bin"} {
#underlying exe in a bin dir - backtrack 1
lappend exe_module_folders [file dirname $normexe_dir]/modules
lappend exe_module_folders [file dirname $normexe_dir]/modules_tcl$tclmajorv
} else {
lappend exe_module_folders $normexe_dir/modules
lappend exe_module_folders $normexe_dir/modules_tcl$tclmajorv
}
set nameexe_dir [file dirname [info nameofexecutable]]
#possible symlink (may resolve to same path as above - we check below to not add in twice)
if {[file tail $nameexe_dir] eq "bin"} {
lappend exe_module_folders [file dirname $nameexe_dir]/modules
lappend exe_module_folders [file dirname $nameexe_dir]/modules_tcl$tclmajorv
} else {
lappend exe_module_folders $nameexe_dir/modules
lappend exe_module_folders $nameexe_dir/modules_tcl$tclmajorv
}
foreach modulefolder $exe_module_folders {
set lc_external_tm_dirs [string tolower $external_tm_dirs]
set lc_modulefolder [string tolower $modulefolder]
if {$lc_modulefolder in [string tolower $original_external_tm_dirs]} {
#perhaps we have an env var set pointing to one of our dev foldersl. We don't want to rely on how the kit ordered it.
#bring to front if not already there.
#assert it must be present in $lc_external_tm_dirs if it's in $original_external_tm_dirs
set posn [lsearch $lc_external_tm_dirs $lc_modulefolder]
if {$posn > 0} {
#don't rely on lremove here. Not all runtimes have it and we don't want to load our forward-compatibility packages yet.
#(still need to support tcl 8.6 - and this script used in multiple kits)
set external_tm_dirs [lreplace $external_tm_dirs $posn $posn]
#don't even add it back in if it doesn't exist in filesystem
if {[file isdirectory $modulefolder]} {
set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder]
}
}
} else {
if {$lc_modulefolder ni $lc_external_tm_dirs && [file isdirectory $modulefolder]} {
set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder] ;#linsert seems faster than 'concat [list $modulefolder] $external_tm_dirs' - review
}
}
}
if {![llength $exe_module_folders]} {
puts stderr "Warning - no 'modules' or 'modules_tcl$tclmajorv' folders found relative to executable (or it's symlink if any)"
}
#add lib and lib_tcl8 lib_tcl9 etc based on tclmajorv
#libs are appended to end - so add higher priority libraries last (opposite to modules)
#auto_path - add exe-relative after exe-relative path
if {"windows" eq $::tcl_platform(platform)} {
#case differences dont matter - but can stop us finding path in auto_path
foreach libsub [list lib_tcl$tclmajorv lib] {
if {[file tail $nameexe_dir] eq "bin"} {
set libfolder [file dirname $nameexe_dir]/$libsub
} else {
set libfolder $nameexe_dir/$libsub
}
if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
}
# -------------
if {[file tail $normexe_dir] eq "bin"} {
set libfolder [file dirname $normexe_dir]/$libsub
} else {
set libfolder $normexe_dir/$libsub
}
if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
}
# -------------
set libfolder [pwd]/$libsub
if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
}
}
} else {
#on other platforms, case differences could represent different paths
foreach libsub [list lib_tcl$tclmajorv lib] {
if {[file tail $nameexe_dir] eq "bin"} {
set libfolder [file dirname $nameexe_dir]/$libsub
} else {
set libfolder $nameexe_dir/$libsub
}
if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
}
# -------------
if {[file tail $normexe_dir] eq "bin"} {
set libfolder [file dirname $normexe_dir]/$libsub
} else {
set libfolder $normexe_dir/$libsub
}
if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
}
# -------------
set libfolder [pwd]/$libsub
if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
}
}
}
#2) support developer running from a folder containing *.tm files they want to make available
# could cause problems if user happens to be in a subdirectory of a tm folder structure as namespaced modules won't work if not at a tm path root.
#The current dir could also be a subdirectory of an existing tm_dir which would fail during tcl::tm::add - we will need to wrap all additions in catch
set currentdir_modules [glob -nocomplain -dir [pwd] -type f -tail *.tm]
#we assume [pwd] will always return an external (not kit) path at this point - REVIEW
if {[llength $currentdir_modules]} {
#now add current dir (if no conflict with above)
#catch {tcl::tm::add [pwd]}
set external_tm_dirs [linsert $external_tm_dirs 0 $currentdir_modules]
if {[file exists [pwd]/modules] || [file exists [pwd]/modules_tcl$tclmajorv]} {
puts stderr "WARNING: modules or modules_tcl$tclmajorv folders not added to tcl::tm::path due to modules found in current workding dir [pwd]"
}
} else {
#modules or modules_tclX subdir relative to cwd cannot be added if [pwd] has been added
set cwd_modules_folder [file normalize [file join [pwd] modules]]
if {[file isdirectory $cwd_modules_folder]} {
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} {
#prepend
set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder]
}
}
set cwd_modules_folder [file normalize [file join [pwd] modules_tcl$tclmajorv]]
if {[file isdirectory $cwd_modules_folder]} {
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} {
#prepend
set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder]
}
}
}
#assert tcl::tm::list still empty here
#restore module paths
#add internals first as in 'dev' mode (dev as first argument on launch) we preference external modules
#note use of lreverse to maintain same order
foreach p [lreverse $internal_tm_dirs] {
if {$p ni [tcl::tm::list]} {
#the prior tm paths go to the head of the list.
#They are processed first.. but an item of same version later in the list will override one at the head. (depending on when list was scanned) REVIEW - true statement???
#addition can fail if one path is a prefix of another
if {[catch {tcl::tm::add $p} errM]} {
puts stderr "Failed to add internal module dir '$p' to tcl::tm::list\n$errM"
}
}
}
foreach p [lreverse $external_tm_dirs] {
if {$p ni [tcl::tm::list]} {
if {[catch {tcl::tm::add $p} errM]} {
puts stderr "Failed to add external module dir '$p' to tcl::tm::list\n$errM"
}
}
}
#------------------------------------------------------------------------------
#REVIEW
#package require a bogus package to ensure Tcl scans the whole auto_path/tm list - otherwise a lower-versioned module earlier in the path may be loaded
#This seems to take not insignificant time depending on size of auto_path and tcl::tm::list (e.g 2023 i9 ssd 100ms) - but seems unavoidable for now
#catch {package require flobrudder666_nonexistant}
#------------------------------------------------------------------------------
} else {
#Tcl_Init will most likely have set up some external paths
#As our app has been started without the 'dev' first arg - we will prune paths that are not zipfs or tclkit
set new_auto_path [list]
#review - case insensitive ok for windows - but could cause issues on other platforms?
foreach ap $::auto_path {
set aplower [string tolower $ap]
foreach okprefix $internal_paths {
if {[string match "[string tolower $okprefix]*" $aplower]} {
lappend new_auto_path $ap
break
}
}
}
set ::auto_path $new_auto_path
set new_tm_list [list]
foreach tm [tcl::tm::list] {
set tmlower [string tolower $tm]
foreach okprefix $internal_paths {
if {[string match "[string tolower $okprefix]*" $tmlower]} {
lappend new_tm_list $tm
break
}
}
}
tcl::tm::remove {*}[tcl::tm::list]
tcl::tm::add {*}[lreverse $new_tm_list]
#If it looks like we are running the vfs/xxx.vfs/main.tcl from an external tclsh - try to use vfs folders to simulate kit state
#set script_relative_lib [file normalize [file join [file dirname [info script]] lib]]
set scriptdir [file dirname [info script]]
if {![string match //zipfs:/* $scriptdir] && ![info exists ::tcl::kitpath]} {
#presumably running the vfs/xxx.vfs/main.tcl script using a non-kit tclsh that doesn't have starkit lib available.. lets see if we can move forward anyway
set vfscontainer [file normalize [file dirname $scriptdir]]
set vfscommon [file join $vfscontainer _vfscommon]
set vfsdir [file normalize $scriptdir]
set projectroot [file dirname [file dirname $vfscontainer]] ;#back below src/vfs/xxx.vfs/main.tcl
puts stdout "no starkit. projectroot?: $projectroot"
puts stdout "info lib: [info library]"
#add back the info lib reported by the executable.. as we can't access the one built into a kit
if {[file exists [info library]]} {
lappend ::auto_path [info library]
}
set lib_types [list lib lib_tcl$tclmajorv]
foreach l $lib_types {
set lib [file join $vfsdir $l]
if {[file exists $lib] && [string tolower $lib] ni [string tolower $::auto_path]} {
lappend ::auto_path $lib
}
}
foreach l $lib_types {
set lib [file join $vfscommon $l]
if {[file exists $lib] && [string tolower $lib] ni [string tolower $::auto_path]} {
lappend ::auto_path $lib
}
}
set mod_types [list modules modules_tcl$tclmajorv]
foreach m $mod_types {
set modpath [file join $vfsdir $m]
if {[file exists $modpath] && [string tolower $modpath] ni [string tolower [tcl::tm::list]]} {
tcl::tm::add $modpath
}
}
foreach m $mod_types {
set modpath [file join $vfscommon $m]
if {[file exists $modpath] && [string tolower $modpath] ni [string tolower [tcl::tm::list]]} {
tcl::tm::add $modpath
}
}
}
#force rescan
#catch {package require flobrudder666_nonexistant}
set arglist $args
}
if {[llength $arglist]} {
#puts stdout "main.tcl launching app-shellspy"
package require app-shellspy
} else {
puts stdout "main.tcl launching app-punk. pkg names count:[llength [package names]]"
package require app-punk
#app-punk starts repl
#repl::start stdin -title "main.tcl"
}
}} {*}$::argv

57
src/vfs/punk86bawt.vfs/main.tcl

@ -8,6 +8,15 @@
apply { args { apply { args {
set has_zipfs [expr {[info commands tcl::zipfs::root] ne ""}]
if {$has_zipfs} {
set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}]
} else {
set has_zipfs_attached 0
}
set tclmajorv [lindex [split [info tclversion] .] 0]
#here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'. #here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'.
#we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require. #we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require.
@ -17,7 +26,7 @@ apply { args {
set topdir [file dirname $normscript] set topdir [file dirname $normscript]
set found_starkit_tcl 0 set found_starkit_tcl 0
set possible_lib_vfs_folders [glob -dir [file join $topdir lib] -type d vfs*] set possible_lib_vfs_folders [glob -nocomplain -dir [file join $topdir lib] -type d vfs*]
foreach test_folder $possible_lib_vfs_folders { foreach test_folder $possible_lib_vfs_folders {
#e.g <name_of_exe>/lib/vfs1.4.1 #e.g <name_of_exe>/lib/vfs1.4.1
#we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders. #we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders.
@ -33,9 +42,9 @@ apply { args {
set found_starkit_tcl 1 set found_starkit_tcl 1
} }
if {!$found_starkit_tcl} { if {!$found_starkit_tcl} {
#our internal search for starkit failed. #our internal 'quick' search for starkit failed.
#either we are in a pure zipfs system - or the starkit package is somewhere unexpected #either we are in a pure zipfs system - or the starkit package is somewhere more devious
#for pure zipfs - it's wasteful to perform exhaustive search for starkit #for pure zipfs - it's a little wasteful to perform exhaustive search for starkit
#review - only keep searching if not 'dev' first arg? #review - only keep searching if not 'dev' first arg?
#Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit #Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit
@ -44,7 +53,6 @@ apply { args {
puts stderr [join [package names] \n] puts stderr [join [package names] \n]
set original_packages [package names] set original_packages [package names]
if {![catch {package require starkit}]} { if {![catch {package require starkit}]} {
#known side-effects of starkit::startup #known side-effects of starkit::startup
#sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced} #sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced}
@ -67,20 +75,21 @@ apply { args {
# -- --- --- # -- --- ---
#when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it #when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it. review - for what versions of Tcl does this apply?
#known to occur in old 8.6.8 kits as well as 8.7
#review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok #review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok
#we want to be able to launch a process from the interactive shell using the same name this one was launched with.
set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe
set thisexeroot [file rootname $thisexe] ;#e.g punk86 set thisexeroot [file rootname $thisexe] ;#e.g punk86
set ::auto_execs($thisexeroot) [info nameofexecutable] set ::auto_execs($thisexeroot) [info nameofexecutable]
if {$thisexe ne $thisexeroot} { if {$thisexe ne $thisexeroot} {
#on windows make the .exe point there too
set ::auto_execs($thisexe) [info nameofexecutable] set ::auto_execs($thisexe) [info nameofexecutable]
} }
# -- --- --- # -- --- ---
set tclmajorv [lindex [split [info tclversion] .] 0]
if {[info exists ::tcl::kitpath]} { if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} {
set kp $::tcl::kitpath set kp $::tcl::kitpath
set existing_module_paths [string tolower [tcl::tm::list]] set existing_module_paths [string tolower [tcl::tm::list]]
foreach p [list modules modules_tcl$tclmajorv] { foreach p [list modules modules_tcl$tclmajorv] {
@ -94,9 +103,10 @@ apply { args {
} }
} }
} }
if {[info commands tcl::zipfs::root] ne ""} { if {$has_zipfs_attached} {
#review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. #review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. (why?)
set zipbase [file join [tcl::zipfs::root] app] ;#zipfs root has trailing slash - but file join does the right thing #default 'zipfs root' has trailing slash (//zipfs:/) - but file join does the right thing
set zipbase [file join [tcl::zipfs::root] app]
if {"$zipbase" in [tcl::zipfs::mount]} { if {"$zipbase" in [tcl::zipfs::mount]} {
set existing_module_paths [string tolower [tcl::tm::list]] set existing_module_paths [string tolower [tcl::tm::list]]
foreach p [list modules modules_tcl$tclmajorv] { foreach p [list modules modules_tcl$tclmajorv] {
@ -111,12 +121,15 @@ apply { args {
} }
} }
} }
set internal_paths [list] set internal_paths [list]
if {[info commands tcl::zipfs::root] ne ""} { if {$has_zipfs} {
set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path
lappend internal_paths $ziproot lappend internal_paths $ziproot
} }
if {[info exists ::tcl::kitpath]} { if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} {
lappend internal_paths $::tcl::kitpath lappend internal_paths $::tcl::kitpath
} }
@ -438,16 +451,28 @@ apply { args {
} }
} }
} }
#force rescan #force rescan
#catch {package require flobrudder666_nonexistant} #catch {package require flobrudder666_nonexistant}
set arglist $args set arglist $args
} }
if {[llength $arglist]} { #assert arglist has had 'dev' first arg removed if it was present.
if {[llength $arglist] == 1 && [lindex $arglist 0] eq "tclsh"} {
#called as <executable> dev tclsh or <executable> tclsh
#we would like to drop through to standard tclsh repl without launching another process? how?
#tclMain.c doesn't seem to allow it.
puts "tcl_interactive: $::tcl_interactive"
set ::tcl_interactive 1
puts "stdin: [chan configure stdin]"
set ::tclsh(dorepl) 1
} elseif {[llength $arglist]} {
#pass through to shellspy commandline processor
#puts stdout "main.tcl launching app-shellspy" #puts stdout "main.tcl launching app-shellspy"
package require app-shellspy package require app-shellspy
} else { } else {
#punk shell
puts stdout "main.tcl launching app-punk. pkg names count:[llength [package names]]" puts stdout "main.tcl launching app-punk. pkg names count:[llength [package names]]"
package require app-punk package require app-punk
#app-punk starts repl #app-punk starts repl

57
src/vfs/punk8win.vfs/main.tcl

@ -8,6 +8,15 @@
apply { args { apply { args {
set has_zipfs [expr {[info commands tcl::zipfs::root] ne ""}]
if {$has_zipfs} {
set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}]
} else {
set has_zipfs_attached 0
}
set tclmajorv [lindex [split [info tclversion] .] 0]
#here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'. #here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'.
#we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require. #we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require.
@ -17,7 +26,7 @@ apply { args {
set topdir [file dirname $normscript] set topdir [file dirname $normscript]
set found_starkit_tcl 0 set found_starkit_tcl 0
set possible_lib_vfs_folders [glob -dir [file join $topdir lib] -type d vfs*] set possible_lib_vfs_folders [glob -nocomplain -dir [file join $topdir lib] -type d vfs*]
foreach test_folder $possible_lib_vfs_folders { foreach test_folder $possible_lib_vfs_folders {
#e.g <name_of_exe>/lib/vfs1.4.1 #e.g <name_of_exe>/lib/vfs1.4.1
#we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders. #we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders.
@ -33,9 +42,9 @@ apply { args {
set found_starkit_tcl 1 set found_starkit_tcl 1
} }
if {!$found_starkit_tcl} { if {!$found_starkit_tcl} {
#our internal search for starkit failed. #our internal 'quick' search for starkit failed.
#either we are in a pure zipfs system - or the starkit package is somewhere unexpected #either we are in a pure zipfs system - or the starkit package is somewhere more devious
#for pure zipfs - it's wasteful to perform exhaustive search for starkit #for pure zipfs - it's a little wasteful to perform exhaustive search for starkit
#review - only keep searching if not 'dev' first arg? #review - only keep searching if not 'dev' first arg?
#Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit #Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit
@ -44,7 +53,6 @@ apply { args {
puts stderr [join [package names] \n] puts stderr [join [package names] \n]
set original_packages [package names] set original_packages [package names]
if {![catch {package require starkit}]} { if {![catch {package require starkit}]} {
#known side-effects of starkit::startup #known side-effects of starkit::startup
#sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced} #sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced}
@ -67,20 +75,21 @@ apply { args {
# -- --- --- # -- --- ---
#when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it #when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it. review - for what versions of Tcl does this apply?
#known to occur in old 8.6.8 kits as well as 8.7
#review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok #review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok
#we want to be able to launch a process from the interactive shell using the same name this one was launched with.
set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe
set thisexeroot [file rootname $thisexe] ;#e.g punk86 set thisexeroot [file rootname $thisexe] ;#e.g punk86
set ::auto_execs($thisexeroot) [info nameofexecutable] set ::auto_execs($thisexeroot) [info nameofexecutable]
if {$thisexe ne $thisexeroot} { if {$thisexe ne $thisexeroot} {
#on windows make the .exe point there too
set ::auto_execs($thisexe) [info nameofexecutable] set ::auto_execs($thisexe) [info nameofexecutable]
} }
# -- --- --- # -- --- ---
set tclmajorv [lindex [split [info tclversion] .] 0]
if {[info exists ::tcl::kitpath]} { if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} {
set kp $::tcl::kitpath set kp $::tcl::kitpath
set existing_module_paths [string tolower [tcl::tm::list]] set existing_module_paths [string tolower [tcl::tm::list]]
foreach p [list modules modules_tcl$tclmajorv] { foreach p [list modules modules_tcl$tclmajorv] {
@ -94,9 +103,10 @@ apply { args {
} }
} }
} }
if {[info commands tcl::zipfs::root] ne ""} { if {$has_zipfs_attached} {
#review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. #review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. (why?)
set zipbase [file join [tcl::zipfs::root] app] ;#zipfs root has trailing slash - but file join does the right thing #default 'zipfs root' has trailing slash (//zipfs:/) - but file join does the right thing
set zipbase [file join [tcl::zipfs::root] app]
if {"$zipbase" in [tcl::zipfs::mount]} { if {"$zipbase" in [tcl::zipfs::mount]} {
set existing_module_paths [string tolower [tcl::tm::list]] set existing_module_paths [string tolower [tcl::tm::list]]
foreach p [list modules modules_tcl$tclmajorv] { foreach p [list modules modules_tcl$tclmajorv] {
@ -111,12 +121,15 @@ apply { args {
} }
} }
} }
set internal_paths [list] set internal_paths [list]
if {[info commands tcl::zipfs::root] ne ""} { if {$has_zipfs} {
set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path
lappend internal_paths $ziproot lappend internal_paths $ziproot
} }
if {[info exists ::tcl::kitpath]} { if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} {
lappend internal_paths $::tcl::kitpath lappend internal_paths $::tcl::kitpath
} }
@ -438,16 +451,28 @@ apply { args {
} }
} }
} }
#force rescan #force rescan
#catch {package require flobrudder666_nonexistant} #catch {package require flobrudder666_nonexistant}
set arglist $args set arglist $args
} }
if {[llength $arglist]} { #assert arglist has had 'dev' first arg removed if it was present.
if {[llength $arglist] == 1 && [lindex $arglist 0] eq "tclsh"} {
#called as <executable> dev tclsh or <executable> tclsh
#we would like to drop through to standard tclsh repl without launching another process? how?
#tclMain.c doesn't seem to allow it.
puts "tcl_interactive: $::tcl_interactive"
set ::tcl_interactive 1
puts "stdin: [chan configure stdin]"
set ::tclsh(dorepl) 1
} elseif {[llength $arglist]} {
#pass through to shellspy commandline processor
#puts stdout "main.tcl launching app-shellspy" #puts stdout "main.tcl launching app-shellspy"
package require app-shellspy package require app-shellspy
} else { } else {
#punk shell
puts stdout "main.tcl launching app-punk. pkg names count:[llength [package names]]" puts stdout "main.tcl launching app-punk. pkg names count:[llength [package names]]"
package require app-punk package require app-punk
#app-punk starts repl #app-punk starts repl

345
src/vfs/punk9linux.vfs/main.tcl

@ -1,22 +1,95 @@
if {![catch {package require starkit}]} { #main.tcl - we expect to be in the context of a zipkit or tclkit vfs attached to a tcl executable.
starkit::startup #review - what happens if both are somehow attached and both vfs and zipfs are available?
} # - if that's even possible - we have no control here over which main.tcl was selected as we're already here
#The logic below will add appropriate package paths from starkit and zipfs vfs paths
# - and restrict package paths to those coming from a vfs (if not launched with 'dev' first arg which allows external paths to remain)
apply { args { apply { args {
set has_zipfs [expr {[info commands tcl::zipfs::root] ne ""}]
if {$has_zipfs} {
set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}]
} else {
set has_zipfs_attached 0
}
set tclmajorv [lindex [split [info tclversion] .] 0]
#here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'.
#we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require.
#standard way to avoid symlinking issues - review!
set normscript [file dirname [file normalize [file join [info script] __dummy__]]]
set normexe [file dirname [file normalize [file join [info nameofexecutable] __dummy__]]]
set topdir [file dirname $normscript]
set found_starkit_tcl 0
set possible_lib_vfs_folders [glob -nocomplain -dir [file join $topdir lib] -type d vfs*]
foreach test_folder $possible_lib_vfs_folders {
#e.g <name_of_exe>/lib/vfs1.4.1
#we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders.
#order of folder processing shouldn't matter (rely on order returned by 'package versions' - review)
if {[file exists $test_folder/starkit.tcl] && [file exists $test_folder/pkgIndex.tcl]} {
set dir $test_folder
source $test_folder/pkgIndex.tcl
}
}
if {[set starkitv [lindex [package versions starkit] end]] ne ""} {
#run the ifneeded script for the latest found (assuming package versions ordering is correct)
eval [package ifneeded starkit $starkitv]
set found_starkit_tcl 1
}
if {!$found_starkit_tcl} {
#our internal 'quick' search for starkit failed.
#either we are in a pure zipfs system - or the starkit package is somewhere more devious
#for pure zipfs - it's a little wasteful to perform exhaustive search for starkit
#review - only keep searching if not 'dev' first arg?
#Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit
#retain it so we can 'forget' the difference after our first 'package require' forces a full scan which includes some paths we may not wish to include or at least include with different preferences
puts "main.tcl 1)--> package name count: [llength [package names]]"
puts stderr [join [package names] \n]
set original_packages [package names]
if {![catch {package require starkit}]} {
#known side-effects of starkit::startup
#sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced}
#set the ::starkit::topdir variable
#if mode not starpack, then:
# - adds $::starkit::topdir/lib to the auto_path if not already present
#
#In this context (vfs attached to tcl kit executable - we expect the launch mode to be 'starkit'
set starkit_startmode [starkit::startup]
puts stderr "STARKIT MODE: $starkit_startmode"
}
puts "main.tcl 2)--> package name count: [llength [package names]]"
foreach pkg [package names] {
if {$pkg ni $original_packages} {
package forget $pkg
}
}
puts "main.tcl 3)--> package name count: [llength [package names]]"
}
# -- --- --- # -- --- ---
#when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it #when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it. review - for what versions of Tcl does this apply?
set thisexe [file tail [info nameofexecutable]] #known to occur in old 8.6.8 kits as well as 8.7
set thisexeroot [file rootname $thisexe] #review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok
#we want to be able to launch a process from the interactive shell using the same name this one was launched with.
set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe
set thisexeroot [file rootname $thisexe] ;#e.g punk86
set ::auto_execs($thisexeroot) [info nameofexecutable] set ::auto_execs($thisexeroot) [info nameofexecutable]
if {$thisexe ne $thisexeroot} { if {$thisexe ne $thisexeroot} {
#on windows make the .exe point there too
set ::auto_execs($thisexe) [info nameofexecutable] set ::auto_execs($thisexe) [info nameofexecutable]
} }
# -- --- --- # -- --- ---
set tclmajorv [lindex [split [info tclversion] .] 0]
if {[info exists ::tcl::kitpath]} { if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} {
set kp $::tcl::kitpath set kp $::tcl::kitpath
set existing_module_paths [string tolower [tcl::tm::list]] set existing_module_paths [string tolower [tcl::tm::list]]
foreach p [list modules modules_tcl$tclmajorv] { foreach p [list modules modules_tcl$tclmajorv] {
@ -30,9 +103,10 @@ apply { args {
} }
} }
} }
if {[info commands tcl::zipfs::root] ne ""} { if {$has_zipfs_attached} {
#review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. #review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. (why?)
set zipbase [file join [tcl::zipfs::root] app] ;#zipfs root has trailing slash - but file join does the right thing #default 'zipfs root' has trailing slash (//zipfs:/) - but file join does the right thing
set zipbase [file join [tcl::zipfs::root] app]
if {"$zipbase" in [tcl::zipfs::mount]} { if {"$zipbase" in [tcl::zipfs::mount]} {
set existing_module_paths [string tolower [tcl::tm::list]] set existing_module_paths [string tolower [tcl::tm::list]]
foreach p [list modules modules_tcl$tclmajorv] { foreach p [list modules modules_tcl$tclmajorv] {
@ -48,6 +122,17 @@ apply { args {
} }
} }
set internal_paths [list]
if {$has_zipfs} {
set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path
lappend internal_paths $ziproot
}
if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} {
lappend internal_paths $::tcl::kitpath
}
if {[lindex $args 0] in {dev devquiet}} { if {[lindex $args 0] in {dev devquiet}} {
set arglist [lassign $args devmode] set arglist [lassign $args devmode]
set ::argv $arglist set ::argv $arglist
@ -78,40 +163,99 @@ apply { args {
#If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them #If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them
# - but first add our other known relative modules paths - as it won't make sense to use current directory as a modulepath if it's an ancestor of one of these.. # - but first add our other known relative modules paths - as it won't make sense to use current directory as a modulepath if it's an ancestor of one of these..
#original tm list at this point consists of whatever the kit decided + some prepended internal kit paths that punk decided on.
#we want to bring the existing external paths to the front (probably from the kit looking at various env TCL* values)
#we want to maintain the order of the internal paths.
#we then want to add our external dev paths of the total list
#assert [llength [package names]] should be small at this point ~ <10 ?
set original_tm_list [tcl::tm::list] set original_tm_list [tcl::tm::list]
tcl::tm::remove {*}$original_tm_list tcl::tm::remove {*}$original_tm_list
# -- --- --- --- --- --- --- ---
#split existing paths into internal & external
set internal_tm_dirs [list] ;#
set external_tm_dirs [list]
set lcase_internal_paths [string tolower $internal_paths]
foreach tm $original_tm_list {
set tmlower [string tolower $tm]
set is_internal 0
foreach okprefix $lcase_internal_paths {
if {[string match "$okprefix*" $tmlower]} {
lappend internal_tm_dirs $tm
set is_internal 1
break
}
}
if {!$is_internal} {
lappend external_tm_dirs $tm
}
}
# -- --- --- --- --- --- --- ---
set original_external_tm_dirs $external_tm_dirs ;#we check some of our additions and bring to front - so we refer to external list as provided by kit
#assert internal_tm_dirs and external_tm_dirs have their case preserved..
set module_folders [list] set module_folders [list]
#review - the below statement doesn't seem to be true.
#tm list first added end up later in the list - and then override earlier ones if version the same - so add pwd-relative 1st to give higher priority #tm list first added end up later in the list - and then override earlier ones if version the same - so add pwd-relative 1st to give higher priority
#(only if Tcl has scanned all paths - see below bogus package load) #(only if Tcl has scanned all paths - see below bogus package load)
#1 #1
if {[file isdirectory [pwd]/modules]} {
catch {tcl::tm::add [pwd]/modules}
}
#2) #2)
if {[string match "*.vfs/*" [file normalize [info script]]]} { # .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder)
#src/xxx.vfs/lib/app-punk/repl.tcl #using normexe under assumption [info name] might be symlink - and more likely to be where the modules are located.
# assume if calling directly into .vfs that the user would prefer to use src/modules - so go up 4 levels #we will try both relative to symlink and relative to underlying exe - with those at symlink location earlier in the list
#set srcmodulefolder [file dirname [file dirname [file dirname [file dirname [file normalize [info script]]]]]]/modules #review - a user may have other expectations.
# - the src/modules folder doesn't contain important modules such as vendormodules - so the above probably isn't that useful
set srcfolder [file dirname [file dirname [file dirname [file dirname [file normalize [info script]]]]]] #case differences could represent different paths on unix-like platforms.
lappend module_folders [file join [file dirname $srcfolder] modules] ;#modules folder at same level as src folder #It's perhaps a little unwise to configure matching paths with only case differences for a cross-platform tool .. but we should support it for those who use it and have no interest in windows - todo! review
lappend module_folders [file join [file dirname $srcfolder] modules_tcl$tclmajorv] set normexe_dir [file dirname $normexe]
if {[file tail $normexe_dir] eq "bin"} {
#underlying exe in a bin dir - backtrack 1
lappend exe_module_folders [file dirname $normexe_dir]/modules
lappend exe_module_folders [file dirname $normexe_dir]/modules_tcl$tclmajorv
} else { } else {
# .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) lappend exe_module_folders $normexe_dir/modules
lappend module_folders [file dirname [file dirname [info nameofexecutable]]]/modules lappend exe_module_folders $normexe_dir/modules_tcl$tclmajorv
lappend module_folders [file dirname [file dirname [info nameofexecutable]]]/modules_tcl$tclmajorv
} }
foreach modulefolder $module_folders { set nameexe_dir [file dirname [info nameofexecutable]]
if {[file isdirectory $modulefolder]} { #possible symlink (may resolve to same path as above - we check below to not add in twice)
tcl::tm::add $modulefolder if {[file tail $nameexe_dir] eq "bin"} {
lappend exe_module_folders [file dirname $nameexe_dir]/modules
lappend exe_module_folders [file dirname $nameexe_dir]/modules_tcl$tclmajorv
} else {
lappend exe_module_folders $nameexe_dir/modules
lappend exe_module_folders $nameexe_dir/modules_tcl$tclmajorv
}
foreach modulefolder $exe_module_folders {
set lc_external_tm_dirs [string tolower $external_tm_dirs]
set lc_modulefolder [string tolower $modulefolder]
if {$lc_modulefolder in [string tolower $original_external_tm_dirs]} {
#perhaps we have an env var set pointing to one of our dev foldersl. We don't want to rely on how the kit ordered it.
#bring to front if not already there.
#assert it must be present in $lc_external_tm_dirs if it's in $original_external_tm_dirs
set posn [lsearch $lc_external_tm_dirs $lc_modulefolder]
if {$posn > 0} {
#don't rely on lremove here. Not all runtimes have it and we don't want to load our forward-compatibility packages yet.
#(still need to support tcl 8.6 - and this script used in multiple kits)
set external_tm_dirs [lreplace $external_tm_dirs $posn $posn]
#don't even add it back in if it doesn't exist in filesystem
if {[file isdirectory $modulefolder]} {
set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder]
}
}
} else { } else {
puts stderr "Warning unable to find module folder at: $modulefolder" if {$lc_modulefolder ni $lc_external_tm_dirs && [file isdirectory $modulefolder]} {
set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder] ;#linsert seems faster than 'concat [list $modulefolder] $external_tm_dirs' - review
}
} }
} }
if {![llength $exe_module_folders]} {
puts stderr "Warning - no 'modules' or 'modules_tcl$tclmajorv' folders found relative to executable (or it's symlink if any)"
}
@ -121,72 +265,121 @@ apply { args {
if {"windows" eq $::tcl_platform(platform)} { if {"windows" eq $::tcl_platform(platform)} {
#case differences dont matter - but can stop us finding path in auto_path #case differences dont matter - but can stop us finding path in auto_path
foreach libsub [list lib_tcl$tclmajorv lib] { foreach libsub [list lib_tcl$tclmajorv lib] {
set libfolder [file dirname [file dirname [info nameofexecutable]]]/$libsub if {[file tail $nameexe_dir] eq "bin"} {
if {[string tolower $libfolder] ni [string tolower $::auto_path]} { set libfolder [file dirname $nameexe_dir]/$libsub
if {[file isdirectory $libfolder]} { } else {
lappend ::auto_path $libfolder set libfolder $nameexe_dir/$libsub
} }
if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
}
# -------------
if {[file tail $normexe_dir] eq "bin"} {
set libfolder [file dirname $normexe_dir]/$libsub
} else {
set libfolder $normexe_dir/$libsub
} }
if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
}
# -------------
set libfolder [pwd]/$libsub set libfolder [pwd]/$libsub
if {[string tolower $libfolder] ni [string tolower $::auto_path]} { if {[string tolower $libfolder] ni [string tolower $::auto_path] && [file isdirectory $libfolder]} {
if {[file isdirectory $libfolder]} { lappend ::auto_path $libfolder
lappend ::auto_path $libfolder
}
} }
} }
} else { } else {
#on other platforms, case differences could represent different paths #on other platforms, case differences could represent different paths
foreach libsub [list lib_tcl$tclmajorv lib] { foreach libsub [list lib_tcl$tclmajorv lib] {
set libfolder [file dirname [file dirname [info nameofexecutable]]]/$libsub if {[file tail $nameexe_dir] eq "bin"} {
if {$libfolder ni $::auto_path} { set libfolder [file dirname $nameexe_dir]/$libsub
if {[file isdirectory $libfolder]} { } else {
lappend ::auto_path $libfolder set libfolder $nameexe_dir/$libsub
} }
if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
}
# -------------
if {[file tail $normexe_dir] eq "bin"} {
set libfolder [file dirname $normexe_dir]/$libsub
} else {
set libfolder $normexe_dir/$libsub
}
if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} {
lappend ::auto_path $libfolder
} }
# -------------
set libfolder [pwd]/$libsub set libfolder [pwd]/$libsub
if {$libfolder ni $::auto_path} { if {$libfolder ni $::auto_path && [file isdirectory $libfolder]} {
if {[file isdirectory $libfolder]} { lappend ::auto_path $libfolder
lappend ::auto_path $libfolder
}
} }
} }
} }
#2) #2) support developer running from a folder containing *.tm files they want to make available
# could cause problems if user happens to be in a subdirectory of a tm folder structure as namespaced modules won't work if not at a tm path root.
#The current dir could also be a subdirectory of an existing tm_dir which would fail during tcl::tm::add - we will need to wrap all additions in catch
set currentdir_modules [glob -nocomplain -dir [pwd] -type f -tail *.tm] set currentdir_modules [glob -nocomplain -dir [pwd] -type f -tail *.tm]
#we assume [pwd] will always return an external (not kit) path at this point - REVIEW
if {[llength $currentdir_modules]} { if {[llength $currentdir_modules]} {
#now add current dir (if no conflict with above) #now add current dir (if no conflict with above)
catch {tcl::tm::add [pwd]} #catch {tcl::tm::add [pwd]}
set external_tm_dirs [linsert $external_tm_dirs 0 $currentdir_modules]
if {[file exists [pwd]/modules] || [file exists [pwd]/modules_tcl$tclmajorv]} {
puts stderr "WARNING: modules or modules_tcl$tclmajorv folders not added to tcl::tm::path due to modules found in current workding dir [pwd]"
}
} else {
#modules or modules_tclX subdir relative to cwd cannot be added if [pwd] has been added
set cwd_modules_folder [file normalize [file join [pwd] modules]]
if {[file isdirectory $cwd_modules_folder]} {
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} {
#prepend
set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder]
}
}
set cwd_modules_folder [file normalize [file join [pwd] modules_tcl$tclmajorv]]
if {[file isdirectory $cwd_modules_folder]} {
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} {
#prepend
set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder]
}
}
} }
#assert tcl::tm::list still empty here
#restore module paths #restore module paths
set tm_list_now [tcl::tm::list] #add internals first as in 'dev' mode (dev as first argument on launch) we preference external modules
foreach p [lreverse $original_tm_list] { #note use of lreverse to maintain same order
if {$p ni $tm_list_now} { foreach p [lreverse $internal_tm_dirs] {
if {$p ni [tcl::tm::list]} {
#the prior tm paths go to the head of the list. #the prior tm paths go to the head of the list.
#They are processed first.. but an item of same version later in the list will override one at the head. (depending on when list was scanned) #They are processed first.. but an item of same version later in the list will override one at the head. (depending on when list was scanned) REVIEW - true statement???
tcl::tm::add $p #addition can fail if one path is a prefix of another
if {[catch {tcl::tm::add $p} errM]} {
puts stderr "Failed to add internal module dir '$p' to tcl::tm::list\n$errM"
}
} }
} }
foreach p [lreverse $external_tm_dirs] {
if {$p ni [tcl::tm::list]} {
if {[catch {tcl::tm::add $p} errM]} {
puts stderr "Failed to add external module dir '$p' to tcl::tm::list\n$errM"
}
}
}
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
#REVIEW
#package require a bogus package to ensure Tcl scans the whole auto_path/tm list - otherwise a lower-versioned module earlier in the path may be loaded #package require a bogus package to ensure Tcl scans the whole auto_path/tm list - otherwise a lower-versioned module earlier in the path may be loaded
#This seems to take not insignificant time depending on size of auto_path and tcl::tm::list (e.g 2023 i9 ssd 100ms) - but seems unavoidable for now #This seems to take not insignificant time depending on size of auto_path and tcl::tm::list (e.g 2023 i9 ssd 100ms) - but seems unavoidable for now
catch {package require flobrudder666_nonexistant} #catch {package require flobrudder666_nonexistant}
#------------------------------------------------------------------------------ #------------------------------------------------------------------------------
} else { } else {
#Tcl_Init will most likely have set up some external paths #Tcl_Init will most likely have set up some external paths
#As our app has been started without the 'dev' first arg - we will prune paths that are not zipfs or tclkit #As our app has been started without the 'dev' first arg - we will prune paths that are not zipfs or tclkit
set internal_paths [list]
if {[info commands tcl::zipfs::root] ne ""} {
set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path
lappend internal_paths $ziproot
}
if {[info exists ::tcl::kitpath]} {
lappend internal_paths $::tcl::kitpath
}
set new_auto_path [list] set new_auto_path [list]
#review - case insensitive ok for windows - but could cause issues on other platforms? #review - case insensitive ok for windows - but could cause issues on other platforms?
foreach ap $::auto_path { foreach ap $::auto_path {
@ -258,21 +451,31 @@ apply { args {
} }
} }
} }
#force rescan #force rescan
catch {package require flobrudder666_nonexistant} #catch {package require flobrudder666_nonexistant}
set arglist $args set arglist $args
} }
if {[llength $arglist]} { #assert arglist has had 'dev' first arg removed if it was present.
puts stdout "main.tcl launching app-shellspy" if {[llength $arglist] == 1 && [lindex $arglist 0] eq "tclsh"} {
#called as <executable> dev tclsh or <executable> tclsh
#we would like to drop through to standard tclsh repl without launching another process? how?
#tclMain.c doesn't seem to allow it.
puts "tcl_interactive: $::tcl_interactive"
set ::tcl_interactive 1
puts "stdin: [chan configure stdin]"
set ::tclsh(dorepl) 1
} elseif {[llength $arglist]} {
#pass through to shellspy commandline processor
#puts stdout "main.tcl launching app-shellspy"
package require app-shellspy package require app-shellspy
} else { } else {
puts stdout "main.tcl launching app-punk" #punk shell
puts stdout "main.tcl launching app-punk. pkg names count:[llength [package names]]"
package require app-punk package require app-punk
#app-punk starts repl #app-punk starts repl
#repl::start stdin -title "main.tcl" #repl::start stdin -title "main.tcl"
} }
puts stderr "main.tcl done"
flush stderr
}} {*}$::argv }} {*}$::argv

27
src/vfs/punk9win.vfs/main.tcl

@ -12,7 +12,7 @@ apply { args {
if {$has_zipfs} { if {$has_zipfs} {
set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}] set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}]
} else { } else {
set has_zipfs_attached set has_zipfs_attached 0
} }
set tclmajorv [lindex [split [info tclversion] .] 0] set tclmajorv [lindex [split [info tclversion] .] 0]
@ -26,7 +26,7 @@ apply { args {
set topdir [file dirname $normscript] set topdir [file dirname $normscript]
set found_starkit_tcl 0 set found_starkit_tcl 0
set possible_lib_vfs_folders [glob -dir [file join $topdir lib] -type d vfs*] set possible_lib_vfs_folders [glob -nocomplain -dir [file join $topdir lib] -type d vfs*]
foreach test_folder $possible_lib_vfs_folders { foreach test_folder $possible_lib_vfs_folders {
#e.g <name_of_exe>/lib/vfs1.4.1 #e.g <name_of_exe>/lib/vfs1.4.1
#we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders. #we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders.
@ -461,10 +461,27 @@ apply { args {
#called as <executable> dev tclsh or <executable> tclsh #called as <executable> dev tclsh or <executable> tclsh
#we would like to drop through to standard tclsh repl without launching another process? how? #we would like to drop through to standard tclsh repl without launching another process? how?
#tclMain.c doesn't seem to allow it. #tclMain.c doesn't seem to allow it.
if {![info exists ::env(TCLSH_PIPEREPL)]} {
puts "tcl_interactive: $::tcl_interactive" set is_tclsh_piperepl_env_true 0
} else {
if {[string is boolean -strict $::env(TCLSH_PIPEREPL)]} {
set is_tclsh_piperepl_env_true $::env(TCLSH_PIPEREPL)
} else {
set is_tclsh_piperepl_env_true 0
}
}
if {!$is_tclsh_piperepl_env_true} {
puts stderr "tcl_interactive: $::tcl_interactive"
puts stderr "stdin: [chan configure stdin]"
puts stderr "Environment variable TCLSH_PIPEREPL is not set or is false or is not a boolean"
} else {
#according to env TCLSH_PIPEREPL and our commandline argument - tclsh repl is desired
#check if tclsh/punk has had the piperepl patch applied - in which case tclsh(istty) should exist
if {![info exists ::tclsh(istty)]} {
puts stderr "error: the runtime doesn't appear to have been compiled with the piperepl patch"
}
}
set ::tcl_interactive 1 set ::tcl_interactive 1
puts "stdin: [chan configure stdin]"
set ::tclsh(dorepl) 1 set ::tclsh(dorepl) 1
} elseif {[llength $arglist]} { } elseif {[llength $arglist]} {

Loading…
Cancel
Save