From 2a06ef9c82c6a21b4922dc63ddd64ec8053b3f19 Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Tue, 11 Nov 2025 13:53:11 +1100 Subject: [PATCH] cmdtrace fixes, soften dependency on punk::mix::templates for bootsupport --- src/bootsupport/modules/punk-0.1.tm | 6 +- src/bootsupport/modules/punk/lib-0.1.4.tm | 46 +++++++++++ src/bootsupport/modules/punk/mix-0.2.1.tm | 45 +++++++++++ src/bootsupport/modules/punk/ns-0.1.0.tm | 81 +++++++++++++++---- src/bootsupport/modules/zzzload-0.1.0.tm | 12 ++- src/modules/punk-0.1.tm | 6 +- src/modules/punk/mix-0.2.tm | 37 --------- src/modules/punk/mix-999999.0a1.0.tm | 45 +++++++++++ src/modules/punk/mix-buildversion.txt | 3 + src/modules/punk/ns-999999.0a1.0.tm | 76 +++++++++++++---- src/modules/zzzload-999999.0a1.0.tm | 12 ++- .../src/bootsupport/modules/punk-0.1.tm | 6 +- .../src/bootsupport/modules/punk/mix-0.2.1.tm | 45 +++++++++++ .../src/bootsupport/modules/punk/ns-0.1.0.tm | 76 +++++++++++++---- .../src/bootsupport/modules/zzzload-0.1.0.tm | 12 ++- .../src/bootsupport/modules/punk-0.1.tm | 6 +- .../src/bootsupport/modules/punk/mix-0.2.1.tm | 45 +++++++++++ .../src/bootsupport/modules/punk/ns-0.1.0.tm | 76 +++++++++++++---- .../src/bootsupport/modules/zzzload-0.1.0.tm | 12 ++- src/vfs/_vfscommon.vfs/modules/punk-0.1.tm | 6 +- .../_vfscommon.vfs/modules/punk/mix-0.2.1.tm | 45 +++++++++++ .../_vfscommon.vfs/modules/punk/ns-0.1.0.tm | 76 +++++++++++++---- .../_vfscommon.vfs/modules/zzzload-0.1.0.tm | 12 ++- 23 files changed, 657 insertions(+), 129 deletions(-) create mode 100644 src/bootsupport/modules/punk/mix-0.2.1.tm delete mode 100644 src/modules/punk/mix-0.2.tm create mode 100644 src/modules/punk/mix-999999.0a1.0.tm create mode 100644 src/modules/punk/mix-buildversion.txt create mode 100644 src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix-0.2.1.tm create mode 100644 src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix-0.2.1.tm create mode 100644 src/vfs/_vfscommon.vfs/modules/punk/mix-0.2.1.tm diff --git a/src/bootsupport/modules/punk-0.1.tm b/src/bootsupport/modules/punk-0.1.tm index 2b2118cf..1893444d 100644 --- a/src/bootsupport/modules/punk-0.1.tm +++ b/src/bootsupport/modules/punk-0.1.tm @@ -5383,9 +5383,13 @@ namespace eval punk { # # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + + #------------------------ + #todo 2026 - remove - use new : expr syntax instead #todo - repl output info that it was evaluated as an expression #know {[expr $args] || 1} {expr $args} - know {[expr $args] || 1} {tailcall expr $args} + #know {[expr $args] || 1} {tailcall expr $args} + #--------------------------- #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) diff --git a/src/bootsupport/modules/punk/lib-0.1.4.tm b/src/bootsupport/modules/punk/lib-0.1.4.tm index a7273752..742223ff 100644 --- a/src/bootsupport/modules/punk/lib-0.1.4.tm +++ b/src/bootsupport/modules/punk/lib-0.1.4.tm @@ -3180,6 +3180,33 @@ namespace eval punk::lib { #[para]Use expr's log10() function or tcl::mathfunc::log10 for base 10 expr {log($x)/log($b)} } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::factors + @cmd -name punk::lib::factors\ + -summary\ + "Sorted factors of positive integer x"\ + -help\ + "Return a sorted list of the positive factors of x where x > 0 + For x = 0 we return only 0 and 1 as technically any number divides zero and there are an infinite number of factors. + (including zero itself in this context)* + + This is a simple brute-force implementation that iterates all numbers below the square root of x to check the factors + Because the implementation is so simple - the performance is very reasonable for numbers below at least a few 10's of millions + See tcllib math::numtheory::factors for a more complex implementation - which seems to be slower for 'small' numbers + Comparisons were done with some numbers below 17 digits long + For seriously big numbers - this simple algorithm would no doubt be outperformed by more complex algorithms. + The numtheory library stores some data about primes etc with each call - so may become faster when being used on more numbers + but has the disadvantage of being slower for 'small' numbers and using more memory. + If the largest factor below x is needed - the greatestOddFactorBelow and GreatestFactorBelow functions are a faster way to get + there than computing the whole list, even for small values of x + * Taking x=0; Notion of x being divisible by integer y being: There exists an integer p such that x = py + In other mathematical contexts zero may be considered not to divide anything." + @values -min 1 -max 1 + x -type integer + }] + } proc factors {x} { #*** !doctools #[call [fun factors] [arg x]] @@ -3293,6 +3320,25 @@ namespace eval punk::lib { } return $r } + namespace eval argdoc { + variable PUNKARGS + lappend PUNKARGS [list { + @id -id ::punk::lib::gcd + @cmd -name punk::lib::gcd\ + -summary\ + "Gretest common divisor of m and n."\ + -help\ + "Return the greatest common divisor of m and n. + Straight from Lars Hellström's math::numtheory library in Tcllib + + Graphical use: + An a by b rectangle can be covered with square tiles of side-length c, + only if c is a common divisor of a and b" + @values -min 2 -max 2 + m -type integer + n -type integer + }] + } proc gcd {n m} { #*** !doctools #[call [fun gcd] [arg n] [arg m]] diff --git a/src/bootsupport/modules/punk/mix-0.2.1.tm b/src/bootsupport/modules/punk/mix-0.2.1.tm new file mode 100644 index 00000000..63cf0427 --- /dev/null +++ b/src/bootsupport/modules/punk/mix-0.2.1.tm @@ -0,0 +1,45 @@ + +package require punk::cap + + +tcl::namespace::eval punk::mix { + proc init {} { + package require punk::cap::handlers::templates ;#handler for templates cap + punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us + + #todo: use tcllib pluginmgr to load all modules that provide 'punk.templates' + #review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages + #We may also need to better control the order of module and library paths in the safe interps pluginmgr uses. + #todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation) + + #The punk::mix::templates module is implemented as a zip based archive (modpod header) + #This requires vfs::zip package or zipfs command in Tcl + #Both are binary requirements - either can fail on older systems. + if {[catch { + package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap + } errTemplates]} { + #emit a warning - but continue on without templates anyway. (punk::mix required to load when using bootsupport paths) + puts stderr "punk::mix failed to load ZIP archive-based module punk::mix::templates\nUse a modern Tcl with zipfs, or a recent vfs::zip library\nError:$errTemplates" + } else { + set t [time { + if {[catch {punk::mix::templates::provider register *} errM]} { + puts stderr "punk::mix failure during punk::mix::templates::provider register *" + puts stderr $errM + puts stderr "-----" + puts stderr $::errorInfo + } + }] + } + puts stderr "->punk::mix::templates::provider register * t=$t" + } + init +} + +package require punk::mix::base +package require punk::mix::cli + +package provide punk::mix [tcl::namespace::eval punk::mix { + variable version + set version 0.2.1 + +}] diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index 4a680500..9a42ad0b 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -1989,7 +1989,7 @@ y" {return quirkykeyscript} } } - + #2 arg form of nested switch - no problem with line-numbers for first 2 arms proc test_switch4 {s} { switch [string index $s 0] { a { @@ -2023,6 +2023,7 @@ y" {return quirkykeyscript} } } } + #3 arg form of nested switch - first 2 arms misreport line numbers proc test_switch4b {s} { switch -- [string index $s 0] { a { @@ -2296,7 +2297,9 @@ y" {return quirkykeyscript} proc dkf_enterstep {vname target args} { #dkf sample on wiki variable tinfo - if {$tinfo(disabled)} return + variable _cmdtrace_disabled + if {$_cmdtrace_disabled} return + #only trace top level steps in the proc if {[info level] == [dict get $tinfo($target) level]} { if {[dict get $tinfo($target) firstline] < 0} { @@ -2550,7 +2553,7 @@ y" {return quirkykeyscript} }]} { #eg cmd {tcl::mathfunc::sqrt 100} puts "No line info for call: $callinfo" - set tinfo(disabled) false + set _cmdtrace_disabled false return } switch -- $type { @@ -2610,7 +2613,9 @@ y" {return quirkykeyscript} dict set tinfo($target) firstline $traceline - set pbody [info body $target] + set ns [punk::ns::nsprefix $target] + set nscmd [punk::ns::nstail $target] + set pbody [::tcl::namespace::eval $ns [list ::tcl::info::body $nscmd]] set offset 0 foreach ln [split $pbody \n] { incr offset 1 @@ -2739,25 +2744,34 @@ y" {return quirkykeyscript} ::tcl::dict::set ::punk::ns::linedict $tgt_cmd [::tcl::dict::create eval_base 1 eval_offset 1 lines {} cmdtype $tgt_type successcalls 0 errorcalls 0] } + #if the target command has a leading colon (e.g expr alternative :) we can't put a trace directly on a fully qualified name with a triple colon such as ::: + #we will need to evaluate in the namespace foreach tgt_cmd $resolved_targets { + set nscmd [nstail $tgt_cmd] + set ns [nsprefix $tgt_cmd] puts "tracing target: $tgt_cmd whilst running: $origin $arglist" - trace add execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] - trace add execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] - trace add execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] } try { - uplevel 1 [list $origin {*}$arglist] + set origin_nscmd [nstail $origin] + set origin_ns [nsprefix $origin] + #uplevel 1 [list $origin {*}$arglist] + ::tcl::namespace::eval $origin_ns [list $origin_nscmd {*}$arglist] } trap {} {errMsg errOptions} { puts stderr "command error $errMsg" } finally { foreach tgt_cmd $resolved_targets { - trace remove execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] - trace remove execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] - trace remove execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + set nscmd [nstail $tgt_cmd] + set ns [nsprefix $tgt_cmd] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] } } @@ -2779,7 +2793,7 @@ y" {return quirkykeyscript} } source { set procbody [grepstr -r a -highlight {yellow bold underline} "^\\s*${k}\\s+" $procbody] - puts stderr "source $k" + #puts stderr "source $k" } default { #set procbody [grepstr -r a -highlight {cyan bold underline} "^\\s*${k}\\s+" $procbody] @@ -2799,6 +2813,9 @@ y" {return quirkykeyscript} } proc cmdtracebasic {args} { variable tinfo + variable _cmdtrace_disabled + set _cmdtrace_disabled false + set cinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$args]] set origin [dict get $cinfo origin] set arglist [dict get $cinfo args_remaining] @@ -4659,7 +4676,11 @@ y" {return quirkykeyscript} punk::args::define $argdef } else { puts "PROC auto def $autoid (generate_autodef)" - set infoargs [info args $origin] + #to handle procs like ":" (eg used by colin's bytecode based expr replacement) or other names of the form ":xyz" + #we can't use 'info args :::' - tcl won't find it + set ns [nsprefix $origin] + set nscmd [nstail $origin] + set infoargs [namespace eval $ns [list ::tcl::info::args $nscmd]] set argdef [punk::lib::tstr -return string { @id -id "${$autoid}" @cmd -help\ @@ -4671,11 +4692,39 @@ y" {return quirkykeyscript} #rather than type 'any' - we should use 'unknown' foreach a $infoargs { incr i - if {[info default $origin $a def]} { - append argdef \n "$a -type unknown -default \"$def\"" + #we need a varname for ::tcl::info::default - but as we need to run it in the ns we have to be careful, + #or we risk variable collisions/pollution of the target ns. + set default_info [apply [list {procname argname} { + if {[::tcl::info::default $procname $argname defaultval]} { + return [dict create exists 1 default $defaultval] + } else { + return [dict create exists 0 default ""] + } + } $ns] $nscmd $a] + if {[dict get $default_info exists]} { + append argdef \n "$a -type unknown -default \"[dict get $default_info default]\"" } else { if {$i == [llength $infoargs]-1 && $a eq "args"} { - append argdef \n "arg -type unknown -multiple 1 -optional 1" + #we need to use a name that doesn't collide with any previous arguments + #The common way of expressing args in a synopsis is ?arg...? but this won't work if a proc is defined such as: + #proc something {arg args} {...} + #This is a bit unfortunate, but not that unusual. + #If we use 'args' - we get a synopsis of ?args...? which isn't great + #if someone uses both arg and args - we'll choose next available arg for starting at 1 + if {"arg" in $infoargs} { + #It's also possible someone defined a proc such as: + #proc something {args args} {...} + #This would make $args available in the proc as a single value, whilst making the remaining args inaccessble. + #Most likely that would be done in error? + set n 1 + while {[lsearch $infoargs arg$n] >=0} { + incr n + } + set args_element "arg$n" + } else { + set args_element "arg" + } + append argdef \n "$args_element -type unknown -multiple 1 -optional 1" } else { append argdef \n "$a -type unknown" } diff --git a/src/bootsupport/modules/zzzload-0.1.0.tm b/src/bootsupport/modules/zzzload-0.1.0.tm index def41578..c55f4243 100644 --- a/src/bootsupport/modules/zzzload-0.1.0.tm +++ b/src/bootsupport/modules/zzzload-0.1.0.tm @@ -23,8 +23,9 @@ package require Thread # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval zzzload { - variable loader_tid "" ;#thread id + variable loader_tid "" ;#thread id proc stacktrace {} { + #review set stack "Stack trace:\n" for {set i 1} {$i < [info level]} {incr i} { set lvl [info level -$i] @@ -50,8 +51,13 @@ namespace eval zzzload { return $stack } proc pkg_require {pkgname args} { + #experimental + # loads a binary package in another thread - doesn't load an ordinary package in main thread. + # has potential for startup time savings with binary modules that are slow to load, + # but utility/practicality is dubious. + variable loader_tid - if {[set ver [package provide twapi]] ne ""} { + if {[set ver [package provide $pkgname]] ne ""} { #skip the whole shebazzle if it's already loaded return $ver } @@ -89,7 +95,7 @@ namespace eval zzzload { thread::mutex lock $mutex set cond [tsv::get zzzload_pkg_cond $pkgname] while {[tsv::get zzzload_pkg $pkgname] eq "loading"} { - thread::cond wait $cond $mutex 3000 + thread::cond wait $cond $mutex 3000 } set result [tsv::get zzzload_pkg $pkgname] thread::mutex unlock $mutex diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 2b2118cf..1893444d 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -5383,9 +5383,13 @@ namespace eval punk { # # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + + #------------------------ + #todo 2026 - remove - use new : expr syntax instead #todo - repl output info that it was evaluated as an expression #know {[expr $args] || 1} {expr $args} - know {[expr $args] || 1} {tailcall expr $args} + #know {[expr $args] || 1} {tailcall expr $args} + #--------------------------- #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) diff --git a/src/modules/punk/mix-0.2.tm b/src/modules/punk/mix-0.2.tm deleted file mode 100644 index e3f2cb16..00000000 --- a/src/modules/punk/mix-0.2.tm +++ /dev/null @@ -1,37 +0,0 @@ - -package require punk::cap - - -tcl::namespace::eval punk::mix { - proc init {} { - package require punk::cap::handlers::templates ;#handler for templates cap - punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us - - #todo: use tcllib pluginmgr to load all modules that provide 'punk.templates' - #review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages - #We may also need to better control the order of module and library paths in the safe interps pluginmgr uses. - #todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation) - - package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap - set t [time { - if {[catch {punk::mix::templates::provider register *} errM]} { - puts stderr "punk::mix failure during punk::mix::templates::provider register *" - puts stderr $errM - puts stderr "-----" - puts stderr $::errorInfo - } - }] - puts stderr "->punk::mix::templates::provider register * t=$t" - } - init - -} - -package require punk::mix::base -package require punk::mix::cli - -package provide punk::mix [tcl::namespace::eval punk::mix { - variable version - set version 0.2 - -}] diff --git a/src/modules/punk/mix-999999.0a1.0.tm b/src/modules/punk/mix-999999.0a1.0.tm new file mode 100644 index 00000000..df011c4d --- /dev/null +++ b/src/modules/punk/mix-999999.0a1.0.tm @@ -0,0 +1,45 @@ + +package require punk::cap + + +tcl::namespace::eval punk::mix { + proc init {} { + package require punk::cap::handlers::templates ;#handler for templates cap + punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us + + #todo: use tcllib pluginmgr to load all modules that provide 'punk.templates' + #review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages + #We may also need to better control the order of module and library paths in the safe interps pluginmgr uses. + #todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation) + + #The punk::mix::templates module is implemented as a zip based archive (modpod header) + #This requires vfs::zip package or zipfs command in Tcl + #Both are binary requirements - either can fail on older systems. + if {[catch { + package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap + } errTemplates]} { + #emit a warning - but continue on without templates anyway. (punk::mix required to load when using bootsupport paths) + puts stderr "punk::mix failed to load ZIP archive-based module punk::mix::templates\nUse a modern Tcl with zipfs, or a recent vfs::zip library\nError:$errTemplates" + } else { + set t [time { + if {[catch {punk::mix::templates::provider register *} errM]} { + puts stderr "punk::mix failure during punk::mix::templates::provider register *" + puts stderr $errM + puts stderr "-----" + puts stderr $::errorInfo + } + }] + } + puts stderr "->punk::mix::templates::provider register * t=$t" + } + init +} + +package require punk::mix::base +package require punk::mix::cli + +package provide punk::mix [tcl::namespace::eval punk::mix { + variable version + set version 999999.0a1.0 + +}] diff --git a/src/modules/punk/mix-buildversion.txt b/src/modules/punk/mix-buildversion.txt new file mode 100644 index 00000000..5e50bcd0 --- /dev/null +++ b/src/modules/punk/mix-buildversion.txt @@ -0,0 +1,3 @@ +0.2.1 +#First line must be a semantic version number +#all other lines are ignored. \ No newline at end of file diff --git a/src/modules/punk/ns-999999.0a1.0.tm b/src/modules/punk/ns-999999.0a1.0.tm index 60a3a5a9..13155d9d 100644 --- a/src/modules/punk/ns-999999.0a1.0.tm +++ b/src/modules/punk/ns-999999.0a1.0.tm @@ -2297,7 +2297,9 @@ y" {return quirkykeyscript} proc dkf_enterstep {vname target args} { #dkf sample on wiki variable tinfo - if {$tinfo(disabled)} return + variable _cmdtrace_disabled + if {$_cmdtrace_disabled} return + #only trace top level steps in the proc if {[info level] == [dict get $tinfo($target) level]} { if {[dict get $tinfo($target) firstline] < 0} { @@ -2611,7 +2613,9 @@ y" {return quirkykeyscript} dict set tinfo($target) firstline $traceline - set pbody [info body $target] + set ns [punk::ns::nsprefix $target] + set nscmd [punk::ns::nstail $target] + set pbody [::tcl::namespace::eval $ns [list ::tcl::info::body $nscmd]] set offset 0 foreach ln [split $pbody \n] { incr offset 1 @@ -2740,25 +2744,34 @@ y" {return quirkykeyscript} ::tcl::dict::set ::punk::ns::linedict $tgt_cmd [::tcl::dict::create eval_base 1 eval_offset 1 lines {} cmdtype $tgt_type successcalls 0 errorcalls 0] } + #if the target command has a leading colon (e.g expr alternative :) we can't put a trace directly on a fully qualified name with a triple colon such as ::: + #we will need to evaluate in the namespace foreach tgt_cmd $resolved_targets { + set nscmd [nstail $tgt_cmd] + set ns [nsprefix $tgt_cmd] puts "tracing target: $tgt_cmd whilst running: $origin $arglist" - trace add execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] - trace add execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] - trace add execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] } try { - uplevel 1 [list $origin {*}$arglist] + set origin_nscmd [nstail $origin] + set origin_ns [nsprefix $origin] + #uplevel 1 [list $origin {*}$arglist] + ::tcl::namespace::eval $origin_ns [list $origin_nscmd {*}$arglist] } trap {} {errMsg errOptions} { puts stderr "command error $errMsg" } finally { foreach tgt_cmd $resolved_targets { - trace remove execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] - trace remove execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] - trace remove execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + set nscmd [nstail $tgt_cmd] + set ns [nsprefix $tgt_cmd] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] } } @@ -2780,7 +2793,7 @@ y" {return quirkykeyscript} } source { set procbody [grepstr -r a -highlight {yellow bold underline} "^\\s*${k}\\s+" $procbody] - puts stderr "source $k" + #puts stderr "source $k" } default { #set procbody [grepstr -r a -highlight {cyan bold underline} "^\\s*${k}\\s+" $procbody] @@ -2800,6 +2813,9 @@ y" {return quirkykeyscript} } proc cmdtracebasic {args} { variable tinfo + variable _cmdtrace_disabled + set _cmdtrace_disabled false + set cinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$args]] set origin [dict get $cinfo origin] set arglist [dict get $cinfo args_remaining] @@ -4660,7 +4676,11 @@ y" {return quirkykeyscript} punk::args::define $argdef } else { puts "PROC auto def $autoid (generate_autodef)" - set infoargs [info args $origin] + #to handle procs like ":" (eg used by colin's bytecode based expr replacement) or other names of the form ":xyz" + #we can't use 'info args :::' - tcl won't find it + set ns [nsprefix $origin] + set nscmd [nstail $origin] + set infoargs [namespace eval $ns [list ::tcl::info::args $nscmd]] set argdef [punk::lib::tstr -return string { @id -id "${$autoid}" @cmd -help\ @@ -4672,11 +4692,39 @@ y" {return quirkykeyscript} #rather than type 'any' - we should use 'unknown' foreach a $infoargs { incr i - if {[info default $origin $a def]} { - append argdef \n "$a -type unknown -default \"$def\"" + #we need a varname for ::tcl::info::default - but as we need to run it in the ns we have to be careful, + #or we risk variable collisions/pollution of the target ns. + set default_info [apply [list {procname argname} { + if {[::tcl::info::default $procname $argname defaultval]} { + return [dict create exists 1 default $defaultval] + } else { + return [dict create exists 0 default ""] + } + } $ns] $nscmd $a] + if {[dict get $default_info exists]} { + append argdef \n "$a -type unknown -default \"[dict get $default_info default]\"" } else { if {$i == [llength $infoargs]-1 && $a eq "args"} { - append argdef \n "arg -type unknown -multiple 1 -optional 1" + #we need to use a name that doesn't collide with any previous arguments + #The common way of expressing args in a synopsis is ?arg...? but this won't work if a proc is defined such as: + #proc something {arg args} {...} + #This is a bit unfortunate, but not that unusual. + #If we use 'args' - we get a synopsis of ?args...? which isn't great + #if someone uses both arg and args - we'll choose next available arg for starting at 1 + if {"arg" in $infoargs} { + #It's also possible someone defined a proc such as: + #proc something {args args} {...} + #This would make $args available in the proc as a single value, whilst making the remaining args inaccessble. + #Most likely that would be done in error? + set n 1 + while {[lsearch $infoargs arg$n] >=0} { + incr n + } + set args_element "arg$n" + } else { + set args_element "arg" + } + append argdef \n "$args_element -type unknown -multiple 1 -optional 1" } else { append argdef \n "$a -type unknown" } diff --git a/src/modules/zzzload-999999.0a1.0.tm b/src/modules/zzzload-999999.0a1.0.tm index dd945ff4..2631d282 100644 --- a/src/modules/zzzload-999999.0a1.0.tm +++ b/src/modules/zzzload-999999.0a1.0.tm @@ -23,8 +23,9 @@ package require Thread # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval zzzload { - variable loader_tid "" ;#thread id + variable loader_tid "" ;#thread id proc stacktrace {} { + #review set stack "Stack trace:\n" for {set i 1} {$i < [info level]} {incr i} { set lvl [info level -$i] @@ -50,8 +51,13 @@ namespace eval zzzload { return $stack } proc pkg_require {pkgname args} { + #experimental + # loads a binary package in another thread - doesn't load an ordinary package in main thread. + # has potential for startup time savings with binary modules that are slow to load, + # but utility/practicality is dubious. + variable loader_tid - if {[set ver [package provide twapi]] ne ""} { + if {[set ver [package provide $pkgname]] ne ""} { #skip the whole shebazzle if it's already loaded return $ver } @@ -89,7 +95,7 @@ namespace eval zzzload { thread::mutex lock $mutex set cond [tsv::get zzzload_pkg_cond $pkgname] while {[tsv::get zzzload_pkg $pkgname] eq "loading"} { - thread::cond wait $cond $mutex 3000 + thread::cond wait $cond $mutex 3000 } set result [tsv::get zzzload_pkg $pkgname] thread::mutex unlock $mutex diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm index 2b2118cf..1893444d 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk-0.1.tm @@ -5383,9 +5383,13 @@ namespace eval punk { # # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + + #------------------------ + #todo 2026 - remove - use new : expr syntax instead #todo - repl output info that it was evaluated as an expression #know {[expr $args] || 1} {expr $args} - know {[expr $args] || 1} {tailcall expr $args} + #know {[expr $args] || 1} {tailcall expr $args} + #--------------------------- #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix-0.2.1.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix-0.2.1.tm new file mode 100644 index 00000000..63cf0427 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/mix-0.2.1.tm @@ -0,0 +1,45 @@ + +package require punk::cap + + +tcl::namespace::eval punk::mix { + proc init {} { + package require punk::cap::handlers::templates ;#handler for templates cap + punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us + + #todo: use tcllib pluginmgr to load all modules that provide 'punk.templates' + #review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages + #We may also need to better control the order of module and library paths in the safe interps pluginmgr uses. + #todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation) + + #The punk::mix::templates module is implemented as a zip based archive (modpod header) + #This requires vfs::zip package or zipfs command in Tcl + #Both are binary requirements - either can fail on older systems. + if {[catch { + package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap + } errTemplates]} { + #emit a warning - but continue on without templates anyway. (punk::mix required to load when using bootsupport paths) + puts stderr "punk::mix failed to load ZIP archive-based module punk::mix::templates\nUse a modern Tcl with zipfs, or a recent vfs::zip library\nError:$errTemplates" + } else { + set t [time { + if {[catch {punk::mix::templates::provider register *} errM]} { + puts stderr "punk::mix failure during punk::mix::templates::provider register *" + puts stderr $errM + puts stderr "-----" + puts stderr $::errorInfo + } + }] + } + puts stderr "->punk::mix::templates::provider register * t=$t" + } + init +} + +package require punk::mix::base +package require punk::mix::cli + +package provide punk::mix [tcl::namespace::eval punk::mix { + variable version + set version 0.2.1 + +}] diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index 8528044a..9a42ad0b 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -2297,7 +2297,9 @@ y" {return quirkykeyscript} proc dkf_enterstep {vname target args} { #dkf sample on wiki variable tinfo - if {$tinfo(disabled)} return + variable _cmdtrace_disabled + if {$_cmdtrace_disabled} return + #only trace top level steps in the proc if {[info level] == [dict get $tinfo($target) level]} { if {[dict get $tinfo($target) firstline] < 0} { @@ -2611,7 +2613,9 @@ y" {return quirkykeyscript} dict set tinfo($target) firstline $traceline - set pbody [info body $target] + set ns [punk::ns::nsprefix $target] + set nscmd [punk::ns::nstail $target] + set pbody [::tcl::namespace::eval $ns [list ::tcl::info::body $nscmd]] set offset 0 foreach ln [split $pbody \n] { incr offset 1 @@ -2740,25 +2744,34 @@ y" {return quirkykeyscript} ::tcl::dict::set ::punk::ns::linedict $tgt_cmd [::tcl::dict::create eval_base 1 eval_offset 1 lines {} cmdtype $tgt_type successcalls 0 errorcalls 0] } + #if the target command has a leading colon (e.g expr alternative :) we can't put a trace directly on a fully qualified name with a triple colon such as ::: + #we will need to evaluate in the namespace foreach tgt_cmd $resolved_targets { + set nscmd [nstail $tgt_cmd] + set ns [nsprefix $tgt_cmd] puts "tracing target: $tgt_cmd whilst running: $origin $arglist" - trace add execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] - trace add execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] - trace add execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] } try { - uplevel 1 [list $origin {*}$arglist] + set origin_nscmd [nstail $origin] + set origin_ns [nsprefix $origin] + #uplevel 1 [list $origin {*}$arglist] + ::tcl::namespace::eval $origin_ns [list $origin_nscmd {*}$arglist] } trap {} {errMsg errOptions} { puts stderr "command error $errMsg" } finally { foreach tgt_cmd $resolved_targets { - trace remove execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] - trace remove execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] - trace remove execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + set nscmd [nstail $tgt_cmd] + set ns [nsprefix $tgt_cmd] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] } } @@ -2780,7 +2793,7 @@ y" {return quirkykeyscript} } source { set procbody [grepstr -r a -highlight {yellow bold underline} "^\\s*${k}\\s+" $procbody] - puts stderr "source $k" + #puts stderr "source $k" } default { #set procbody [grepstr -r a -highlight {cyan bold underline} "^\\s*${k}\\s+" $procbody] @@ -2800,6 +2813,9 @@ y" {return quirkykeyscript} } proc cmdtracebasic {args} { variable tinfo + variable _cmdtrace_disabled + set _cmdtrace_disabled false + set cinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$args]] set origin [dict get $cinfo origin] set arglist [dict get $cinfo args_remaining] @@ -4660,7 +4676,11 @@ y" {return quirkykeyscript} punk::args::define $argdef } else { puts "PROC auto def $autoid (generate_autodef)" - set infoargs [info args $origin] + #to handle procs like ":" (eg used by colin's bytecode based expr replacement) or other names of the form ":xyz" + #we can't use 'info args :::' - tcl won't find it + set ns [nsprefix $origin] + set nscmd [nstail $origin] + set infoargs [namespace eval $ns [list ::tcl::info::args $nscmd]] set argdef [punk::lib::tstr -return string { @id -id "${$autoid}" @cmd -help\ @@ -4672,11 +4692,39 @@ y" {return quirkykeyscript} #rather than type 'any' - we should use 'unknown' foreach a $infoargs { incr i - if {[info default $origin $a def]} { - append argdef \n "$a -type unknown -default \"$def\"" + #we need a varname for ::tcl::info::default - but as we need to run it in the ns we have to be careful, + #or we risk variable collisions/pollution of the target ns. + set default_info [apply [list {procname argname} { + if {[::tcl::info::default $procname $argname defaultval]} { + return [dict create exists 1 default $defaultval] + } else { + return [dict create exists 0 default ""] + } + } $ns] $nscmd $a] + if {[dict get $default_info exists]} { + append argdef \n "$a -type unknown -default \"[dict get $default_info default]\"" } else { if {$i == [llength $infoargs]-1 && $a eq "args"} { - append argdef \n "arg -type unknown -multiple 1 -optional 1" + #we need to use a name that doesn't collide with any previous arguments + #The common way of expressing args in a synopsis is ?arg...? but this won't work if a proc is defined such as: + #proc something {arg args} {...} + #This is a bit unfortunate, but not that unusual. + #If we use 'args' - we get a synopsis of ?args...? which isn't great + #if someone uses both arg and args - we'll choose next available arg for starting at 1 + if {"arg" in $infoargs} { + #It's also possible someone defined a proc such as: + #proc something {args args} {...} + #This would make $args available in the proc as a single value, whilst making the remaining args inaccessble. + #Most likely that would be done in error? + set n 1 + while {[lsearch $infoargs arg$n] >=0} { + incr n + } + set args_element "arg$n" + } else { + set args_element "arg" + } + append argdef \n "$args_element -type unknown -multiple 1 -optional 1" } else { append argdef \n "$a -type unknown" } diff --git a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zzzload-0.1.0.tm b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zzzload-0.1.0.tm index def41578..c55f4243 100644 --- a/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zzzload-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.project-0.1/src/bootsupport/modules/zzzload-0.1.0.tm @@ -23,8 +23,9 @@ package require Thread # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval zzzload { - variable loader_tid "" ;#thread id + variable loader_tid "" ;#thread id proc stacktrace {} { + #review set stack "Stack trace:\n" for {set i 1} {$i < [info level]} {incr i} { set lvl [info level -$i] @@ -50,8 +51,13 @@ namespace eval zzzload { return $stack } proc pkg_require {pkgname args} { + #experimental + # loads a binary package in another thread - doesn't load an ordinary package in main thread. + # has potential for startup time savings with binary modules that are slow to load, + # but utility/practicality is dubious. + variable loader_tid - if {[set ver [package provide twapi]] ne ""} { + if {[set ver [package provide $pkgname]] ne ""} { #skip the whole shebazzle if it's already loaded return $ver } @@ -89,7 +95,7 @@ namespace eval zzzload { thread::mutex lock $mutex set cond [tsv::get zzzload_pkg_cond $pkgname] while {[tsv::get zzzload_pkg $pkgname] eq "loading"} { - thread::cond wait $cond $mutex 3000 + thread::cond wait $cond $mutex 3000 } set result [tsv::get zzzload_pkg $pkgname] thread::mutex unlock $mutex diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm index 2b2118cf..1893444d 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk-0.1.tm @@ -5383,9 +5383,13 @@ namespace eval punk { # # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + + #------------------------ + #todo 2026 - remove - use new : expr syntax instead #todo - repl output info that it was evaluated as an expression #know {[expr $args] || 1} {expr $args} - know {[expr $args] || 1} {tailcall expr $args} + #know {[expr $args] || 1} {tailcall expr $args} + #--------------------------- #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix-0.2.1.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix-0.2.1.tm new file mode 100644 index 00000000..63cf0427 --- /dev/null +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/mix-0.2.1.tm @@ -0,0 +1,45 @@ + +package require punk::cap + + +tcl::namespace::eval punk::mix { + proc init {} { + package require punk::cap::handlers::templates ;#handler for templates cap + punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us + + #todo: use tcllib pluginmgr to load all modules that provide 'punk.templates' + #review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages + #We may also need to better control the order of module and library paths in the safe interps pluginmgr uses. + #todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation) + + #The punk::mix::templates module is implemented as a zip based archive (modpod header) + #This requires vfs::zip package or zipfs command in Tcl + #Both are binary requirements - either can fail on older systems. + if {[catch { + package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap + } errTemplates]} { + #emit a warning - but continue on without templates anyway. (punk::mix required to load when using bootsupport paths) + puts stderr "punk::mix failed to load ZIP archive-based module punk::mix::templates\nUse a modern Tcl with zipfs, or a recent vfs::zip library\nError:$errTemplates" + } else { + set t [time { + if {[catch {punk::mix::templates::provider register *} errM]} { + puts stderr "punk::mix failure during punk::mix::templates::provider register *" + puts stderr $errM + puts stderr "-----" + puts stderr $::errorInfo + } + }] + } + puts stderr "->punk::mix::templates::provider register * t=$t" + } + init +} + +package require punk::mix::base +package require punk::mix::cli + +package provide punk::mix [tcl::namespace::eval punk::mix { + variable version + set version 0.2.1 + +}] diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm index 8528044a..9a42ad0b 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -2297,7 +2297,9 @@ y" {return quirkykeyscript} proc dkf_enterstep {vname target args} { #dkf sample on wiki variable tinfo - if {$tinfo(disabled)} return + variable _cmdtrace_disabled + if {$_cmdtrace_disabled} return + #only trace top level steps in the proc if {[info level] == [dict get $tinfo($target) level]} { if {[dict get $tinfo($target) firstline] < 0} { @@ -2611,7 +2613,9 @@ y" {return quirkykeyscript} dict set tinfo($target) firstline $traceline - set pbody [info body $target] + set ns [punk::ns::nsprefix $target] + set nscmd [punk::ns::nstail $target] + set pbody [::tcl::namespace::eval $ns [list ::tcl::info::body $nscmd]] set offset 0 foreach ln [split $pbody \n] { incr offset 1 @@ -2740,25 +2744,34 @@ y" {return quirkykeyscript} ::tcl::dict::set ::punk::ns::linedict $tgt_cmd [::tcl::dict::create eval_base 1 eval_offset 1 lines {} cmdtype $tgt_type successcalls 0 errorcalls 0] } + #if the target command has a leading colon (e.g expr alternative :) we can't put a trace directly on a fully qualified name with a triple colon such as ::: + #we will need to evaluate in the namespace foreach tgt_cmd $resolved_targets { + set nscmd [nstail $tgt_cmd] + set ns [nsprefix $tgt_cmd] puts "tracing target: $tgt_cmd whilst running: $origin $arglist" - trace add execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] - trace add execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] - trace add execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] } try { - uplevel 1 [list $origin {*}$arglist] + set origin_nscmd [nstail $origin] + set origin_ns [nsprefix $origin] + #uplevel 1 [list $origin {*}$arglist] + ::tcl::namespace::eval $origin_ns [list $origin_nscmd {*}$arglist] } trap {} {errMsg errOptions} { puts stderr "command error $errMsg" } finally { foreach tgt_cmd $resolved_targets { - trace remove execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] - trace remove execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] - trace remove execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + set nscmd [nstail $tgt_cmd] + set ns [nsprefix $tgt_cmd] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] } } @@ -2780,7 +2793,7 @@ y" {return quirkykeyscript} } source { set procbody [grepstr -r a -highlight {yellow bold underline} "^\\s*${k}\\s+" $procbody] - puts stderr "source $k" + #puts stderr "source $k" } default { #set procbody [grepstr -r a -highlight {cyan bold underline} "^\\s*${k}\\s+" $procbody] @@ -2800,6 +2813,9 @@ y" {return quirkykeyscript} } proc cmdtracebasic {args} { variable tinfo + variable _cmdtrace_disabled + set _cmdtrace_disabled false + set cinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$args]] set origin [dict get $cinfo origin] set arglist [dict get $cinfo args_remaining] @@ -4660,7 +4676,11 @@ y" {return quirkykeyscript} punk::args::define $argdef } else { puts "PROC auto def $autoid (generate_autodef)" - set infoargs [info args $origin] + #to handle procs like ":" (eg used by colin's bytecode based expr replacement) or other names of the form ":xyz" + #we can't use 'info args :::' - tcl won't find it + set ns [nsprefix $origin] + set nscmd [nstail $origin] + set infoargs [namespace eval $ns [list ::tcl::info::args $nscmd]] set argdef [punk::lib::tstr -return string { @id -id "${$autoid}" @cmd -help\ @@ -4672,11 +4692,39 @@ y" {return quirkykeyscript} #rather than type 'any' - we should use 'unknown' foreach a $infoargs { incr i - if {[info default $origin $a def]} { - append argdef \n "$a -type unknown -default \"$def\"" + #we need a varname for ::tcl::info::default - but as we need to run it in the ns we have to be careful, + #or we risk variable collisions/pollution of the target ns. + set default_info [apply [list {procname argname} { + if {[::tcl::info::default $procname $argname defaultval]} { + return [dict create exists 1 default $defaultval] + } else { + return [dict create exists 0 default ""] + } + } $ns] $nscmd $a] + if {[dict get $default_info exists]} { + append argdef \n "$a -type unknown -default \"[dict get $default_info default]\"" } else { if {$i == [llength $infoargs]-1 && $a eq "args"} { - append argdef \n "arg -type unknown -multiple 1 -optional 1" + #we need to use a name that doesn't collide with any previous arguments + #The common way of expressing args in a synopsis is ?arg...? but this won't work if a proc is defined such as: + #proc something {arg args} {...} + #This is a bit unfortunate, but not that unusual. + #If we use 'args' - we get a synopsis of ?args...? which isn't great + #if someone uses both arg and args - we'll choose next available arg for starting at 1 + if {"arg" in $infoargs} { + #It's also possible someone defined a proc such as: + #proc something {args args} {...} + #This would make $args available in the proc as a single value, whilst making the remaining args inaccessble. + #Most likely that would be done in error? + set n 1 + while {[lsearch $infoargs arg$n] >=0} { + incr n + } + set args_element "arg$n" + } else { + set args_element "arg" + } + append argdef \n "$args_element -type unknown -multiple 1 -optional 1" } else { append argdef \n "$a -type unknown" } diff --git a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zzzload-0.1.0.tm b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zzzload-0.1.0.tm index def41578..c55f4243 100644 --- a/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zzzload-0.1.0.tm +++ b/src/project_layouts/custom/_project/punk.shell-0.1/src/bootsupport/modules/zzzload-0.1.0.tm @@ -23,8 +23,9 @@ package require Thread # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval zzzload { - variable loader_tid "" ;#thread id + variable loader_tid "" ;#thread id proc stacktrace {} { + #review set stack "Stack trace:\n" for {set i 1} {$i < [info level]} {incr i} { set lvl [info level -$i] @@ -50,8 +51,13 @@ namespace eval zzzload { return $stack } proc pkg_require {pkgname args} { + #experimental + # loads a binary package in another thread - doesn't load an ordinary package in main thread. + # has potential for startup time savings with binary modules that are slow to load, + # but utility/practicality is dubious. + variable loader_tid - if {[set ver [package provide twapi]] ne ""} { + if {[set ver [package provide $pkgname]] ne ""} { #skip the whole shebazzle if it's already loaded return $ver } @@ -89,7 +95,7 @@ namespace eval zzzload { thread::mutex lock $mutex set cond [tsv::get zzzload_pkg_cond $pkgname] while {[tsv::get zzzload_pkg $pkgname] eq "loading"} { - thread::cond wait $cond $mutex 3000 + thread::cond wait $cond $mutex 3000 } set result [tsv::get zzzload_pkg $pkgname] thread::mutex unlock $mutex diff --git a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm index 2b2118cf..1893444d 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk-0.1.tm @@ -5383,9 +5383,13 @@ namespace eval punk { # # potentially can be disabled by config(?) - but then scripts not able to use all repl features.. + + #------------------------ + #todo 2026 - remove - use new : expr syntax instead #todo - repl output info that it was evaluated as an expression #know {[expr $args] || 1} {expr $args} - know {[expr $args] || 1} {tailcall expr $args} + #know {[expr $args] || 1} {tailcall expr $args} + #--------------------------- #it is significantly faster to call a proc such as punk::lib::range like this than to inline it in the unknown proc #punk::lib::range is defined as a wrapper to lseq if it is available (8.7+) diff --git a/src/vfs/_vfscommon.vfs/modules/punk/mix-0.2.1.tm b/src/vfs/_vfscommon.vfs/modules/punk/mix-0.2.1.tm new file mode 100644 index 00000000..63cf0427 --- /dev/null +++ b/src/vfs/_vfscommon.vfs/modules/punk/mix-0.2.1.tm @@ -0,0 +1,45 @@ + +package require punk::cap + + +tcl::namespace::eval punk::mix { + proc init {} { + package require punk::cap::handlers::templates ;#handler for templates cap + punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us + + #todo: use tcllib pluginmgr to load all modules that provide 'punk.templates' + #review - tcllib pluginmgr 0.5 @2025 has some bugs - esp regarding .tm modules vs packages + #We may also need to better control the order of module and library paths in the safe interps pluginmgr uses. + #todo - develop punk::pluginmgr to fix these issues (bug reports already submitted re tcllib, but the path issues may need customisation) + + #The punk::mix::templates module is implemented as a zip based archive (modpod header) + #This requires vfs::zip package or zipfs command in Tcl + #Both are binary requirements - either can fail on older systems. + if {[catch { + package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap + } errTemplates]} { + #emit a warning - but continue on without templates anyway. (punk::mix required to load when using bootsupport paths) + puts stderr "punk::mix failed to load ZIP archive-based module punk::mix::templates\nUse a modern Tcl with zipfs, or a recent vfs::zip library\nError:$errTemplates" + } else { + set t [time { + if {[catch {punk::mix::templates::provider register *} errM]} { + puts stderr "punk::mix failure during punk::mix::templates::provider register *" + puts stderr $errM + puts stderr "-----" + puts stderr $::errorInfo + } + }] + } + puts stderr "->punk::mix::templates::provider register * t=$t" + } + init +} + +package require punk::mix::base +package require punk::mix::cli + +package provide punk::mix [tcl::namespace::eval punk::mix { + variable version + set version 0.2.1 + +}] diff --git a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm index 8528044a..9a42ad0b 100644 --- a/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/punk/ns-0.1.0.tm @@ -2297,7 +2297,9 @@ y" {return quirkykeyscript} proc dkf_enterstep {vname target args} { #dkf sample on wiki variable tinfo - if {$tinfo(disabled)} return + variable _cmdtrace_disabled + if {$_cmdtrace_disabled} return + #only trace top level steps in the proc if {[info level] == [dict get $tinfo($target) level]} { if {[dict get $tinfo($target) firstline] < 0} { @@ -2611,7 +2613,9 @@ y" {return quirkykeyscript} dict set tinfo($target) firstline $traceline - set pbody [info body $target] + set ns [punk::ns::nsprefix $target] + set nscmd [punk::ns::nstail $target] + set pbody [::tcl::namespace::eval $ns [list ::tcl::info::body $nscmd]] set offset 0 foreach ln [split $pbody \n] { incr offset 1 @@ -2740,25 +2744,34 @@ y" {return quirkykeyscript} ::tcl::dict::set ::punk::ns::linedict $tgt_cmd [::tcl::dict::create eval_base 1 eval_offset 1 lines {} cmdtype $tgt_type successcalls 0 errorcalls 0] } + #if the target command has a leading colon (e.g expr alternative :) we can't put a trace directly on a fully qualified name with a triple colon such as ::: + #we will need to evaluate in the namespace foreach tgt_cmd $resolved_targets { + set nscmd [nstail $tgt_cmd] + set ns [nsprefix $tgt_cmd] puts "tracing target: $tgt_cmd whilst running: $origin $arglist" - trace add execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] - trace add execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] - trace add execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace add execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] } try { - uplevel 1 [list $origin {*}$arglist] + set origin_nscmd [nstail $origin] + set origin_ns [nsprefix $origin] + #uplevel 1 [list $origin {*}$arglist] + ::tcl::namespace::eval $origin_ns [list $origin_nscmd {*}$arglist] } trap {} {errMsg errOptions} { puts stderr "command error $errMsg" } finally { foreach tgt_cmd $resolved_targets { - trace remove execution $tgt_cmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd] - trace remove execution $tgt_cmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd] - trace remove execution $tgt_cmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd] + set nscmd [nstail $tgt_cmd] + set ns [nsprefix $tgt_cmd] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] + ::tcl::namespace::eval $ns [list ::trace remove execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] } } @@ -2780,7 +2793,7 @@ y" {return quirkykeyscript} } source { set procbody [grepstr -r a -highlight {yellow bold underline} "^\\s*${k}\\s+" $procbody] - puts stderr "source $k" + #puts stderr "source $k" } default { #set procbody [grepstr -r a -highlight {cyan bold underline} "^\\s*${k}\\s+" $procbody] @@ -2800,6 +2813,9 @@ y" {return quirkykeyscript} } proc cmdtracebasic {args} { variable tinfo + variable _cmdtrace_disabled + set _cmdtrace_disabled false + set cinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$args]] set origin [dict get $cinfo origin] set arglist [dict get $cinfo args_remaining] @@ -4660,7 +4676,11 @@ y" {return quirkykeyscript} punk::args::define $argdef } else { puts "PROC auto def $autoid (generate_autodef)" - set infoargs [info args $origin] + #to handle procs like ":" (eg used by colin's bytecode based expr replacement) or other names of the form ":xyz" + #we can't use 'info args :::' - tcl won't find it + set ns [nsprefix $origin] + set nscmd [nstail $origin] + set infoargs [namespace eval $ns [list ::tcl::info::args $nscmd]] set argdef [punk::lib::tstr -return string { @id -id "${$autoid}" @cmd -help\ @@ -4672,11 +4692,39 @@ y" {return quirkykeyscript} #rather than type 'any' - we should use 'unknown' foreach a $infoargs { incr i - if {[info default $origin $a def]} { - append argdef \n "$a -type unknown -default \"$def\"" + #we need a varname for ::tcl::info::default - but as we need to run it in the ns we have to be careful, + #or we risk variable collisions/pollution of the target ns. + set default_info [apply [list {procname argname} { + if {[::tcl::info::default $procname $argname defaultval]} { + return [dict create exists 1 default $defaultval] + } else { + return [dict create exists 0 default ""] + } + } $ns] $nscmd $a] + if {[dict get $default_info exists]} { + append argdef \n "$a -type unknown -default \"[dict get $default_info default]\"" } else { if {$i == [llength $infoargs]-1 && $a eq "args"} { - append argdef \n "arg -type unknown -multiple 1 -optional 1" + #we need to use a name that doesn't collide with any previous arguments + #The common way of expressing args in a synopsis is ?arg...? but this won't work if a proc is defined such as: + #proc something {arg args} {...} + #This is a bit unfortunate, but not that unusual. + #If we use 'args' - we get a synopsis of ?args...? which isn't great + #if someone uses both arg and args - we'll choose next available arg for starting at 1 + if {"arg" in $infoargs} { + #It's also possible someone defined a proc such as: + #proc something {args args} {...} + #This would make $args available in the proc as a single value, whilst making the remaining args inaccessble. + #Most likely that would be done in error? + set n 1 + while {[lsearch $infoargs arg$n] >=0} { + incr n + } + set args_element "arg$n" + } else { + set args_element "arg" + } + append argdef \n "$args_element -type unknown -multiple 1 -optional 1" } else { append argdef \n "$a -type unknown" } diff --git a/src/vfs/_vfscommon.vfs/modules/zzzload-0.1.0.tm b/src/vfs/_vfscommon.vfs/modules/zzzload-0.1.0.tm index def41578..c55f4243 100644 --- a/src/vfs/_vfscommon.vfs/modules/zzzload-0.1.0.tm +++ b/src/vfs/_vfscommon.vfs/modules/zzzload-0.1.0.tm @@ -23,8 +23,9 @@ package require Thread # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval zzzload { - variable loader_tid "" ;#thread id + variable loader_tid "" ;#thread id proc stacktrace {} { + #review set stack "Stack trace:\n" for {set i 1} {$i < [info level]} {incr i} { set lvl [info level -$i] @@ -50,8 +51,13 @@ namespace eval zzzload { return $stack } proc pkg_require {pkgname args} { + #experimental + # loads a binary package in another thread - doesn't load an ordinary package in main thread. + # has potential for startup time savings with binary modules that are slow to load, + # but utility/practicality is dubious. + variable loader_tid - if {[set ver [package provide twapi]] ne ""} { + if {[set ver [package provide $pkgname]] ne ""} { #skip the whole shebazzle if it's already loaded return $ver } @@ -89,7 +95,7 @@ namespace eval zzzload { thread::mutex lock $mutex set cond [tsv::get zzzload_pkg_cond $pkgname] while {[tsv::get zzzload_pkg $pkgname] eq "loading"} { - thread::cond wait $cond $mutex 3000 + thread::cond wait $cond $mutex 3000 } set result [tsv::get zzzload_pkg $pkgname] thread::mutex unlock $mutex