#we need to actually define these procs here, (not import then re-export) - or namespace origin will report the original source namespace - which isn't what we want.
#we need to actually define these procs here, (not import then re-export) - or namespace origin will report the original source namespace - which isn't what we want.
proc assertActive {expr args} [info body ::punk::assertion::primary::assertActive]
set info_command [namespace eval $nscaller {info commands assert}]
set info_command [tcl::namespace::eval $nscaller {tcl::info::commands assert}]
if {$on_off} {
if {$on_off} {
#Enable it in calling namespace
#Enable it in calling namespace
if {"assert" eq $info_command} {
if {"assert" eq $info_command} {
#There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure)
#There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure)
if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} {
if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} {
namespace eval $nscaller {
tcl::namespace::eval $nscaller {
set assertorigin [namespace origin assert]
set assertorigin [tcl::namespace::origin assert]
set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin]
set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin]
#assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace
#assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace
namespace eval $nscaller {
tcl::namespace::eval $nscaller {
set assertorigin [namespace origin assert]
set assertorigin [tcl::namespace::origin assert]
if {[string match ::punk::assertion::* $assertorigin]} {
if {[tcl::string::match ::punk::assertion::* $assertorigin]} {
error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin"
error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin"
error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin"
error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin"
set registrationobj ::${providerpkg}::capsystem::capprovider.registration
set registrationobj ::${providerpkg}::capsystem::capprovider.registration
if {[info commands $registrationobj] eq ""} {
if {[tcl::info::commands $registrationobj] eq ""} {
error "capprovider.provider constructor error. Missing capprovider.registration interface at '$obj' (command not found) interface_capprovider.regstration instantiation must precede interface_capprovider.provider"
error "capprovider.provider constructor error. Missing capprovider.registration interface at '$obj' (command not found) interface_capprovider.regstration instantiation must precede interface_capprovider.provider"
}
}
set provider_pkg [string trim $providerpkg ""]
#review - what are we trying to achieve here?
set provider_pkg [tcl::string::trim $providerpkg ""]
}
}
method register {{capabilityname_glob *}} {
method register {{capabilityname_glob *}} {
#*** !doctools
#*** !doctools
@ -232,13 +232,13 @@ namespace eval punk::cap {
#such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname.
#such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname.
#we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later.
#we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later.
#normalize with leading :: in case caller passed in package name rather than fully qualified namespace
#normalize with leading :: in case caller passed in package name rather than fully qualified namespace
if {![string match ::* $capnamespace]} {
if {![tcl::string::match ::* $capnamespace]} {
set capnamespace ::$capnamespace
set capnamespace ::$capnamespace
}
}
}
}
@ -250,20 +250,21 @@ namespace eval punk::cap {
return
return
}
}
#assertion: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries.
#assertion: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries.
if {![tcl::dict::exists $caps $capname providers]} {
dict set caps $capname providers [list]
tcl::dict::set caps $capname providers [list]
}
}
if {[llength [set providers [dict get $caps $capname providers]]]} {
if {[llength [set providers [tcl::dict::get $caps $capname providers]]]} {
#some provider(s) were in place before the handler was registered
#some provider(s) were in place before the handler was registered
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} {
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} {
foreach pkg $providers {
foreach pkg $providers {
set fullcapabilitylist [dict get $pkgcapsdeclared $pkg]
set fullcapabilitylist [tcl::dict::get $pkgcapsdeclared $pkg]
foreach capspec $fullcapabilitylist {
set capname_capabilitylist [lsearch -all -inline -index 0 $fullcapabilitylist $capname]
foreach capspec $capname_capabilitylist {
lassign $capspec cn capdict
lassign $capspec cn capdict
if {$cn ne $capname} {
#if {$cn ne $capname} {
continue
# continue
}
#}
if {[catch {$capreg pkg_register $pkg $capdict $fullcapabilitylist} do_register]} {
if {[catch {$capreg pkg_register $pkg $capdict $fullcapabilitylist} do_register]} {
puts stderr "punk::cap::register_capabilityname '$capname' '$capnamespace' failed to register provider package '$pkg' - possible error in handler or provider"
puts stderr "punk::cap::register_capabilityname '$capname' '$capnamespace' failed to register provider package '$pkg' - possible error in handler or provider"
puts stderr "error message:"
puts stderr "error message:"
@ -271,22 +272,22 @@ namespace eval punk::cap {
set do_register 0
set do_register 0
}
}
set list_accepted [dict get $pkgcapsaccepted $pkg]
set list_accepted [tcl::dict::get $pkgcapsaccepted $pkg]
if {$do_register} {
if {$do_register} {
if {$capspec ni $list_accepted} {
if {$capspec ni $list_accepted} {
dict lappend pkgcapsaccepted $pkg $capspec
tcl::dict::lappend pkgcapsaccepted $pkg $capspec
}
}
} else {
} else {
set posn [lsearch $list_accepted $capspec]
set posn [lsearch $list_accepted $capspec]
if {$posn >=0} {
if {$posn >=0} {
set list_accepted [lreplace $list_accepted $posn $posn]
set list_accepted [lreplace $list_accepted $posn $posn]
#Return the base namespace of the active handler package for the named capability.
#Return the base namespace of the active handler package for the named capability.
#[para] The base namespace for a handler will always be the package name, but prefixed with ::
#[para] The base namespace for a handler will always be the package name, but prefixed with ::
variable caps
variable caps
if {[dict exists $caps $capname]} {
if {[tcl::dict::exists $caps $capname]} {
return [dict get $caps $capname handler]
return [tcl::dict::get $caps $capname handler]
}
}
return ""
return ""
}
}
@ -338,8 +339,8 @@ namespace eval punk::cap {
}
}
proc get_providers {capname} {
proc get_providers {capname} {
variable caps
variable caps
if {[dict exists $caps $capname]} {
if {[tcl::dict::exists $caps $capname]} {
return [dict get $caps $capname providers]
return [tcl::dict::get $caps $capname providers]
}
}
return [list]
return [list]
}
}
@ -356,26 +357,26 @@ namespace eval punk::cap {
foreach {k v} $args {
foreach {k v} $args {
switch -- $k {
switch -- $k {
-nowarnings {
-nowarnings {
dict set opts $k $v
tcl::dict::set opts $k $v
}
}
default {
default {
error "Unrecognized option $k. Known options [dict keys $opts]"
error "Unrecognized option $k. Known options [tcl::dict::keys $opts]"
}
}
}
}
}
}
set warnings [expr {! [dict get $opts -nowarnings]}]
set warnings [expr {! [tcl::dict::get $opts -nowarnings]}]
if {[string match ::* $pkg]} {
if {[tcl::string::match ::* $pkg]} {
set pkg [string range $pkg 2 end]
set pkg [tcl::string::range $pkg 2 end]
}
}
if {[dict exists $pkgcapsaccepted $pkg]} {
if {[tcl::dict::exists $pkgcapsaccepted $pkg]} {
set pkg_already_accepted [dict get $pkgcapsaccepted $pkg]
set pkg_already_accepted [tcl::dict::get $pkgcapsaccepted $pkg]
} else {
} else {
set pkg_already_accepted [list]
set pkg_already_accepted [list]
}
}
package require $pkg
package require $pkg
set providerapi ::${pkg}::provider
set providerapi ::${pkg}::provider
if {[info commands $providerapi] eq ""} {
if {[tcl::info::commands $providerapi] eq ""} {
error "register_package error. pkg '$pkg' doesn't seem to be a punk::cap capability provider (no object found at $providerapi)"
error "register_package error. pkg '$pkg' doesn't seem to be a punk::cap capability provider (no object found at $providerapi)"
}
}
set defined_caps [$providerapi capabilities]
set defined_caps [$providerapi capabilities]
@ -397,13 +398,13 @@ namespace eval punk::cap {
if {[llength $capname] !=1} {
if {[llength $capname] !=1} {
puts stderr "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'"
puts stderr "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'"
set reason "First element of capspec not a single-word name"
set reason "First element of capspec not a single-word name"
puts stderr "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'"
puts stderr "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'"
set reason "The second element of the capspec isn't a valid dict"
set reason "The second element of the capspec isn't a valid dict"
set provide_statement [package ifneeded $pkg [package require $pkg]]
set provide_statement [package ifneeded $pkg [package require $pkg]]
set tmfile [lindex $provide_statement end]
set tmfile [lindex $provide_statement end]
if {[interp issafe]} {
#default safe interp can't use file exists/normalize etc.. but safe interp may have a policy/alias set allowing file access to certain paths - so test if file exists is usable
if {[catch {file exists $tmfile} tm_exists]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING (expected in most safe interps) - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
flush stderr
return 0
}
} else {
set tm_exists [file exists $tmfile]
}
if {![file exists $tmfile]} {
if {![file exists $tmfile]} {
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability"
set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results
set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results
set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
set dirs [glob -nocomplain -dir $folderpath -types d $opt_glob]
set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob]
set hlinks [glob -nocomplain -dir $folderpath -types {hidden l} $opt_glob]
set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove
set links [glob -nocomplain -dir $folderpath -types l $opt_glob] ;#links may have dupes - we don't care. struct::set difference will remove (?)
set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob]
set hfiles [glob -nocomplain -dir $folderpath -types {hidden f} $opt_glob]
set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
set files [glob -nocomplain -dir $folderpath -types f $opt_glob]
}
}
#note struct::set difference produces unordered result
#note struct::set difference produces unordered result
#struct::set difference removes duplicates
#struct::set difference removes duplicates (but not always.. e.g if using tcl impl and 2nd element empty!)
#relying on struct::set to remove dupes is somewhat risky. It is not well documented - and behaviour of dupes in inputs is underspecified as it appears to be intended for mathematical 'sets'
#remove links and . .. from directories, remove links from files
#remove links and . .. from directories, remove links from files
#struct::set will affect order: tcl vs critcl give different ordering!
set files [struct::set difference [concat $hfiles $files[unset files]] $links]
set files [struct::set difference [concat $hfiles $files[unset files]] $links]
#tcl 8.7+ lseq significantly faster, especially for larger ranges
#tcl 8.7+ lseq significantly faster for larger ranges
#support minimal set from to
return [lseq $from $to]
proc range {from to} {
lseq $from $to
}
} else {
#lseq accepts basic expressions e.g 4-2 for both arguments
#e.g we can do lseq 0 [llength $list]-1
#if range is to be consistent with the lseq version above - it should support that, even though we don't support most lseq functionality in either wrapper.
proc range {from to} {
set to [offset_expr $to]
set from [offset_expr $from]
if {$to > $from} {
set count [expr {($to -$from) + 1}]
if {$from == 0} {
return [lsearch -all [lrepeat $count 0] *]
} else {
incr from -1
return [lmap v [lrepeat $count 0] {incr from}]
}
#slower methods.
#2)
#set i -1
#set L [lrepeat $count 0]
#lmap v $L {lset L [incr i] [incr from];lindex {}}
set opt_keysorttype [dict get $argd opts -keysorttype]
set opt_keysortdirection [dict get $argd opts -keysortdirection]
set opt_trimright [dict get $argd opts -trimright]
set opt_ansibase_key [dict get $argd opts -ansibase_keys]
set opt_ansibase_value [dict get $argd opts -ansibase_values]
set opt_return [dict get $argd opts -return]
set dval [dict get $argd values dictvalue]
set patterns [dict get $argd values patterns]
set result ""
set filtered_keys [list]
foreach p $patterns {
lappend filtered_keys {*}[dict keys $dval $p]
}
if {$opt_keysorttype eq "none"} {
#we can only get duplicate keys if there are multiple patterns supplied
#ignore keysortdirection - doesn't apply
if {[llength $patterns] > 1} {
#order-maintaining (order of keys as they appear in dict)
set filtered_keys [punk::lib::lunique $filtered_keys]
}
} else {
set filtered_keys [lsort -unique -$opt_keysorttype $opt_keysortdirection $filtered_keys]
}
if {[llength $filtered_keys]} {
#both keys and values could have newline characters.
#simple use of 'format' won't cut it for more complex dict keys/values
#use block::width or our columns won't align in some cases
set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]]
set RST [a]
switch -- $opt_return {
"tailtohead" {
#last line of key is side by side (possibly with separator) with first line of value
#This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values
#we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries
lassign [textblock::size [dict get $dval $key]] _vw vwidth _vh vheight
set totalheight [expr {$kheight + $vheight -1}]
set blanks_above [string repeat \n [expr {$kheight -1}]]
set blanks_below [string repeat \n [expr {$vheight -1}]]
set sepwidth [textblock::width $opt_sep]
#append result [textblock::pad $opt_ansibase_key$key$RST -width $maxl] $opt_sep $opt_ansibase_value[dict get $dval $key]$RST \n
set kblock [textblock::pad $opt_ansibase_key$key$RST$blanks_below -width $maxl]
set sblock [textblock::pad $blanks_above$opt_sep$blanks_below -width $sepwidth]
set vblock $blanks_above$opt_ansibase_value[dict get $dval $key]$RST
#only vblock is ragged - we can do a basic join because we don't care about rhs whitespace
append result [textblock::join_basic $kblock $sblock $vblock] \n
}
}
"sidebyside" {
#This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs.
#use ansibase_key etc to make the output more comprehensible in that situation.
#This is why it is not the default. (review - terminal width detection and wrapping?)
foreach key $filtered_keys {
#append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n
#differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic
append result [textblock::join -- [textblock::pad $opt_ansibase_key$key$RST -width $maxl] $opt_sep "$opt_ansibase_value[dict get $dval $key]$RST"] \n
}
}
}
}
if {$opt_trimright} {
set result [::join [lines_as_list -line trimright $result] \n]
}
if {[string last \n $result] == [string length $result]-1} {
set result [string range $result 0 end-1]
}
#stdout/stderr can exist but not be in 'chan names' (e.g when transforms in place)
set chan [dict get $argd opts -channel]
switch -- $chan {
stderr - stdout {
puts $chan $result
}
none {
return $result
}
default {
#review - check member of chan names?
#just try outputting to the supplied channel for now
puts $chan $result
}
}
}
proc is_list_all_in_list {small large} {
proc is_list_all_in_list {small large} {
package require struct::list
package require struct::list
package require struct::set
package require struct::set
@ -356,7 +533,87 @@ namespace eval punk::lib {
return [expr {[llength $i] == 0}]
return [expr {[llength $i] == 0}]
}
}
#somewhat like struct::set difference - but order preserving, and doesn't treat as a 'set' so preserves dupes in fromlist
#struct::set difference may happen to preserve ordering when items are integers, but order can't be relied on,
# especially as struct::set has 2 differing implementations (tcl vs critcl) which return results with different ordering to each other and different deduping behaviour in some cases (e.g empty 2nd arg)
proc ldiff {fromlist removeitems} {
if {[llength $removeitems] == 0} {return $fromlist}
#The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env
#The closure-like behaviour is *very* slow especially when called from a context such as the global namespace with lots of vars and large arrays such as ::env
proc lmapflat_closure {varnames list script} {
proc lmapflat_closure {varnames list script} {
set result [list]
set result [list]
@ -368,29 +625,29 @@ namespace eval punk::lib {
#capture - use uplevel 1 or namespace eval depending on context
#capture - use uplevel 1 or namespace eval depending on context
set capture [uplevel 1 {
set capture [uplevel 1 {
apply { varnames {
apply { varnames {
set capturevars [dict create]
set capturevars [tcl::dict::create]
set capturearrs [dict create]
set capturearrs [tcl::dict::create]
foreach fullv $varnames {
foreach fullv $varnames {
set v [namespace tail $fullv]
set v [tcl::namespace::tail $fullv]
upvar 1 $v var
upvar 1 $v var
if {[info exists var]} {
if {[info exists var]} {
if {(![array exists var])} {
if {(![array exists var])} {
dict set capturevars $v $var
tcl::dict::set capturevars $v $var
} else {
} else {
dict set capturearrs capturedarray_$v [array get var]
tcl::dict::set capturearrs capturedarray_$v [array get var]
}
}
} else {
} else {
#A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set
#A variable can show in the results for 'info vars' but still not 'exist'. e.g a 'variable x' declaration in the namespace where the variable has never been set
}
}
}
}
return [dict create vars $capturevars arrs $capturearrs]
return [tcl::dict::create vars $capturevars arrs $capturearrs]
} } [info vars]
} } [info vars]
} ]
} ]
# -- --- ---
# -- --- ---
set cvars [dict get $capture vars]
set cvars [tcl::dict::get $capture vars]
set carrs [dict get $capture arrs]
set carrs [tcl::dict::get $capture arrs]
set apply_script ""
set apply_script ""
foreach arrayalias [dict keys $carrs] {
foreach arrayalias [tcl::dict::keys $carrs] {
set realname [string range $arrayalias [string first _ $arrayalias]+1 end]
set realname [string range $arrayalias [string first _ $arrayalias]+1 end]
#eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible?
#eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible?
#-anyopts 1 avoids having to know what to say if odd numbers of options passed etc
#-anyopts 1 avoids having to know what to say if odd numbers of options passed etc
#we don't have to decide what is an opt vs a value
#we don't have to decide what is an opt vs a value
#even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block)
#even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block)
set opt_commandprefix [dict get $opts -commandprefix]
set opt_commandprefix [tcl::dict::get $opts -commandprefix]
# -- --- --- --- --- ---
# -- --- --- --- --- ---
set opt_ansiresets [dict get $opts -ansiresets]
set opt_ansiresets [tcl::dict::get $opts -ansiresets]
# -- --- --- --- --- ---
# -- --- --- --- --- ---
set opt_ansireplays [dict get $opts -ansireplays]
set opt_ansireplays [tcl::dict::get $opts -ansireplays]
if {$opt_ansireplays} {
if {$opt_ansireplays} {
if {$opt_ansiresets eq "auto"} {
if {$opt_ansiresets eq "auto"} {
set opt_ansiresets 1
set opt_ansiresets 1
@ -1414,7 +1695,11 @@ namespace eval punk::lib {
set replaycodes $RST ;#todo - default?
set replaycodes $RST ;#todo - default?
set transformed [list]
set transformed [list]
#shortcircuit common case of no ansi
#shortcircuit common case of no ansi
if {![punk::ansi::ta::detect $linelist]} {
#NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the have backslash escapes due to Tcl list quoting and escaping behaviour.
#This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled)
#ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable
#detect_in_list will check at first level. (not intended for detecting ansi in deeper structures)
if {![punk::ansi::ta::detect_in_list $linelist]} {
if {$opt_ansiresets} {
if {$opt_ansiresets} {
foreach ln $linelist {
foreach ln $linelist {
lappend transformed $RST$ln$RST
lappend transformed $RST$ln$RST
@ -1604,8 +1889,29 @@ namespace eval punk::lib {
}
}
#we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164)
#we are interested in seeing jumpTable line and following lines up until next line starting with "Command" or bracketed number e.g (164)
proc show_jump_tables {procname} {
proc show_jump_tables {args} {
set data [tcl::unsupported::disassemble proc $procname]
#avoiding use of 'info cmdtype' as unavaliable in safe interps as at 2024-06.
if {[llength $args] == 1} {
set data [tcl::unsupported::disassemble proc [lindex $args 0]]
} elseif {[llength $args] == 2} {
#review - this looks for direct methods on the supplied object/class, and then tries to disassemble method on the supplied class or class of supplied object if it isn't a class itself.
#not sure if this handles more complex hierarchies or mixins etc.
lassign $args obj method
if {![info object isa object $obj]} {
error "show_jump_tables unable to examine '$args'. $obj is not an oo object"
}
#classes are objects too and can have direct methods
if {$method in [info object methods $obj]} {
set data [tcl::unsupported::disassemble objmethod $obj $method]
} else {
if {![info object isa class $obj]} {
set obj [info object class $obj]
}
set data [tcl::unsupported::disassemble method $obj $method]
}
} else {
error "show_jump_tables expected a procname or a class/object and method"
}
set result ""
set result ""
set in_jt 0
set in_jt 0
foreach ln [split $data \n] {
foreach ln [split $data \n] {
@ -1626,6 +1932,12 @@ namespace eval punk::lib {
return $result
return $result
}
}
proc temperature_f_to_c {deg_fahrenheit} {
return [expr {($deg_fahrenheit -32) * (5/9.0)}]
}
proc temperature_c_to_f {deg_celsius} {
return [expr {($deg_celsius * (9/5.0)) + 32}]
}
#*** !doctools
#*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib ---}]
#[list_end] [comment {--- end definitions namespace punk::lib ---}]
}
}
@ -1639,7 +1951,7 @@ namespace eval punk::lib {
#todo - way to generate 'internal' docs separately?
#todo - way to generate 'internal' docs separately?
#*** !doctools
#*** !doctools
#[section Internal]
#[section Internal]
namespace eval punk::lib::system {
tcl::namespace::eval punk::lib::system {
#*** !doctools
#*** !doctools
#[subsection {Namespace punk::lib::system}]
#[subsection {Namespace punk::lib::system}]
#[para] Internal functions that are not part of the API
#[para] Internal functions that are not part of the API
set bytecode_outer [tcl::unsupported::disassemble proc [namespace current]::testcompile::ensembletest]
if {$show} {
puts outer:
puts $bytecode_outer
}
if {![interp issafe]} {
#test of safe subinterp only needed if we aren't already in a safe interp
if {![catch {
interp create x -safe
} errMsg]} {
x eval {proc ensembletest {} {string index a 0}}
set bytecode_safe [x eval {tcl::unsupported::disassemble proc ::ensembletest}]
if {$show} {
puts safe:
puts $bytecode_safe
}
interp delete x
#mainly we expect the safe interp might contain invokeStk - indicating not byte compiled (or we would see strindex instead)
#It's possible the interp we're running in is also not compiling ensembles.
#we could then get a result of 2 - which still indicates a problem
if {[string last "invokeStk" $bytecode_safe] >= 1} {
incr has_bug
}
} else {
#our failure to create a safe interp here doesn't necessarily mean the Tcl version doesn't have the problem - but we could end up returning zero if somehow safe interp can't be created from unsafe interp?
#unlikely - but we should warn
puts stderr "Unable to create a safe sub-interp to test - result only indicates status of current interpreter"
}
}
namespace delete [namespace current]::testcompile
if {[string last "invokeStk" $bytecode_outer] >= 1} {
#not just used by cksum_path. used by caller (e.g fill_relativecksums_from_base_and_relativepathdict via cksum_filter_opts) to determine what opt names passed through
#not just used by cksum_path. used by caller (e.g fill_relativecksums_from_base_and_relativepathdict via cksum_filter_opts) to determine what opt names passed through
variable cksum_default_opts
set cksum_default_opts [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1]
proc cksum_default_opts {} {
proc cksum_default_opts {} {
return [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1]
variable cksum_default_opts
return $cksum_default_opts
}
}
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?)
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?)
put stderr "get_template_basefolders WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations"
put stderr "get_template_basefolders WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations"
}
}
}
}
proc new {module args} {
proc new {args} {
set year [clock format [clock seconds] -format %Y]
set year [clock format [clock seconds] -format %Y]
set defaults [list\
set moduletypes [punk::mix::cli::lib::module_types]
-project \uFFFF\
# use \uFFFD because unicode replacement char should consistently render as 1 wide
-version \uFFFF\
set argspecs [subst {
-license <unspecified>\
-project -default \uFFFD
-template punk.module\
-version -default \uFFFD
-type \uFFFF\
-license -default <unspecified>
-force 0\
-template -default punk.module
-quiet 0\
-type -default \uFFFD -choices {$moduletypes}
]
-force -default 0 -type boolean
set opts [dict merge $defaults $args]
-quiet -default 0 -type boolean
*values -min 1 -max 1
module -type string
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] opts values
set module [dict get $values module]
#set opts [dict merge $defaults $args]
#todo - review compatibility between -template and -type
#todo - review compatibility between -template and -type
#-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl)
#-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl)
#NOTE: info procs within namespace eval is different to 'info commands' within namespace eval (info procs doesn't look outside of namespace)
#NOTE: info procs within tcl::namespace::eval is different to 'info commands' within tcl::namespace::eval (info procs doesn't look outside of namespace)
set allprocs [namespace eval $location {::info procs}]
set allprocs [tcl::namespace::eval $location {::info procs}]
#set allprocs [nseval $location {::info procs}]
#set allprocs [nseval $location {::info procs}]
set childtails [lmap v $allchildren {nstail $v}]
set childtails [lmap v $allchildren {nstail $v}]
set allaliases [list]
set allaliases [list]
@ -1120,7 +1133,7 @@ namespace eval punk::ns {
set interp_aliases [interp aliases ""]
set interp_aliases [interp aliases ""]
#use aliases glob - because aliases can be present with or without leading ::
#use aliases glob - because aliases can be present with or without leading ::
#NOTE: alias may not have matching command in the relevant namespce (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases
#NOTE: alias may not have matching command in the relevant namespce (renamed alias) so we can't just start with commands and check if it's an alias if we want to show all aliases
set raw_aliases [namespace eval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval.
set raw_aliases [tcl::namespace::eval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval.
#set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval.
#set raw_aliases [nseval $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval.
#\\servername\share etc or \\?\UNC\servername\share etc.
#\\servername\share etc or \\?\UNC\servername\share etc.
proc is_unc_path {path} {
proc is_unc_path {path} {
set strcopy_path [punk::objclone $path]
set strcopy_path [punk::objclone $path]
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway)
set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway)
if {[string first "//" $strcopy_path] == 0} {
if {[string first "//" $strcopy_path] == 0} {
#check for "Dos device path" syntax
#check for "Dos device path" syntax
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} {
if {[string range $strcopy_path 0 3] in {//?/ //./}} {
#Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share)
#Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share)
if {[string range $strcopy_path 4 6] eq "UNC"} {
if {[string range $strcopy_path 4 6] eq "UNC"} {
return 1
return 1
@ -78,8 +78,8 @@ namespace eval punk::winpath {
#(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax)
#(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax)
proc is_dos_device_path {path} {
proc is_dos_device_path {path} {
set strcopy_path [punk::objclone $path]
set strcopy_path [punk::objclone $path]
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway)
set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway)
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} {
if {[string range $strcopy_path 0 3] in {//?/ //./}} {
