You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2890 lines
132 KiB
2890 lines
132 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2023 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::ns 999999.0a1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
##e.g package require frobz |
|
package require punk::lib |
|
package require punk::args |
|
|
|
tcl::namespace::eval ::punk::ns::evaluator { |
|
#eval-_NS_xxx_NS_etc procs |
|
} |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
tcl::namespace::eval punk::ns { |
|
variable ns_current "::" |
|
variable ns_re_cache [dict create] ;#cache regular expressions used in globmatchns |
|
namespace export nsjoin nsprefix nstail nsparts nseval nschildren nsimport_noclobber corp |
|
catch { |
|
package require debug |
|
debug define punk.ns.compile |
|
#debug on punk.ns.compile |
|
#debug level punk.ns.compile 3 |
|
} |
|
|
|
#leading colon makes it hard (impossible?) to call directly if not within the namespace |
|
proc ns/ {v {ns_or_glob ""} args} { |
|
variable ns_current ;#change active ns of repl by setting ns_current |
|
|
|
set ns_caller [uplevel 1 {::namespace current}] |
|
#puts stderr "ns_cur:$ns_current ns_call:$ns_caller" |
|
|
|
|
|
set types [list all] |
|
set nspathcommands 0 |
|
if {$v eq "/"} { |
|
set types [list children] |
|
} |
|
if {$v eq "///"} { |
|
set nspathcommands 1 |
|
} |
|
|
|
set ns_or_glob [string map {:::: ::} $ns_or_glob] |
|
|
|
#todo - cooperate with repl? |
|
set out "" |
|
if {$ns_or_glob eq ""} { |
|
set is_absolute 1 |
|
set ns_queried $ns_current |
|
set out [nslist [nsjoin $ns_current *] -types $types -nspathcommands $nspathcommands] |
|
} else { |
|
set is_absolute [string match ::* $ns_or_glob] |
|
set has_globchars [regexp {[*?]} $ns_or_glob] |
|
if {$is_absolute} { |
|
if {!$has_globchars} { |
|
if {![nsexists $ns_or_glob]} { |
|
error "cannot change to namespace $ns_or_glob" |
|
} |
|
set ns_current $ns_or_glob |
|
set ns_queried $ns_current |
|
tailcall ns/ $v "" |
|
} else { |
|
set ns_queried $ns_or_glob |
|
set out [nslist $ns_or_glob -types $types -nspathcommands $nspathcommands] |
|
} |
|
} else { |
|
if {!$has_globchars} { |
|
set nsnext [nsjoin $ns_current $ns_or_glob] |
|
if {![nsexists $nsnext]} { |
|
error "cannot change to namespace $ns_or_glob" |
|
} |
|
set ns_current $nsnext |
|
set ns_queried $nsnext |
|
set out [nslist [nsjoin $nsnext *] -types $types -nspathcommands $nspathcommands] |
|
} else { |
|
set ns_queried [nsjoin $ns_current $ns_or_glob] |
|
set out [nslist [nsjoin $ns_current $ns_or_glob] -types $types -nspathcommands $nspathcommands] |
|
} |
|
} |
|
} |
|
set ns_display "\n$ns_queried" |
|
if {$ns_current eq $ns_queried} { |
|
if {$ns_current in [info commands $ns_current] } { |
|
if {![catch [list tcl::namespace::ensemble configure $ns_current] ensemble_info]} { |
|
if {[llength $ensemble_info] > 0} { |
|
#this namespace happens to match ensemble command. |
|
#todo - keep cache of encountered ensembles from commands.. and examine namespace in the configure info. |
|
set ns_display "\n[a+ yellow bold]$ns_current (ensemble)[a+]" |
|
} |
|
} |
|
} |
|
} |
|
append out $ns_display |
|
return $out |
|
|
|
|
|
} |
|
|
|
|
|
#create possibly nested namespace structure - but only if not already existant |
|
proc n/new {args} { |
|
variable ns_current |
|
if {![llength $args]} { |
|
error "usage: :/new <ns> \[<ns> ...\]" |
|
} |
|
set a1 [lindex $args 0] |
|
set is_absolute [string match ::* $a1] |
|
if {$is_absolute} { |
|
set nspath [nsjoinall {*}$args] |
|
} else { |
|
if {[string match :* $a1]} { |
|
puts stderr "n/new WARNING namespace with leading colon '$a1' is likely to have unexpected results" |
|
} |
|
set nspath [nsjoinall $ns_current {*}$args] |
|
} |
|
|
|
set ns_exists [nseval [nsprefix $nspath] [list ::tcl::namespace::exists [nstail $nspath] ]] |
|
|
|
if {$ns_exists} { |
|
error "Namespace $nspath already exists" |
|
} |
|
#tcl::namespace::eval [nsprefix $nspath] [list tcl::namespace::eval [nstail $nspath] {}] |
|
nseval [nsprefix $nspath] [list ::tcl::namespace::eval [nstail $nspath] {}] |
|
n/ $nspath |
|
} |
|
|
|
|
|
#nn/ ::/ nsup/ - back up one namespace level |
|
proc nsup/ {v args} { |
|
variable ns_current |
|
if {$ns_current eq "::"} { |
|
puts stderr "Already at global namespace '::'" |
|
} else { |
|
set out "" |
|
set nsq [nsprefix $ns_current] |
|
if {$v eq "/"} { |
|
set out [get_nslist -match [nsjoin $nsq *] -types [list children]] |
|
} else { |
|
set out [get_nslist -match [nsjoin $nsq *] -types [list all]] |
|
} |
|
#set out [nslist [nsjoin $nsq *]] |
|
set ns_current $nsq |
|
append out "\n$ns_current" |
|
return $out |
|
} |
|
} |
|
|
|
#todo - walk up each ns - testing for possibly weirdly named namespaces |
|
#needed to use n/ to change to an oddly named namespace such as ":x" |
|
proc nsexists {nspath} { |
|
if {$nspath eq ""} {return 0} |
|
set parts [nsparts $nspath] |
|
if {[lindex $parts 0] ne ""} { |
|
#relative |
|
set ns_caller [uplevel 1 {::namespace current}] |
|
set fq_nspath [nsjoin $ns_caller $nspath] |
|
} else { |
|
set fq_nspath $nspath |
|
} |
|
if {[catch {nseval_ifexists $fq_nspath {}}]} { |
|
return 0 |
|
} else { |
|
return 1 |
|
} |
|
} |
|
|
|
#recursive nseval - for introspection of weird namespace trees |
|
#approx 10x slower than normal tcl::namespace::eval - but still only a few microseconds.. fine for repl introspection |
|
#WARNING: creates namespaces if they don't exist |
|
proc nseval_getscript {location} { |
|
set parts [nsparts $location] |
|
if {[lindex $parts 0] eq ""} { |
|
lset parts 0 :: |
|
} |
|
if {[lindex $parts end] eq ""} { |
|
set parts [lrange $parts 0 end-1] |
|
} |
|
|
|
set body "" |
|
set i 0 |
|
set tails [lrepeat [llength $parts] ""] |
|
foreach ns $parts { |
|
set cmdlist [list ::tcl::namespace::eval $ns] |
|
set t "" |
|
if {$i > 0} { |
|
append body " <lb>" |
|
} |
|
append body $cmdlist |
|
if {$i == ([llength $parts] -1)} { |
|
append body " <script>" |
|
} |
|
if {$i > 0} { |
|
set t {<rb>} |
|
} |
|
lset tails $i $t |
|
incr i |
|
} |
|
append body [join [lreverse $tails] " "] |
|
#puts stdout "tails: $tails" |
|
#puts stdout "i: $i" |
|
set body [string map [list <lb> "\{" <rb> "\}"] $body] |
|
|
|
set scr {[::list ::eval [::uplevel <i> {::set script}]]} |
|
|
|
set up [expr {$i - 1}] |
|
set scr [string map "<i> $up" $scr] |
|
|
|
set body [string map [list <script> $scr] $body] |
|
return $body |
|
} |
|
proc nseval {fqns script} { |
|
#create one proc for each fully qualified namespace to evaluate script |
|
if {![string match ::* $fqns]} { |
|
error "nseval only accepts a fully qualified namespace" |
|
} |
|
set loc [string map {:: _NS_} $fqns] |
|
#set cmd ::punk::pipecmds::nseval_$loc |
|
set cmd ::punk::ns::evaluator::eval-$loc |
|
if {$cmd ni [info commands $cmd]} { |
|
append body \n [nseval_getscript $fqns] |
|
proc $cmd {script} $body |
|
debug.punk.ns.compile {proc $cmd} 2 |
|
} |
|
tailcall $cmd $script |
|
} |
|
proc nseval_ifexists {ns script} { |
|
set parts [nsparts $ns] |
|
if {[lindex $parts 0] ne ""} { |
|
#relative |
|
set nscaller [uplevel 1 {::tcl::namespace::current}] |
|
set nsfq [nsjoin $nscaller $ns] |
|
} else { |
|
set nsfq $ns |
|
} |
|
set ns_script [nseval_ifexists_getscript $nsfq] |
|
uplevel 1 [list {*}$ns_script $script] |
|
} |
|
proc nseval_ifexists_getscript {location} { |
|
set parts [nsparts $location] |
|
if {[lindex $parts 0] eq ""} { |
|
lset parts 0 :: |
|
} |
|
if {[lindex $parts end] eq ""} { |
|
set parts [lrange $parts 0 end-1] |
|
} |
|
|
|
set body "apply \{{script} \{eval \[string map \[list <s> \$script\] \{" |
|
set i 0 |
|
set tails [lrepeat [llength $parts] ""] |
|
foreach ns $parts { |
|
set cmdlist [list ::punk::ns::eval_no_create $ns] |
|
set t "" |
|
if {$i > 0} { |
|
append body " <lb>" |
|
} |
|
append body $cmdlist |
|
if {$i == ([llength $parts] -1)} { |
|
append body " {<s>}" |
|
} |
|
if {$i > 0} { |
|
set t {<rb>} |
|
} |
|
lset tails $i $t |
|
incr i |
|
} |
|
append body [join [lreverse $tails] " "] |
|
#puts stdout "tails: $tails" |
|
#puts stdout "i: $i" |
|
set body [string map [list <lb> "\{" <rb> "\}"] $body] |
|
append body " \}\]\}\}" |
|
return $body |
|
} |
|
proc eval_no_create {ns script} { |
|
uplevel 1 [string map [list <ns> $ns <scr> $script] { |
|
if {[::tcl::namespace::exists <ns>]} { |
|
::tcl::namespace::eval <ns> {<scr>} |
|
} else { |
|
error "no such namespace <ns>" |
|
} |
|
}] |
|
} |
|
|
|
|
|
proc nschildren {ns} { |
|
set parts [nsparts $ns] |
|
if {[lindex $parts 0] ne ""} { |
|
#relative |
|
set nscaller [uplevel 1 {::tcl::namespace::current}] |
|
set fqns [nsjoin $nscaller $ns] |
|
} else { |
|
set fqns $ns |
|
} |
|
#if {![string match ::* $fqns]} { |
|
# error "nschildren only accepts a fully qualified namespace" |
|
#} |
|
set parent [nsprefix $fqns] |
|
set tail [nstail $fqns] |
|
#puts ">>> parent $parent tail $tail" |
|
#set nslist [nseval $parent [list ::namespace children $tail]] |
|
#set nslist [tcl::namespace::eval $parent [list ::tcl::namespace::children $tail]] |
|
set nslist [nseval_ifexists $parent [list ::tcl::namespace::children $tail]] |
|
return [lsort $nslist] |
|
} |
|
|
|
#Note nsjoin,nsjoinall,nsprefix,nstail are string functions that don't care about namespaces in existence. |
|
#Some functions in punk::ns are |
|
|
|
proc nsjoin {prefix name} { |
|
if {[string match ::* $name]} { |
|
if {"$prefix" ne ""} { |
|
error "nsjoin: won't join non-empty prefix to absolute namespace path '$name'" |
|
} |
|
return $name |
|
} |
|
if {"$prefix" eq "::"} { |
|
return ::$name |
|
} |
|
#if {"$name" eq ""} { |
|
# return $prefix |
|
#} |
|
#nsjoin ::x::y "" should return ::x::y:: - this is the correct fully qualified form used to call a command that is the empty string |
|
return ${prefix}::$name |
|
} |
|
proc nsjoinall {prefix args} { |
|
#if {![llength $args]} { |
|
# error "usage: nsjoinall prefix relativens \[relativens ...\]" |
|
#} |
|
set segments [list $prefix] |
|
foreach sub $args { |
|
if {[string match ::* $sub]} { |
|
if {[string length [concat {*}$segments]]} { |
|
error "nsjoin: won't join non-empty namespace prefix to absolute namespace path '$sub'" |
|
} |
|
} |
|
lappend segments $sub |
|
} |
|
set nonempty_segments [list] |
|
foreach s $segments { |
|
if {[string length $s]} { |
|
lappend nonempty_segments $s |
|
} |
|
} |
|
if {$prefix eq "::"} { |
|
return ::[join [lrange $nonempty_segments 1 end] ::] |
|
} |
|
return [join $nonempty_segments ::] |
|
} |
|
|
|
|
|
#REVIEW - the combination of nsprefix & nstail are designed to *almost* always be able to reassemble the input, and to be independent of what namespaces actually exist |
|
#The main difference being collapsing (or ignoring) repeated double-colons |
|
#we need to distinguish unprefixed from prefixed ie ::x vs x |
|
#There is an apparent inconsistency with nstail ::a:::x being able to return :x |
|
#whereas nsprefix :::a will return just a |
|
#This is because :x (or even just : ) can in theory be the name of a command and we may need to see it (although it is not a good idea) |
|
#and a namespace can exist with leading colon - but is even worse - as default Tcl commands will misreport e.g namespace current within namespace eval |
|
#The view is taken that a namespace with leading/trailing colons is so error-prone that even introspection is unreliable so we will rule that out. |
|
# |
|
proc nsprefix {{nspath ""}} { |
|
#normalize the common case of :::: |
|
set nspath [string map {:::: ::} $nspath] |
|
set rawprefix [string range $nspath 0 end-[string length [nstail $nspath]]] |
|
if {$rawprefix eq "::"} { |
|
return $rawprefix |
|
} else { |
|
if {[string match *:: $rawprefix]} { |
|
return [string range $rawprefix 0 end-2] |
|
} else { |
|
return $rawprefix |
|
} |
|
#return [string trimright $rawprefix :] |
|
} |
|
} |
|
|
|
#namespace tail which handles :::cmd ::x:::y ::x:::/y etc in a specific manner for string processing |
|
#review - consider making -strict raise an error for unexpected sequences such as :::: or any situation with more than 2 colons together. |
|
proc nstail {nspath args} { |
|
#normalize the common case of :::: |
|
set nspath [string map {:::: ::} $nspath] |
|
set mapped [string map {:: \u0FFF} $nspath] |
|
set parts [split $mapped \u0FFF] |
|
|
|
set defaults [list -strict 0] |
|
set opts [dict merge $defaults $args] |
|
set strict [dict get $opts -strict] |
|
|
|
if {$strict} { |
|
foreach p $parts { |
|
if {[string match :* $p]} { |
|
error "nstail unpaired colon ':' in $nspath" |
|
} |
|
} |
|
} |
|
|
|
#e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. |
|
return [lindex $parts end] |
|
} |
|
|
|
#return a list of namespace segments - always with leading empty string for fully qualified namespace (ie for ::x) |
|
#'supports' to some extent unreasonable namespaces /commands such as x: ::x: ::x:::y |
|
#Can be used to either support use of such namespaces/commands - or as part of validation to disallow them |
|
#as opposed to silent behaviour of Tcl namespace commands which don't handle them consistently (for tcl 8.x anyway Review tcl 9) |
|
#Note that for ::x:: the trailing :: cannot represent a trailing namespace part being an empty string |
|
#This is because Tcl's 'tcl::namespace::eval "" ""' reports 'only global namespace can have empty name' |
|
#NOTE tcl allows creating ambiguous namespaces. e.g ::punk:::etc:::blah |
|
# is this :: punk :etc :blah or :: punk :etc: blah |
|
#clearly leading/trailing colons in namespaces and commands are just a bad idea. |
|
#nsparts will prefer leading colon (ie greedy on ::) |
|
#This is important to support leading colon commands such as :/ |
|
# ie ::punk:::jjj:::etc -> :: punk :jjj :etc |
|
proc nsparts {nspath} { |
|
set nspath [string map {:::: ::} $nspath] |
|
set mapped [string map {:: \u0FFF} $nspath] |
|
set parts [split $mapped \u0FFF] |
|
if {[lindex $parts end] eq ""} { |
|
|
|
} |
|
return $parts |
|
} |
|
|
|
#tcl 8.x has creative writing var weirdness.. tcl 9 is likely to differ |
|
proc nsvars {{nsglob "*"}} { |
|
set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $nsglob]] |
|
#set commandns [uplevel 1 [list namespace current]] |
|
|
|
set searchns [nsprefix $ns_absolute] ;#the ns within which we want to searchns |
|
set searchall [nsjoin $searchns *] ;#will correctly form ::* or ::childns::* |
|
|
|
set nsparts [nsparts $searchns] |
|
set weird_ns 0 |
|
if {[lsearch $nsparts :*] >=0} { |
|
set weird_ns 1 |
|
} |
|
if {$weird_ns} { |
|
set rawresult [nseval_ifexists $searchns [list info vars]] |
|
} else { |
|
set rawresult [info vars $searchall] ;#will not find vars in ::x:::y etc. - seems to be impossible in tcl 8.x |
|
} |
|
set matched_fullpath [list] |
|
foreach r $rawresult { |
|
lappend matched_fullpath [nstail $r] |
|
} |
|
|
|
set location [nsprefix $ns_absolute] |
|
set tailmatch [nstail $ns_absolute] |
|
set raw_matched_in_ns [nseval $location [list ::info vars $tailmatch]] |
|
#NOTE: tcl <9 will read vars from global namespace - so we are only checking the intersection here |
|
#(this is due to info vars ::etc:::blah failing to handle additional colon) |
|
set matched_in_ns [list] |
|
set result [list] |
|
foreach r $raw_matched_in_ns { |
|
set m [nstail $r] |
|
lappend matched_in_ns $m |
|
if {$m in $matched_fullpath} { |
|
lappend result $m |
|
} |
|
} |
|
|
|
|
|
return [list_as_lines -- [lsort $result]] |
|
#.= lsort $result |> list_as_lines -- |
|
} |
|
|
|
proc nsglob_as_re {glob} { |
|
#any segment that is not just * must match exactly one segment in the path |
|
set pats [list] |
|
foreach seg [nsparts $glob] { |
|
if {$seg eq ""} { |
|
set seg "" |
|
} |
|
if {$seg eq "*"} { |
|
lappend pats {[^:]*} |
|
} elseif {$seg eq "**"} { |
|
lappend pats {.*} |
|
} else { |
|
#set seg [string map [list . {[.]}] $seg] |
|
set seg [string map {. [.]} $seg] |
|
if {[regexp {[*?]} $seg]} { |
|
set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg] |
|
lappend pats "$pat" |
|
} else { |
|
lappend pats "$seg" |
|
} |
|
} |
|
} |
|
return "^[join $pats ::]\$" |
|
} |
|
proc globmatchns {glob path} { |
|
#the total set of namespaces is *generally* reasonably bounded so we could just cache all globs, perhaps with some pretty high limit for sanity.. (a few thousand?) review - memory cost? |
|
# Tcl (reportedly https://wiki.tcl-lang.org/page/regexp) only caches 'up to 30'dynamically - but should cache more if more stored. |
|
variable ns_re_cache |
|
if {![dict exists $ns_re_cache $glob]} { |
|
if {[dict size $ns_re_cache] > 4200} { |
|
#shimmer dict to list and back doesn't seem to affect internal rep of regexp items therein. |
|
set ns_re_cache [lrange $ns_re_cache 400 end] ;#chop 200 items off beginning of dict |
|
} |
|
dict set ns_re_cache $glob [nsglob_as_re $glob] |
|
} |
|
return [regexp [dict get $ns_re_cache $glob] $path] |
|
} |
|
|
|
proc nstree {{location ""}} { |
|
if {![string match ::* $location]} { |
|
set nscaller [uplevel 1 {::namespace current}] |
|
set location [nsjoin $nscaller $location] |
|
} |
|
list_as_lines [nstree_list $location] |
|
} |
|
|
|
|
|
#important: add tests for tricky cases - e.g punk::m**::util vs punk::m*::util vs punk::m*::**::util - these should all be able to return different results depending on namespace structure. |
|
#e.g punk::m**::util will return punk::mix::util but punk::m*::**::util will not because punk::mix::util is too short to match. Both will return deeper matches such as: punk::mix::commandset::repo::util |
|
proc nstree_list {location args} { |
|
package require struct::list |
|
#puts "> nstree_list $location $args" |
|
set defaults [dict create\ |
|
-call-depth-internal 0\ |
|
-subnslist {}\ |
|
-allbelow 1\ |
|
] |
|
set opts [dict merge $defaults $args] |
|
# -- ---- --- --- --- --- |
|
set CALLDEPTH [dict get $opts -call-depth-internal] |
|
set subnslist [dict get $opts -subnslist] |
|
set allbelow [dict get $opts -allbelow] ;#whether to return matches longer than the matched glob-path |
|
# -- ---- --- --- --- --- |
|
|
|
set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $location]] |
|
set has_globchars [regexp {[*?]} $ns_absolute] ;#don't use regexes on plain namespaces with no glob chars |
|
if {!$has_globchars && !$allbelow && ![llength $subnslist]} { |
|
#short circuit trivial case |
|
return [list $location] |
|
} |
|
|
|
|
|
set base "" |
|
set tailparts [list] |
|
if {$CALLDEPTH == 0} { |
|
set parts [nsparts $ns_absolute] |
|
lset parts 0 :: |
|
set idx 0 |
|
if {$has_globchars} { |
|
foreach seg $parts { |
|
if {![regexp {[*?]} $seg]} { |
|
set base [nsjoin $base $seg] |
|
} else { |
|
set tailparts [lrange $parts $idx end] |
|
break |
|
} |
|
incr idx |
|
} |
|
} else { |
|
set base $ns_absolute |
|
} |
|
} else { |
|
set base $location |
|
set tailparts $subnslist |
|
} |
|
if {![tcl::namespace::exists $base]} { |
|
return [list] |
|
} |
|
#set parent [nsprefix $ns_absolute] |
|
#set tail [nstail $ns_absolute] |
|
|
|
#set allchildren [lsort [nseval $base [list ::namespace children]]] |
|
set allchildren [lsort [tcl::namespace::eval $base [list ::namespace children]]] |
|
|
|
#puts "->base:$base tailparts:$tailparts allchildren: $allchildren" |
|
#puts "->base:$base tailparts:$tailparts childcount: [llength $allchildren]" |
|
|
|
#** only significant when it is the trailing part of a segment eg ::**::xxx ::a**::xxx |
|
if {[llength $tailparts]} { |
|
set nextglob [lindex $tailparts 0] |
|
if {$nextglob eq "**"} { |
|
set nslist [nstree_list $base -subnslist {} -allbelow 1] |
|
} elseif {[regexp {[*]{2}$} $nextglob]} { |
|
set nslist [list] |
|
lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] |
|
foreach ch $nsmatches { |
|
lappend nslist $ch |
|
#lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 1] |
|
lappend nslist {*}[nstree_list $ch -subnslist [list "**" {*}[lrange $tailparts 1 end]] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow 0] |
|
} |
|
} else { |
|
#lsearch with -glob ok even if nextglob has no globchars (no discernable speed diff, and earlier parts may have globchars anyway) |
|
set nslist [list] |
|
lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] |
|
if {[llength $tailparts] >1 || $allbelow} { |
|
foreach ch $nsmatches { |
|
lappend nslist $ch |
|
lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] |
|
} |
|
} else { |
|
#if only one tailpart remaining and not $allbelow - then we already have what we need |
|
set nslist $nsmatches |
|
} |
|
} |
|
} else { |
|
#puts "nstree_list: no tailparts base:$base" |
|
if {$allbelow} { |
|
set nsmatches $allchildren |
|
set nslist [list] |
|
foreach ch $nsmatches { |
|
lappend nslist $ch |
|
lappend nslist {*}[nstree_list $ch -subnslist {} -call-depth-internal 0 -allbelow 1] |
|
} |
|
} else { |
|
set nslist $allchildren |
|
} |
|
#set nsmatches $allchildren |
|
#set nslist [nstree_list $base -subnslist {} -allbelow 0] |
|
} |
|
set nslist [lsort -unique $nslist] |
|
|
|
|
|
if 0 { |
|
set nextglob [lindex $tailparts 0] |
|
if {$nextglob ne "**"} { |
|
set nslist [list] |
|
if {[llength $tailparts]} { |
|
set nsmatches [list] |
|
#lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]::*] |
|
lappend nsmatches {*}[lsearch -all -inline -glob $allchildren [nsjoin ${base} $nextglob]] |
|
} else { |
|
set nsmatches $allchildren |
|
} |
|
#return |
|
|
|
foreach ch $nsmatches { |
|
lappend nslist $ch |
|
lappend nslist {*}[nstree_list $ch -subnslist [lrange $tailparts 1 end] -call-depth-internal [expr {$CALLDEPTH + 1}] -allbelow $allbelow] |
|
} |
|
} else { |
|
set nslist [nstree_list $base -subnslist {} -allbelow 1] |
|
} |
|
} |
|
|
|
#foreach ns $nslist { |
|
# puts "== $ns" |
|
#} |
|
set nslist_filtered [list] |
|
if {$CALLDEPTH == 0} { |
|
#puts "--base: $base" |
|
#puts "-- globmatchns [nsjoin ${ns_absolute} **]" |
|
#puts "-- globmatchns ${ns_absolute}" |
|
if {$base ni $nslist} { |
|
#puts stderr "> adding $base to $nslist" |
|
set nslist [list $base {*}$nslist] |
|
} |
|
if {$has_globchars} { |
|
if {$allbelow} { |
|
foreach ns $nslist { |
|
if {[globmatchns ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { |
|
lappend nslist_filtered $ns |
|
} |
|
} |
|
} else { |
|
set nslist_filtered [struct::list::Lfilter $nslist [list globmatchns ${ns_absolute}]] |
|
} |
|
} else { |
|
if {$allbelow} { |
|
foreach ns $nslist { |
|
if {[string equal ${ns_absolute} $ns] || [globmatchns [nsjoin ${ns_absolute} **] $ns]} { |
|
lappend nslist_filtered $ns |
|
} |
|
} |
|
} else { |
|
#set nslist_filtered [struct::list::Lfilter $nslist [list string match ${ns_absolute}]] |
|
set nslist_filtered [list $ns_absolute] |
|
} |
|
} |
|
return $nslist_filtered |
|
} |
|
return $nslist |
|
} |
|
|
|
variable usageinfo_char \U1f6c8 |
|
# command has usageinfo e.g from punk::args. todo cmdline, argp, tepam etc? |
|
proc Usageinfo_mark {{ansicodes \UFFEF}} { |
|
variable usageinfo_char |
|
if {$ansicodes eq ""} { |
|
return $usageinfo_char |
|
} elseif {$ansicodes eq "\UFFEF"} { |
|
return " [a+ brightyellow]$usageinfo_char[a]" |
|
} else { |
|
return " [a+ {*}$ansicodes]$usageinfo_char[a]" |
|
} |
|
} |
|
|
|
#REVIEW - ansi codes can be *very* confusing to the user when trying to handle lists etc.. |
|
proc get_nslist {args} { |
|
set known_types [list children commands exported imported aliases procs ensembles ooclasses ooobjects ooprivateobjects ooprivateclasses native coroutines interps zlibstreams] |
|
set defaults [dict create\ |
|
-match ""\ |
|
-types $known_types\ |
|
-nsdict ""\ |
|
] |
|
set opts [dict merge $defaults $args] |
|
# -- --- --- --- --- --- --- --- --- --- |
|
set fq_glob [dict get $opts -match] |
|
set requested_types [dict get $opts -types] |
|
set opt_nsdict [dict get $opts -nsdict] |
|
|
|
set types $requested_types |
|
if {"all" in $requested_types} { |
|
foreach known $known_types { |
|
if {$known ni $types} { |
|
lappend types $known |
|
} |
|
} |
|
} |
|
if {"oo" in $requested_types} { |
|
if {"ooclasses" ni $types} { |
|
lappend types "ooclasses" |
|
} |
|
if {"ooobjects" ni $types} { |
|
lappend types "ooobjects" |
|
} |
|
if {"ooprivateobjects" ni $types} { |
|
lappend types "ooprivateobjects" |
|
} |
|
if {"ooprivateclasses" ni $types} { |
|
lappend types "ooprivateclasses" |
|
} |
|
} |
|
foreach t $types { |
|
switch -- $t { |
|
oo - all - |
|
children - commands - exported - imported - aliases - procs - ensembles - ooclasses - ooobjects - ooprivateobjects - ooprivateclasses - native - coroutines - interps - zlibstreams {} |
|
default { |
|
error "Unrecognised namespace member type: $t known types: $known_types oo all" |
|
} |
|
} |
|
} |
|
|
|
set glob_is_absolute [expr {[string match ::* $fq_glob]}] |
|
if {!$glob_is_absolute} { |
|
error "get_nslist requires fully-qualified namespace glob e.g ::*" |
|
} |
|
#2 columns for namespaces 4 for commands/procs/aliases - todo make less duplicated - generalize to specified number of columns for each? |
|
#NOTE aliases may not be commands in current namespace - but we want to show them (marked red and with R) |
|
# |
|
|
|
set children [list] |
|
set commands [list] |
|
set exported [list] |
|
set imported [list] |
|
set aliases [list] |
|
set procs [list] |
|
set ensembles [list] |
|
set ooclasses [list] |
|
set ooobjects [list] |
|
set ooprivateobjects [list] |
|
set ooprivateclasses [list] |
|
set native [list] |
|
set interps [list] |
|
set coroutines [list] |
|
set zlibstreams [list] |
|
set usageinfo [list] |
|
|
|
if {$opt_nsdict eq ""} { |
|
set nsmatches [get_ns_dicts $fq_glob -allbelow 0] |
|
set itemcount 0 |
|
set matches_with_results [list] |
|
foreach nsinfo $nsmatches { |
|
set itemcount [dict get $nsinfo itemcount] |
|
if {$itemcount > 0} { |
|
lappend matches_with_results $nsinfo |
|
} |
|
} |
|
if {[llength $matches_with_results] == 1} { |
|
set contents [lindex $matches_with_results 0] |
|
} elseif {[llength $matches_with_results] > 1} { |
|
puts stderr "get_nslist WARNING: more than one ([llength $matches_with_results]) namespace had results for the pattern '$fq_glob'. Displaying only first. Consider calling get_ns_dicts and passing results to get_nslist one at a time using -nsdict option" |
|
set contents [lindex $matches_with_results 0] |
|
} else { |
|
return "- no results -" |
|
} |
|
} else { |
|
set contents $opt_nsdict |
|
if {[dict get $opt_nsdict itemcount] == 0} { |
|
return "- no results -" |
|
} |
|
} |
|
set ns [dict get $contents location] |
|
|
|
package require overtype |
|
if {"children" in $types} { |
|
set children [dict get $contents children] |
|
} |
|
if {"commands" in $types} { |
|
set commands [dict get $contents commands] |
|
foreach t $types { |
|
switch -- $t { |
|
exported { |
|
set exported [dict get $contents exported] |
|
} |
|
imported { |
|
set imported [dict get $contents imported] |
|
} |
|
aliases { |
|
set aliases [dict get $contents aliases] |
|
} |
|
procs { |
|
set procs [dict get $contents procs] |
|
} |
|
ensembles { |
|
set ensembles [dict get $contents ensembles] |
|
} |
|
ooclasses { |
|
set ooclasses [dict get $contents ooclasses] |
|
} |
|
ooobjects { |
|
set ooobjects [dict get $contents ooobjects] |
|
} |
|
ooprivateobjects { |
|
set ooprivateobjects [dict get $contents ooprivateobjects] |
|
} |
|
ooprivateclasses { |
|
set ooprivateclasses [dict get $contents ooprivateclasses] |
|
} |
|
native { |
|
set native [dict get $contents native] |
|
} |
|
interps { |
|
set interps [dict get $contents interps] |
|
} |
|
coroutines { |
|
set coroutines [dict get $contents coroutines] |
|
} |
|
zlibstreams { |
|
set zlibstreams [dict get $contents zlibstreams] |
|
} |
|
} |
|
} |
|
set usageinfo [dict get $contents usageinfo] |
|
} |
|
|
|
set numchildren [llength $children] |
|
if {$numchildren} { |
|
set mid [expr {int(ceil($numchildren/2.0))}] |
|
set children1 [lrange $children 0 $mid-1] |
|
set children2 [lrange $children $mid end] |
|
} else { |
|
set children1 [list] |
|
set children2 [list] |
|
} |
|
|
|
#elements are commands and possibly renamed aliases which may or may not have been renamed into the current namespace |
|
#a command could be an empty string or something else weird. |
|
#Primarily just to handle empty string command - we will wrap each command as a 2-part element here |
|
#(our foreach loop needs to ignore missing commands - but not empty string) |
|
set elements [lmap v $commands {list c $v}] |
|
|
|
set seencmds [list] |
|
set masked [list] ;# |
|
#jmn |
|
#set cmdsets [concat $procs $ensembles $ooclasses $ooobjects $ooprivateobjects $ooprivateclasses $native $interps $coroutines $zlibstreams] |
|
set cmdsets [list {*}$procs {*}$ensembles {*}$ooclasses {*}$ooobjects {*}$ooprivateobjects {*}$ooprivateclasses {*}$native {*}$interps {*}$coroutines {*}$zlibstreams] |
|
foreach a $aliases { |
|
if {[list c $a] in $elements} { |
|
#possibly an ordinary alias - or a renamed alias that is masked by a proc/ensemble/oo |
|
#we can detect masking by proc/ensemble/oo - but not by a binary extension loaded after the rename: REVIEW |
|
if {$a in $cmdsets} { |
|
#we have an alias that is also a known other command-type |
|
lappend elements [list c $a] ;#add in twice so we can display both. |
|
lappend masked $a |
|
} |
|
} else { |
|
#a renamed-alias |
|
lappend elements [list c $a] |
|
} |
|
} |
|
set elements [lsort -index 1 $elements] |
|
|
|
|
|
set numelements [llength $elements] |
|
if {$numelements} { |
|
set split1 [expr {int(ceil($numelements/4.0))}] |
|
set elements1 [lrange $elements 0 $split1-1] |
|
set remaining3 [lrange $elements $split1 end] |
|
|
|
set numremaining3 [llength $remaining3] |
|
set split2 [expr {int(ceil($numremaining3/3.0))}] |
|
set elements2 [lrange $remaining3 0 $split2-1] |
|
set remaining2 [lrange $remaining3 $split2 end] |
|
|
|
set numremaining2 [llength $remaining2] |
|
set mid [expr {int(ceil($numremaining2/2.0))}] |
|
set elements3 [lrange $remaining2 0 $mid-1] |
|
set elements4 [lrange $remaining2 $mid end] |
|
|
|
} else { |
|
set elements1 [list] |
|
set elements2 [list] |
|
set elements3 [list] |
|
set elements4 [list] |
|
} |
|
|
|
|
|
|
|
#set chwidest1 [pipedata [list {*}$children1 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] |
|
set lenlist1 [lmap v [list {*}$children1 ""] {string length $v}] |
|
set chwidest1 [tcl::mathfunc::max {*}$lenlist1] |
|
|
|
#set chwidest2 [pipedata [list {*}$children2 ""] {lmap v $data {string length $v}} {tcl::mathfunc::max {*}$data}] |
|
set chwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$children2 ""] {string length $v}]] |
|
|
|
#wrap the cmd in [list] (just for the width calc) to get a proper length for what will actually be displayed |
|
#set cmdwidest1 [pipedata [list {*}$elements1 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] |
|
set cmdwidest1 [tcl::mathfunc::max {*}[lmap v [list {*}$elements1 ""] {string length [list [lindex $v 1]]}]] |
|
|
|
#set cmdwidest2 [pipedata [list {*}$elements2 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] |
|
set cmdwidest2 [tcl::mathfunc::max {*}[lmap v [list {*}$elements2 ""] {string length [list [lindex $v 1]]}]] |
|
#set cmdwidest3 [pipedata [list {*}$elements3 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] |
|
set cmdwidest3 [tcl::mathfunc::max {*}[lmap v [list {*}$elements3 ""] {string length [list [lindex $v 1]]}]] |
|
#set cmdwidest4 [pipedata [list {*}$elements4 ""] {lmap v $data {string length [list [lindex $v 1]]}} {tcl::mathfunc::max {*}$data}] |
|
set cmdwidest4 [tcl::mathfunc::max {*}[lmap v [list {*}$elements4 ""] {string length [list [lindex $v 1]]}]] |
|
|
|
set displaylist [list] |
|
set col1 [string repeat " " [expr {$chwidest1 + 8}]] |
|
set col2 [string repeat " " [expr {$chwidest2 + 8}]] |
|
set col3 [string repeat " " [expr {$cmdwidest1 + 8}]] |
|
set col4 [string repeat " " [expr {$cmdwidest2 + 8}]] |
|
set col5 [string repeat " " [expr {$cmdwidest3 + 8}]] |
|
set a [a+ bold purple] |
|
set e [a+ bold yellow] |
|
set p [a+ bold white] |
|
set c_nat [a+ web-gray] ;#native |
|
set c_int [a+ web-orange] ;#interps |
|
set c_cor [a+ web-hotpink] ;#coroutines |
|
set c_ooo [a+ bold cyan] ;#object |
|
set c_ooc [a+ web-aquamarine] ;#class |
|
set c_ooO [a+ web-dodgerblue] ;#privateObject |
|
set c_ooC [a+ web-lightskyblue] ;#privateClass |
|
set c_zst [a+ web-yellow] ;#zlibstreams |
|
|
|
set a1 [a][a+ cyan] |
|
foreach ch1 $children1 ch2 $children2 cmd1 $elements1 cmd2 $elements2 cmd3 $elements3 cmd4 $elements4 { |
|
set c1 [a+ white] |
|
set c2 [a+ white] |
|
set c3 [a+ white] |
|
set c4 [a+ white] |
|
|
|
for {set i 1} {$i <= 4} {incr i} { |
|
if {[llength [set cmd$i]]} { |
|
set c [a+ white] |
|
set prefix " " |
|
set element [set cmd$i] |
|
set cmd [lindex $element 1] |
|
set cmd_display [list $cmd] ;#wrap in list so empty command is visible (and distinguishable from for example a double-curly command) |
|
if {$cmd ni $commands && $cmd in $aliases } { |
|
#ordinary un-masked commandless-alias |
|
#(original alias name that has been renamed) |
|
set c [a+ red bold strike] |
|
set prefix "${a}als " |
|
set prefix [overtype::right $prefix "-R"] |
|
} else { |
|
if {$cmd in $exported} { |
|
set c [a+ green bold] |
|
} |
|
#keep oooobjects below ooclasses, ooprivateclasses, ooprivateobjects |
|
if {$cmd in $aliases && $cmd in $seencmds} { |
|
#masked commandless-alias |
|
#assertion: member of masked - but we use seencmds instead to detect. |
|
set c [a+ yellow bold] |
|
set prefix "${a}als " |
|
set prefix [overtype::right $prefix "-R"] |
|
} elseif {$cmd in $procs} { |
|
set prefix "${p}prc " |
|
} elseif {$cmd in $native} { |
|
set prefix "${c_nat}nat " |
|
} elseif {$cmd in $ensembles} { |
|
set prefix "${e}ens " |
|
} elseif {$cmd in $ooclasses} { |
|
set prefix "${c_ooc}ooc " |
|
} elseif {$cmd in $ooprivateobjects} { |
|
set prefix "${c_ooO}ooO " |
|
} elseif {$cmd in $ooprivateclasses} { |
|
set prefix "${c_ooC}ooC " |
|
} elseif {$cmd in $ooobjects} { |
|
set prefix "${c_ooo}ooo " |
|
} elseif {$cmd in $aliases} { |
|
set prefix "${a}als " |
|
} elseif {$cmd in $interps} { |
|
set prefix "${c_int}int " |
|
} elseif {$cmd in $coroutines} { |
|
set prefix "${c_cor}cor " |
|
} elseif {$cmd in $zlibstreams} { |
|
set prefix "${c_zst}zst " |
|
} else { |
|
} |
|
if {$cmd in $imported} { |
|
set prefix [overtype::right $prefix "-[a+ yellow bold]I[a+]"] |
|
} |
|
} |
|
if {$cmd in $usageinfo} { |
|
set u [Usageinfo_mark brightgreen] |
|
} else { |
|
set u "" |
|
} |
|
set cmd$i "${prefix} $c$cmd_display$u" |
|
#set c$i $c |
|
set c$i "" |
|
lappend seencmds $cmd |
|
} |
|
} |
|
|
|
#lappend displaylist $a1[overtype::left $col1 $ch1][a+]$a1[overtype::left $col2 $ch2][a+]$c1[overtype::left $col3 $cmd1][a+]$c2[overtype::left $col4 $cmd2][a+]$c3[overtype::left $col5 $cmd3][a+]$c4$cmd4[a+] |
|
lappend displaylist $a1[overtype::left $col1 $ch1][a]$a1[overtype::left $col2 $ch2][a]$c1[overtype::left $col3 $cmd1][a]$c2[overtype::left $col4 $cmd2][a]$c3[overtype::left $col5 $cmd3][a]$c4$cmd4[a] |
|
} |
|
|
|
return [list_as_lines $displaylist] |
|
} |
|
proc nspath_here_absolute {{nspath "\uFFFF"}} { |
|
set path_is_absolute [expr {[string match ::* $nspath]}] |
|
if {$path_is_absolute} { |
|
return $nspath |
|
} |
|
set ns_caller [uplevel 1 {::namespace current}] ;#must qualify 'namespace' command. Needs to be called from arbitrary namespaces where 'namespace' command may exist (e.g tdom::schema) |
|
if {$nspath eq "\uFFFF"} { |
|
return $ns_caller |
|
} |
|
#nsjoin will join nscaller with empty nspath to form nscaller:: - which is correct way to represent command named with empty string |
|
return [nsjoin $ns_caller $nspath] |
|
} |
|
|
|
proc nspath_to_absolute {nspath base} { |
|
set path_is_absolute [expr {[string match ::* $nspath]}] |
|
if {$path_is_absolute} { |
|
return $nspath |
|
} |
|
if {![string length $nspath]} { |
|
return $base |
|
} |
|
return [nsjoin $base $nspath] |
|
} |
|
|
|
set has_textblock [expr {![catch {package require textblock}]}] |
|
|
|
if {$has_textblock} { |
|
interp alias "" ::punk::ns::Block_width "" textblock::width |
|
} else { |
|
#maint - equiv of textblock::width |
|
proc Block_width {textblock} { |
|
if {$textblock eq ""} { return 0 } |
|
if {[tcl::string::last \t $textblock] >=0} { |
|
if {[tcl::info::exists punk::console::tabwidth]} { |
|
set tw $::punk::console::tabwidth |
|
} else { |
|
set tw 8 |
|
} |
|
set textblock [textutil::tabify::untabify2 $textblock $tw] |
|
} |
|
if {[punk::ansi::ta::detect $textblock]} { |
|
set textblock [punk::ansi::ansistripraw $textblock] |
|
} |
|
if {[tcl::string::last \n $textblock] >= 0} { |
|
return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] |
|
} |
|
return [punk::char::ansifreestring_width $textblock] |
|
} |
|
} |
|
proc nslist {{glob "*"} args} { |
|
set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] |
|
if {[dict exists $args -match]} { |
|
#review - presumably this is due to get_nslist taking -match? |
|
error "nslist requires positional argument 'glob' instead of -match option" |
|
} |
|
set defaults [dict create\ |
|
-match $ns_absolute\ |
|
-nspathcommands 0\ |
|
] |
|
|
|
set opts [dict merge $defaults $args] |
|
# -- --- --- |
|
set opt_nspathcommands [dict get $opts -nspathcommands] |
|
# -- --- --- |
|
|
|
|
|
set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] |
|
set with_results [list] |
|
foreach nsdict $ns_matches { |
|
if {[dict get $nsdict itemcount]>0} { |
|
lappend with_results $nsdict |
|
} |
|
} |
|
|
|
#special case when glob is for * - we should also consider existence of item(s) namespacepath as a 'result' |
|
|
|
set count_with_results [llength $with_results] |
|
set output "" |
|
foreach nsdict $with_results { |
|
dict set opts -nsdict $nsdict |
|
set block [get_nslist {*}$opts] |
|
#if {[string first \n $block] < 0} { |
|
# #single line |
|
# set width [Block_width [list $block]] |
|
#} else { |
|
# set width [Block_width $block] |
|
#} |
|
set width [Block_width $block] |
|
|
|
#if multiple results or if there is only 1 result - but we are path-globbing - then we need to show location |
|
if {$count_with_results > 1 || [regexp {[*?]} [nsprefix $ns_absolute]]} { |
|
append output \n [dict get $nsdict location] |
|
} |
|
if {[string length $block]} { |
|
append output \n $block |
|
} |
|
if {[dict size [dict get $nsdict namespacepath]]} { |
|
set path_text "" |
|
if {!$opt_nspathcommands} { |
|
append path_text \n " also resolving cmds in namespace paths: [dict keys [dict get $nsdict namespacepath]]" |
|
} else { |
|
append path_text \n " also resolving cmds in namespace paths:" |
|
set nspathdict [dict get $nsdict namespacepath] |
|
dict for {k v} $nspathdict { |
|
set cmds [dict get $v commands] |
|
append path_text \n " path: $k" |
|
append path_text \n " cmds: $cmds" |
|
} |
|
} |
|
append output $path_text |
|
set path_text_width [Block_width $path_text] |
|
append output \n [string repeat - [expr {max($width,$path_text_width)}]] |
|
} elseif {$count_with_results > 1 && $width > 0 } { |
|
append output \n [string repeat - $width] |
|
} |
|
} |
|
return $output |
|
} |
|
#cli command - impure - relies on caller/ns_current |
|
proc nslist_dict {{glob "*"} args} { |
|
set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] |
|
return [get_ns_dicts $ns_absolute {*}$args] |
|
} |
|
|
|
#info cmdtype available in 8.7+ |
|
#safe interps also seem to have it disabled for some reason |
|
#we need to return "na" if 'info cmdtype' not supported or not functioning due to safe interp etc |
|
#IMPORTANT: don't detect easy types such as proc/import here - caller needs the 'na' to do the proper fallback |
|
#it is not desirable to do a partial cmdtype support here |
|
proc cmdtype {cmd} { |
|
#set cmd [namespace which $cmd] ;#will return empty result for empty string command or command such as :x or any command that doesn't exist |
|
set fqcmd [namespace which $cmd] ;#will resolve for example 'namespace path' reachable commands |
|
if {$fqcmd eq ""} { |
|
#e.g ::ns:::x will return empty result from namespace which even if :x is a command in ::ns |
|
set where [nsprefix $cmd] |
|
if {$where eq ""} { |
|
#bare command that didn't resolve using namespace which |
|
#command probably doesn't exist (may be auto_path cmd not yet loaded) |
|
set where :: |
|
} |
|
set what [nstail $cmd] |
|
} else { |
|
set where [nsprefix $fqcmd] |
|
set what [nstail $fqcmd] |
|
} |
|
#ensure we con't call 'namespace eval' on a nonexistent ns and create cruft namespaces |
|
set parts [nsparts $where] |
|
if {[lsearch $parts :*] > -1} { |
|
set weird_ns 1 |
|
if {![nsexists $where]} { |
|
#error "punk::ns::cmdtype could not locate command $cmd (namespace '$where' not found)." |
|
return nsnotfound |
|
} |
|
} else { |
|
set weird_ns 0 |
|
if {![namespace exists $where]} { |
|
#error "punk::ns::cmdtype could not locate command $cmd (namespace '$where' not found)" |
|
return nsnotfound |
|
} |
|
} |
|
|
|
if {[interp issafe]} { |
|
#todo - weird_ns |
|
if {[catch {namespace eval $where [list ::tcl::info::cmdtype $what]} result]} { |
|
if {[info commands ::cmdtype] ne ""} { |
|
#hack - look for an alias that may have been specifically enabled to bring this back |
|
tailcall ::cmdtype $cmd |
|
} |
|
return na |
|
} else { |
|
return $result |
|
} |
|
} |
|
if {[info commands ::tcl::info::cmdtype] ne ""} { |
|
if {$weird_ns} { |
|
if {[nseval_ifexists $where [list ::info commands $what]] eq ""} { |
|
return notfound |
|
} else { |
|
return [nseval_ifexists $where [list ::tcl::info::cmdtype $what]] |
|
} |
|
} else { |
|
if {[namespace eval $where [list ::info commands $what]] eq ""} { |
|
#e.g parray if it hasn't yet been called (an auto_path loaded command) |
|
return notfound |
|
} else { |
|
tailcall namespace eval $where [list ::tcl::info::cmdtype $what] |
|
} |
|
} |
|
} |
|
#we could examine namespaces to determine more - but would be duplicating work already done/available in get_ns_dicts which is usually the caller |
|
#also - we're unlikely to be able to (easily) duplicate the full info cmdtype behaviour - so don't try here! |
|
return na |
|
} |
|
#non-contextual - but impure due to state-retrieval from the passed-in namespace part of the fq_glob |
|
#returns a list of dicts even if only one ns matched |
|
#glob chars at last segment match contents/children of namespaces |
|
#glob chars in the path will result in multiple namespaces being matched |
|
#e.g ::tcl::*::d* will match commands beginning with d and child namespaces beginning with d in any namespaces 1 below ::tcl |
|
proc get_ns_dicts {fq_glob args} { |
|
#JMN |
|
#puts stderr "get_ns_dicts $fq_glob" |
|
set glob_is_absolute [expr {[string match ::* $fq_glob]}] |
|
if {!$glob_is_absolute} { |
|
error "get_ns_dicts requires fully-qualified namespace glob e.g ::*" |
|
} |
|
set has_globchars [regexp {[*?]} $fq_glob] |
|
|
|
set defaults [dict create\ |
|
-allbelow 0\ |
|
-nspathcommands 1\ |
|
] |
|
set opts [dict merge $defaults $args] |
|
# -- --- --- --- --- --- --- --- --- --- --- --- |
|
set allbelow [dict get $opts -allbelow] |
|
set nspathcommands [dict get $opts -nspathcommands] |
|
# -- --- --- --- --- --- --- --- --- --- --- --- |
|
|
|
#set location [nsprefix $fq_glob] |
|
set commands [list] |
|
|
|
set nsglob [nsprefix $fq_glob] |
|
set glob [nstail $fq_glob] |
|
set matched_namespaces [nstree_list $nsglob -allbelow $allbelow] |
|
|
|
set report_namespaces [list] |
|
#special case trailing ** in last segment |
|
if {[regexp {[*]{2}$} $glob]} { |
|
lappend report_namespaces {*}$matched_namespaces |
|
foreach ns $matched_namespaces { |
|
lappend report_namespaces {*}[nstree_list [nsjoin $ns $glob]] |
|
} |
|
} else { |
|
set report_namespaces $matched_namespaces |
|
} |
|
punk::args::update_definitions |
|
|
|
set nsdict_list [list] |
|
foreach ch $report_namespaces { |
|
#puts "get_ns_dicts>>> $ch glob:'$glob'" |
|
if {$allbelow == 0 && !$has_globchars} { |
|
set allchildren [list] |
|
} else { |
|
set allchildren [nschildren $ch] ; #sorted, only returns 1 level deeper |
|
} |
|
|
|
#nscommands returns exactly one line per entry + a trailing newline. If there is an empty line other than at the end - that is because there is a command named as the empty string. |
|
# By default 'linelist' trims 1st and last empty line. Turn off all block trimming with -block {} |
|
#set commands [.= nscommands -raw [nsjoin $ch $glob] |> punk::lib::linelist -block {}] |
|
set commands [punk::lib::linelist -block {} [nscommands -raw [nsjoin $ch $glob]]] |
|
|
|
#by convention - returning just \n represents a single result of the empty string whereas no results |
|
#after passing through linelist this becomes {} {} which appears as a list of two empty strings. |
|
#this is because there isn't a way to represent unambiguously all 3 cases of: empty-list, list of single empty string, list of two empty strings just using \n separated lines |
|
#unless we always return a newline at the tail if there is a result |
|
#For this reason nscommands returns a trailing newline - so the last entry should always be empty string - and is a bogus entry |
|
#We double-check it here to avoid regressions/mistakes - as nscommands is also a user-level command so there exists the temptation to make it not return the extra newline. |
|
if {[lindex $commands end] eq ""} { |
|
set commands [lrange $commands 0 end-1] |
|
} else { |
|
puts stderr "get_ns_dicts WARNING nscommands didn't return a trailing newline - unexpected" |
|
} |
|
|
|
|
|
#JMN |
|
set location $ch |
|
set locationparts [nsparts $location] |
|
set weird_ns 0 |
|
if {[lsearch $locationparts :*] >= 0} { |
|
set weird_ns 1 |
|
} |
|
if {$weird_ns} { |
|
set exportpatterns [nseval_ifexists $location {::namespace export}] |
|
set nspathlist [nseval_ifexists $location {::namespace path}] |
|
} else { |
|
set exportpatterns [tcl::namespace::eval $location {::namespace export}] |
|
set nspathlist [tcl::namespace::eval $location {::namespace path}] |
|
} |
|
set nspathdict [dict create] |
|
if {$nspathcommands} { |
|
foreach pathns $nspathlist { |
|
set pathcommands [lmap v [info commands ${pathns}::*] {namespace tail $v}] |
|
set matched [lsearch -all -inline $pathcommands $glob] |
|
dict set nspathdict $pathns [dict create commands $matched] |
|
} |
|
} else { |
|
foreach pathns $nspathlist { |
|
dict set nspathdict $pathns [dict create] ;#use consistent structure when nspathcommands false |
|
} |
|
} |
|
#set exportpatterns [nseval $location {::namespace export}] |
|
set allexported [list] |
|
set matched [list] |
|
foreach p $exportpatterns { |
|
if {[regexp {[*?]} $p]} { |
|
#lappend matched {*}[nseval $location [list ::info commands [nsjoin ${location} $p]]] |
|
if {$weird_ns} { |
|
#! info commands can't glob with a weird ns prefix |
|
#! info commands with no arguments returns all commands (from global and any other ns in namespace path) |
|
#lappend matched {*}[nseval_ifexists $location [list ::info commands [nsjoin ${location} $p]]] |
|
lappend matched {*}[nseval_ifexists $location [string map [list <loc> $location <pat> $p] { |
|
set allcommands [info commands] |
|
set matches [list] |
|
foreach c $allcommands { |
|
set fq [namespace which $c] |
|
if {[string match <loc>::<pat> $fq]} { |
|
lappend matches $c |
|
} |
|
} |
|
return $matches |
|
}] |
|
|
|
} else { |
|
lappend matched {*}[tcl::namespace::eval $location [list ::info commands [nsjoin ${location} $p]]] |
|
} |
|
foreach m $matched { |
|
lappend allexported [nstail $m] |
|
} |
|
} else { |
|
lappend allexported $p |
|
} |
|
} |
|
set allexported [lsort -unique $allexported] |
|
#NOTE: info procs within tcl::namespace::eval is different to 'info commands' within tcl::namespace::eval (info procs doesn't look outside of namespace) |
|
if {$weird_ns} { |
|
set allprocs [nseval_ifexists $location {::info procs}] |
|
} else { |
|
set allprocs [tcl::namespace::eval $location {::info procs}] |
|
} |
|
#set allprocs [nseval $location {::info procs}] |
|
set childtails [lmap v $allchildren {nstail $v}] |
|
set allaliases [list] |
|
set allnative [list] |
|
set allensembles [list] |
|
set allinterps [list] |
|
set allcoroutines [list] |
|
set allzlibstreams [list] |
|
set allooobjects [list] |
|
set allooclasses [list] |
|
set allooprivateobjects [list] |
|
set allooprivateclasses [list] |
|
set allimported [list] |
|
set allundetermined [list] |
|
set interp_aliases [interp aliases ""] |
|
#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 |
|
if {$weird_ns} { |
|
set raw_aliases [nseval_ifexists $location [list ::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. |
|
} else { |
|
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 aliases [list] |
|
foreach a $raw_aliases { |
|
if {[string match *:: $a]} { |
|
#exception for alias such as ::p::2:: so that it doesn't show up as empty string |
|
#lappend aliases :: |
|
#JMN - 2023 - better to display an empty string somehow |
|
lappend aliases "" |
|
} else { |
|
lappend aliases [nstail $a] |
|
} |
|
} |
|
|
|
#NOTE for 'info <subcommand>...' 'namespace origin|(etc)..' |
|
# - use the pattern [namespace eval $location [list <cmd> $cmd]] |
|
#This allows examination of cmds with "bad" names such as empty string or prefixed with single colon. |
|
#while these should be rare - we want to handle such edge cases when browsing namespaces. |
|
foreach cmd $commands { |
|
#if {"${location}::$cmd" in $interp_aliases || [string trimleft "${location}::$cmd" ":"] in $interp_aliases} { |
|
# #NOTE: doesn't cater for renamed aliases - Tcl 8.x (and 9.01) doesn't seem to have any introspection capabilities to match command to a renamed alias |
|
# #which_alias hack from wiki relies on trace and executing the command - which we don't want to do. |
|
# lappend allaliases $cmd |
|
#} |
|
set ctype [cmdtype ${location}::$cmd] |
|
switch -- $ctype { |
|
na { |
|
if {$weird_ns} { |
|
set cmdorigin [nseval_ifexists $location [list ::namespace origin $cmd]] |
|
} else { |
|
set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] |
|
} |
|
if {[nsprefix $cmdorigin] ne $location} { |
|
#import |
|
lappend allimported $cmd |
|
set origin_location [nsprefix $cmdorigin] |
|
} else { |
|
set origin_location $location |
|
} |
|
#tcl 8.6 (info cmdtype unavailable) |
|
#todo - use catch tcl::unsupported::corotype to see if coroutine |
|
set originlocationparts [nsparts $origin_location] |
|
set weird_origin 0 |
|
if {[lsearch $originlocationparts :*] >= 0} { |
|
set weird_origin 1 |
|
} |
|
if {$weird_origin} { |
|
if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { |
|
lappend allensembles $cmd |
|
} elseif {[nseval_ifexists $origin_location [list ::info object isa object $cmd]]} { |
|
lappend allooobjects $cmd |
|
if {[nseval_ifexists $origin_location [list ::info object isa class $cmd]]} { |
|
lappend allooclasses $cmd |
|
} |
|
} else { |
|
|
|
} |
|
} else { |
|
if {![catch {namespace eval $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} { |
|
lappend allensembles $cmd |
|
} elseif {[namespace eval $origin_location [list ::info object isa object $cmd]]} { |
|
lappend allooobjects $cmd |
|
if {[namespace eval $origin_location [list ::info object isa class $cmd]]} { |
|
lappend allooclasses $cmd |
|
} |
|
} else { |
|
|
|
} |
|
} |
|
} |
|
default { |
|
if {$ctype eq "import"} { |
|
if {$weird_ns} { |
|
set cmdorigin [nseval_ifexists $location [list ::namespace origin $cmd]] |
|
} else { |
|
set cmdorigin [namespace eval $location [list ::namespace origin $cmd]] |
|
} |
|
#even if cmd was already imported to another ns and then reimported from there, namespace origin will show the original source |
|
#ie we don't need to follow a chain of 'imported' results. |
|
set origin_location [nsprefix $cmdorigin] |
|
set origin_cmd [nstail $cmdorigin] |
|
|
|
set originlocationparts [nsparts $origin_location] |
|
set weird_origin 0 |
|
if {[lsearch $originlocationparts :*] >= 0} { |
|
set weird_origin 1 |
|
} |
|
if {$weird_origin} { |
|
set mixedtype i-[nseval_ifexists $origin_location [list ::tcl::info::cmdtype $origin_cmd]] |
|
} else { |
|
set mixedtype i-[namespace eval $origin_location [list ::tcl::info::cmdtype $origin_cmd]] |
|
} |
|
lappend allimported $cmd |
|
} else { |
|
set mixedtype $ctype |
|
} |
|
#assert mixedtype != import |
|
#review - we don't have a way to mark as both native and ensemble |
|
switch -- $mixedtype { |
|
i-native - native { |
|
lappend allnative $cmd |
|
} |
|
i-ensemble - ensemble { |
|
lappend allensembles $cmd |
|
} |
|
i-alias - alias { |
|
#review |
|
lappend allaliases $cmd |
|
} |
|
i-object - object { |
|
if {[info object isa object ${location}::$cmd]} { |
|
lappend allooobjects $cmd |
|
if {[info object isa class ${location}::$cmd]} { |
|
lappend allooclasses $cmd |
|
} |
|
} |
|
} |
|
i-privateObject - privateObject { |
|
lappend allooobjects $cmd |
|
lappend allooprivateobjects $cmd |
|
} |
|
i-privateClass - privateClass { |
|
lappend allooobjects $cmd |
|
lappend allooprivateclasses $cmd |
|
} |
|
i-interp - interp { |
|
lappend allinterps $cmd |
|
} |
|
i-coroutine - coroutine { |
|
lappend allcoroutines $cmd |
|
} |
|
i-zlibStream - zlibStream { |
|
lappend allzlibstreams $cmd |
|
} |
|
default { |
|
#there may be other registered types |
|
#(extensible with Tcl_RegisterCommandTypeName) |
|
lappend allothers $cmd |
|
} |
|
|
|
} |
|
|
|
} |
|
} |
|
#JMN TODO |
|
if {[catch { |
|
if {$cmd eq ""} { |
|
#empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. |
|
set nsorigin [namespace origin ${location}::] |
|
} elseif {[string match :* $cmd]} { |
|
set nsorigin [nseval $location "::namespace origin $cmd"] |
|
} else { |
|
set nsorigin [namespace origin [nsjoin $location $cmd]] |
|
} |
|
} errM]} { |
|
puts stderr "get_ns_dicts failed to determine origin of command '$cmd' adding to 'undetermined'" |
|
puts stderr "error message: $errM" |
|
lappend allundetermined $cmd |
|
} else { |
|
if {[nsprefix $nsorigin] ne $location} { |
|
lappend allimported $cmd |
|
} |
|
} |
|
} |
|
if {$glob ne "*"} { |
|
set childtailmatches [lsearch -all -inline $childtails $glob] |
|
#set fqchildren [lmap v $childtailmatches {lindex ${location}::$v}] ;#lindex without indices is fast equivalent of 'val' or string cat |
|
|
|
set exported [lsearch -all -inline $allexported $glob] |
|
set procs [lsearch -all -inline $allprocs $glob] |
|
#set aliases [lsearch -all -inline $allaliases $glob] |
|
set ensembles [lsearch -all -inline $allensembles $glob] |
|
set native [lsearch -all -inline $allnative $glob] |
|
set coroutines [lsearch -all -inline $allcoroutines $glob] |
|
set interps [lsearch -all -inline $allinterps $glob] |
|
set zlibstreams [lsearch -all -inline $allzlibstreams $glob] |
|
set ooprivateobjects [lsearch -all -inline $allooprivateobjects $glob] |
|
set ooprivateclasses [lsearch -all -inline $allooprivateclasses $glob] |
|
set ooobjects [lsearch -all -inline $allooobjects $glob] |
|
set ooclasses [lsearch -all -inline $allooclasses $glob] |
|
set imported [lsearch -all -inline $allimported $glob] |
|
set undetermined [lsearch -all -inline $allundetermined $glob] |
|
} else { |
|
set childtailmatches $childtails |
|
#set fqchildren $allchildren |
|
set exported $allexported |
|
set procs $allprocs |
|
#set aliases $allaliases |
|
set ensembles $allensembles |
|
set native $allnative |
|
set coroutines $allcoroutines |
|
set interps $allinterps |
|
set zlibstreams $allzlibstreams |
|
set ooobjects $allooobjects |
|
set ooclasses $allooclasses |
|
set ooprivateobjects $allooprivateobjects |
|
set ooprivateclasses $allooprivateclasses |
|
set imported $allimported |
|
set undetermined $allundetermined |
|
} |
|
|
|
#itemcount will overcount if we are including commands as well as procs/exported etc - |
|
set itemcount 0 |
|
incr itemcount [llength $childtailmatches] |
|
incr itemcount [llength $commands] |
|
|
|
|
|
#incr itemcount [llength $procs] |
|
#incr itemcount [llength $exported] |
|
#incr itemcount [llength $imported] |
|
#incr itemcount [llength $aliases] |
|
#incr itemcount [llength $ensembles] |
|
#incr itemcount [llength $ooobjects] |
|
#incr itemcount [llength $ooclasses] |
|
#definitely don't count exportpatterns |
|
incr itemcount [llength $undetermined] |
|
|
|
set usageinfo [list] |
|
set has_punkargs [expr {[info commands ::punk::args::id_exists] ne ""}] |
|
set has_tepam [expr {[info exists ::tepam::ProcedureList]}] |
|
if {$has_punkargs || $has_tepam} { |
|
foreach c $commands { |
|
if {$c in $imported} { |
|
set fq [namespace origin [nsjoin $location $c]] |
|
} elseif {$c in $aliases} { |
|
#TODO - use which_alias ? |
|
set tgt [interp alias "" [nsjoin $location $c]] |
|
if {$tgt eq ""} { |
|
set tgt [interp alias "" [string trimleft [nsjoin $location $c] :]] |
|
} |
|
set word1 [lindex $tgt 0] |
|
if {$word1 eq "punk::mix::base::_cli"} { |
|
#special case for punk deck - REVIEW |
|
#e.g punk::mix::base::_cli -extension ::punk::mix::cli |
|
set fq [lindex $tgt end] |
|
} else { |
|
#todo - alias may have prefilled some leading args - so usage report should reflect that??? |
|
#(currying) |
|
set fq $word1 |
|
} |
|
} else { |
|
set fq [nsjoin $location $c] |
|
} |
|
if {$has_punkargs} { |
|
set id [string trimleft $fq :] |
|
if {[::punk::args::id_exists $id]} { |
|
lappend usageinfo $c |
|
} else { |
|
if {$has_tepam} { |
|
if {$fq in $::tepam::ProcedureList} { |
|
lappend usageinfo $c |
|
} |
|
} |
|
} |
|
} else { |
|
if {$fq in $::tepam::ProcedureList} { |
|
lappend usageinfo $c |
|
} |
|
} |
|
} |
|
} |
|
|
|
set nsdict [dict create\ |
|
location $location\ |
|
children [lsort $childtailmatches]\ |
|
commands $commands\ |
|
procs $procs\ |
|
exported $exported\ |
|
imported $imported\ |
|
aliases $aliases\ |
|
ensembles $ensembles\ |
|
native $native\ |
|
coroutines $coroutines\ |
|
interps $interps\ |
|
zlibstreams $zlibstreams\ |
|
ooobjects $ooobjects\ |
|
ooclasses $ooclasses\ |
|
ooprivateobjects $ooprivateobjects\ |
|
ooprivateclasses $ooprivateclasses\ |
|
namespacexport $exportpatterns\ |
|
undetermined $undetermined\ |
|
usageinfo $usageinfo\ |
|
namespacepath $nspathdict\ |
|
glob $glob\ |
|
itemcount $itemcount\ |
|
] |
|
lappend nsdict_list $nsdict |
|
} |
|
return $nsdict_list |
|
} |
|
#Must be no ansi when only single arg used. |
|
#review - ansi codes will be very confusing in some scenarios! |
|
#todo - only output color when requested (how?) or via repltelemetry ? |
|
interp alias {} nscommands2 {} .= ,'ok'@0.= { |
|
#Note: namespace argument to apply doesn't accept namespace segments with leading colon - so pipelines won't work fully in dodgily-named namespaces such as :::x |
|
#inspect -label namespace_current [namespace current] |
|
#inspect -label info_procs [info procs] |
|
|
|
::set commandns [::namespace current] |
|
::set commandlist [::list] |
|
#color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway |
|
#colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed |
|
::set colors [::list none cyan yellow green] |
|
::set ci 0 ;#colourindex |
|
::set do_raw 0 |
|
::if {[::set posn [::lsearch $searchlist -raw]] >= 0} { |
|
::set searchlist [::lreplace $searchlist $posn $posn] |
|
::set do_raw 1 |
|
} |
|
::if {![::llength $searchlist]} { |
|
::lappend searchlist * |
|
} |
|
::foreach search $searchlist { |
|
::if {$ci > [::llength $colors]-1} { |
|
::set ci 0 |
|
} |
|
#by using pipeswitch instead of pipeswitchc - we give the ability* for the switch script block to affect vars in the calling scope |
|
# (*not a desirable feature from a functional point of view - but useful for debugging, and also potentially faster ) |
|
::if {$ci == 0 || $do_raw} { |
|
::set col "" |
|
::set rst "" |
|
} else { |
|
::set col [a+ [::lindex $colors $ci] bold] |
|
::set rst [a+] |
|
} |
|
::incr ci ;#colourindex |
|
#inspect -label search $search |
|
|
|
::if {![::llength $search]} { |
|
::set base $commandns |
|
::set what "*" |
|
} else { |
|
::if {[::string match ::* $search]} { |
|
::set base [::punk::ns::nsprefix $search] |
|
::set what [::punk::ns::nstail $search] |
|
} else { |
|
::set base $commandns |
|
::set what $search |
|
} |
|
} |
|
|
|
::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] |
|
#important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created |
|
::if {![::tcl::namespace::exists $base]} { |
|
::continue |
|
} |
|
|
|
if 0 { |
|
#NOTE - matched commands will return commands from global ns due to 'namespace eval' - also any commands from namespaces in the 'namespace path' list |
|
#We don't simply do info commands ${base}::$what because it misses some oddly named things (JMN 2023 - like what?) |
|
#this was to support weird namespaces with leading/trailing colons - not an important usecase for the cost |
|
::set matchedcommands [::pipeswitch { |
|
::pipecase \ |
|
caseresult.= ::list $base $what |,basens/0,g/1> {tcl::namespace::eval $basens [::list ::info commands $g]} |
|
}] |
|
#lappend commandlist {*}[@@ok/result= $matchedcommands] |
|
#need to pull result from matchedcommands dict |
|
#set cmd_tails [@@ok/result= $matchedcommands |> {::lmap v $data {punk::ns::nstail $v}}] |
|
::set cmd_tails [::lmap v [::dict get $matchedcommands ok result] {::punk::ns::nstail $v}] |
|
::set all_ns_tails [::lmap v $all_ns_commands {::punk::ns::nstail $v}] |
|
::foreach c $cmd_tails { |
|
::if {$c in $all_ns_tails} { |
|
::if {$do_raw} { |
|
::lappend commandlist [::list $c $c] |
|
} else { |
|
::lappend commandlist [::list $c $col[::list $c]$rst] |
|
} |
|
} |
|
} |
|
} else { |
|
|
|
::set all_ns_tails [::lmap v $all_ns_commands {::punk::ns::nstail $v}] |
|
foreach c $all_ns_tails { |
|
::if {$do_raw} { |
|
::lappend commandlist [::list $c $c] |
|
} else { |
|
::lappend commandlist [::list $c $col[::list $c]$rst] |
|
} |
|
} |
|
} |
|
} |
|
::list ok [::list result $commandlist] |
|
#unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) |
|
#we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. |
|
} |data@@ok/result> ::lsort -index 0 |> {::lmap v $data {::lindex $v 1}} |> {::if {![::llength $data]} {::return {}} else {::return [::join $data \n]\n}} <searchlist| |
|
|
|
proc nscommands {args} { |
|
set commandns [uplevel 1 [list ::namespace current]] |
|
set commandlist [::list] |
|
#color code multiple args? - not very practical if many ns args supplied, but then... common case will only be 1 or 2 anyway |
|
#colors can be stripped by caller with ansistrip - but we'll make the default case easier by using no ansi codes if a single arg is passed |
|
set colors [::list none cyan yellow green] |
|
set ci 0 ;#colourindex |
|
set do_raw 0 |
|
if {[::set posn [::lsearch $args -raw]] >= 0} { |
|
::set args [::lreplace $args $posn $posn] |
|
::set do_raw 1 |
|
} |
|
if {![llength $args]} { |
|
lappend args * |
|
} |
|
::foreach search $args { |
|
::if {$ci > [::llength $colors]-1} { |
|
::set ci 0 |
|
} |
|
::if {$ci == 0 || $do_raw} { |
|
::set col "" |
|
::set rst "" |
|
} else { |
|
::set col [a+ [::lindex $colors $ci] bold] |
|
::set rst [a+] |
|
} |
|
::incr ci ;#colourindex |
|
#inspect -label search $search |
|
|
|
::if {![::llength $search]} { |
|
::set base $commandns |
|
::set what "*" |
|
} else { |
|
::if {[::string match ::* $search]} { |
|
::set base [::punk::ns::nsprefix $search] |
|
::set what [::punk::ns::nstail $search] |
|
} else { |
|
::set base $commandns |
|
::set what $search |
|
} |
|
} |
|
set weird_ns 0 |
|
if {[string match *:::* $base]} { |
|
set weird_ns 1 |
|
} |
|
#important not to call tcl::namespace::eval (or punk::ns::nseval) on non-existant base - or it will be created |
|
if {$weird_ns} { |
|
::if {![nsexists $base]} { |
|
::continue |
|
} |
|
#info commands can't glob with weird_ns prefix |
|
puts ">>> base: $base what: $what" |
|
::set all_ns_commands [nseval_ifexists $base [list apply {{loc what} { |
|
set _all [uplevel 1 [list ::info commands]] |
|
set _matches [list] |
|
foreach _a $_all { |
|
set _c [uplevel 1 [list ::namespace which $_a]] |
|
if {[::string match ${loc}::${what} $_c]} { |
|
::lappend _matches $_a |
|
} |
|
} |
|
return $_matches |
|
}} $base $what ]] |
|
} else { |
|
::if {![::tcl::namespace::exists $base]} { |
|
::continue |
|
} |
|
::set all_ns_commands [::info commands [::punk::ns::nsjoin $base $what]] |
|
} |
|
::set all_ns_tails [::lmap v $all_ns_commands {::punk::ns::nstail $v}] |
|
foreach c $all_ns_tails { |
|
::if {$do_raw} { |
|
::lappend commandlist [::list $c $c] |
|
} else { |
|
::lappend commandlist [::list $c $col[::list $c]$rst] |
|
} |
|
} |
|
} |
|
set commandlist [lsort -index 0 $commandlist] |
|
set results [list] |
|
foreach pair $commandlist { |
|
lappend results [lindex $pair 1] |
|
} |
|
#unless we always return trailing \n - it's impossible to represent a list containing only the empty string using \n (cannot disambiguate between empty list and/or list of 2 empty strings) |
|
#we use the convention that a result of just \n represents a list of just the empty string - as we don't require duplicates anyway - so it shouldn't mean two empty strings. |
|
if {![llength $results]} { |
|
return {} |
|
} else { |
|
return [join $results \n]\n |
|
} |
|
} |
|
interp alias {} nscommands {} punk::ns::nscommands |
|
|
|
|
|
|
|
interp alias {} nscommands1 {} .= ,'ok'@0.= { |
|
set commandns [namespace current] |
|
#upvar caseresult caseresult |
|
inspect -label namespace_current [namespace current] |
|
inspect -label nsthis [nsthis] |
|
inspect -label nsthis2 [nsthis2] |
|
inspect -label commandns $commandns |
|
inspect -label info_procs [info procs] |
|
#by using pipeswitch instead of pipeswitchc - we give the ability* for the switch script block to affect vars in the calling scope |
|
# (*not a desirable feature from a functional point of view - but useful for debugging, and also potentially faster ) |
|
pipeswitch { |
|
#no glob chars present |
|
if {![llength $ns]} { |
|
set ns $commandns |
|
} else { |
|
if {![string match ::* $ns]} { |
|
if {$commandns eq "::"} {set commandns ""} |
|
set ns ${commandns}::$ns |
|
} |
|
} |
|
inspect '$ns' |
|
pipecase \ |
|
caseresult= $ns |input> \ |
|
1.= {expr {[string length [string map [list * "" ? ""] $data]] == [string length $data]}} |> { |
|
#uplevel 1 [list info commands ${input}::*] |
|
info commands ${input}::* |
|
} |
|
|
|
#pipecase1 ns has one or more of glob chars * or ? |
|
pipecase \ |
|
caseresult= $ns |input> { |
|
#uplevel 1 [list info commands ${input}] |
|
info commands ${input} |
|
} |
|
} |
|
} |data@@ok/result> {lmap v $data {punk::ns::nstail $v}} |> lsort |> {join $data \n} <ns/0| |
|
|
|
punk::args::definition { |
|
*id punk::ns::arginfo |
|
*proc -name punk::ns::arginfo -help\ |
|
"Show usage info for a command" |
|
-return -type string -default table -choices {string table tableobject} |
|
-- -type none -help\ |
|
"End of options marker |
|
Use this if the command to view begins with a -" |
|
*values -min 1 |
|
commandpath -help\ |
|
"command (may be alias or ensemble)" |
|
subcommand -optional 1 -multiple 1 -default {} -help\ |
|
"subcommand if commandpath is an ensemble. |
|
Multiple subcommands can be supplied if ensembles are further nested" |
|
} |
|
proc arginfo {args} { |
|
lassign [dict values [punk::args::get_by_id punk::ns::arginfo $args]] leaders opts values received |
|
set commandpath [dict get $values commandpath] |
|
set commandargs [dict get $values subcommand] |
|
punk::args::update_definitions ;#ensure any packages that register PUNKARGS have been loaded |
|
|
|
#todo - similar to corp? review corp resolution process |
|
|
|
#should handle lazy loaded commands (via ::auto_index) that are not yet present but may be documented |
|
if {[string match ::* $commandpath]} { |
|
set targetns [nsprefix $commandpath] |
|
set name [nstail $commandpath] |
|
#don't use 'info commands $commandpath' - or Tcl will use 'namespace path' resolution to find command in another ns or in global |
|
#when arginfo given a fully qualified path - we only want an answer for that exact command |
|
set nscommands [info commands ${targetns}::*] |
|
if {[lsearch -exact $nscommands $commandpath] >= 0} { |
|
#use nseval_ifexists to avoid creating intermediate namespaces for bogus paths |
|
if {[catch { |
|
set origin [nseval_ifexists $targetns [list ::namespace origin $name]] |
|
set resolved [nseval_ifexists $targetns [list ::namespace which $name]] |
|
}]} { |
|
set origin $commandpath |
|
set resolved $commandpath |
|
} |
|
} else { |
|
#fully qualified command specified but doesn't exist |
|
set origin $commandpath |
|
set resolved $commandpath |
|
} |
|
} else { |
|
set thispath [uplevel 1 [list ::nsthis $commandpath]] |
|
set targetns [nsprefix $thispath] |
|
set name [nstail $thispath] |
|
set targetparts [nsparts $targetns] |
|
if {[lsearch $targetparts :*] >=0} { |
|
#weird ns |
|
set valid_ns [nsexists $targetns] |
|
} else { |
|
set valid_ns [namespace exists $targetns] |
|
} |
|
if {$valid_ns} { |
|
if {[catch { |
|
set origin [nseval_ifexists $targetns [list ::namespace origin $name]] |
|
set resolved [nseval_ifexists $targetns [list ::namespace which $name]] |
|
}]} { |
|
set thiscmd [nsjoin $targetns $name] |
|
#relative commandpath specified - but Tcl didn't find a match in namespace path |
|
#assume global (todo - look for namespace match in auto_index first ?) |
|
set origin ::$name |
|
set resolved ::$name |
|
} |
|
} else { |
|
#namespace doesn't seem to exist - but there still could be documentation for lazy loaded ns and command |
|
set origin $commandpath |
|
set resolved $commandpath |
|
} |
|
} |
|
#set thiscmd [nsjoin $targetns $name] |
|
#if {[info commands $thiscmd] eq ""} { |
|
# set origin $thiscmd |
|
# set resolved $thiscmd |
|
#} else { |
|
# set origin [nseval $targetns [list ::namespace origin $name]] |
|
# set resolved [nseval $targetns [list ::namespace which $name]] |
|
#} |
|
|
|
#ns::cmdtype only detects alias type on 8.7+? |
|
set initial_cmdtype [punk::ns::cmdtype $origin] |
|
switch -- $initial_cmdtype { |
|
na - alias { |
|
#REVIEW - alias entry doesn't necessarily match command! |
|
#considure using which_alias (wiki) |
|
set tgt [interp alias "" $origin] |
|
if {$tgt eq ""} { |
|
set tgt [interp alias "" [string trimleft $origin :]] |
|
} |
|
if {$tgt ne ""} { |
|
set word1 [lindex $tgt 0] |
|
if {$word1 eq "punk::mix::base::_cli"} { |
|
#special case for punk deck - REVIEW |
|
#e.g punk::mix::base::_cli -extension ::punk::mix::cli |
|
set fq [lindex $tgt end] |
|
} else { |
|
#todo - alias may have prefilled some leading args - so usage report should reflect that??? |
|
#(possible curried arguments) |
|
#review - curried arguments could be for ensembles! |
|
set fq $word1 |
|
} |
|
set origin $fq |
|
#retest cmdtype on modified origin |
|
set cmdtype [punk::ns::cmdtype $origin] |
|
} else { |
|
set cmdtype $initial_cmdtype |
|
} |
|
if {$cmdtype eq "na"} { |
|
#tcl 8.6 |
|
if {[info object isa object $origin]} { |
|
set cmdtype "object" |
|
} |
|
} |
|
} |
|
default { |
|
set cmdtype $initial_cmdtype |
|
} |
|
} |
|
|
|
switch -- $cmdtype { |
|
object { |
|
#class is also an object |
|
#todo -mixins etc etc |
|
set class [info object class $origin] |
|
#the call: info object methods <o> -all |
|
# seems to do the right thing as far as hiding unexported methods, and showing things like destroy |
|
# - which don't seem to be otherwise easily introspectable |
|
set public_methods [info object methods $origin -all] |
|
#set class_methods [info class methods $class] |
|
#set object_methods [info object methods $origin] |
|
|
|
if {[llength $commandargs]} { |
|
set c1 [lindex $commandargs 0] |
|
if {$c1 in $public_methods} { |
|
switch -- $c1 { |
|
new { |
|
set constructorinfo [info class constructor $origin] |
|
set arglist [lindex $constructorinfo 0] |
|
set argspec [punk::lib::tstr -return string { |
|
*id "${$origin} new" |
|
*proc -name "${$origin} new" -help\ |
|
"create object with specified command name. |
|
Arguments are passed to the constructor." |
|
*values |
|
}] |
|
set i 0 |
|
foreach a $arglist { |
|
if {[llength $a] == 1} { |
|
if {$i == [llength $arglist]-1 && $a eq "args"} { |
|
#'args' is only special if last |
|
append argspec \n "args -optional 1 -multiple 1" |
|
} else { |
|
append argspec \n "$a" |
|
} |
|
} else { |
|
append argspec \n "[lindex $a 0] -default [lindex $a 1]" |
|
} |
|
incr i |
|
} |
|
punk::args::definition $argspec |
|
return [punk::args::usage {*}$opts "$origin new"] |
|
} |
|
create { |
|
set constructorinfo [info class constructor $origin] |
|
set arglist [lindex $constructorinfo 0] |
|
set argspec [punk::lib::tstr -return string { |
|
*id "${$origin} create" |
|
*proc -name "${$origin} create" -help\ |
|
"create object with specified command name. |
|
Arguments following objectName are passed to the constructor." |
|
*values -min 1 |
|
objectName -type string -help\ |
|
"possibly namespaced name for object instance command" |
|
}] |
|
set i 0 |
|
foreach a $arglist { |
|
if {[llength $a] == 1} { |
|
if {$i == [llength $arglist]-1 && $a eq "args"} { |
|
#'args' is only special if last |
|
append argspec \n "args -optional 1 -multiple 1" |
|
} else { |
|
append argspec \n "$a" |
|
} |
|
} else { |
|
append argspec \n "[lindex $a 0] -default [lindex $a 1]" |
|
} |
|
incr i |
|
} |
|
punk::args::definition $argspec |
|
return [punk::args::usage {*}$opts "$origin create"] |
|
} |
|
destroy { |
|
#review - generally no doc |
|
# but we may want notes about a specific destructor |
|
set argspec [punk::lib::tstr -return string { |
|
*id "${$origin} destroy" |
|
*proc -name "destroy" -help\ |
|
"delete object, calling destructor if any. |
|
destroy accepts no arguments." |
|
*values -min 0 -max 0 |
|
}] |
|
punk::args::definition $argspec |
|
return [punk::args::usage {*}$opts "$origin destroy"] |
|
} |
|
default { |
|
#use info object call <obj> <method> to resolve callchain |
|
#we assume the first impl is the topmost in the callchain |
|
# and its call signature is therefore the one we are interested in - REVIEW |
|
# we should probably ignore generaltypes filter|unknown and look for a subsequent method|private? |
|
set implementations [::info object call $origin $c1] |
|
#result documented as list of 4 element lists |
|
#set callinfo [lindex $implementations 0] |
|
set def "" |
|
foreach impl $implementations { |
|
lassign $impl generaltype mname location methodtype |
|
switch -- $generaltype { |
|
method - private { |
|
|
|
if {$location eq "object"} { |
|
set id "[string trimleft $origin :] $c1" ;# "<object> <method>" |
|
if {[info commands ::punk::args::id_exists] ne ""} { |
|
if {[punk::args::id_exists $id]} { |
|
return [uplevel 1 [list punk::args::usage {*}$opts $id]] |
|
} |
|
} |
|
set def [::info object definition $origin $c1] |
|
} else { |
|
set id "[string trimleft $location :] $c1" ;# "<class> <method>" |
|
if {[info commands ::punk::args::id_exists] ne ""} { |
|
if {[punk::args::id_exists $id]} { |
|
return [uplevel 1 [list punk::args::usage {*}$opts $id]] |
|
} |
|
} |
|
set def [::info class definition $location $c1] |
|
} |
|
break |
|
} |
|
filter { |
|
} |
|
unknown { |
|
} |
|
} |
|
} |
|
if {$def ne ""} { |
|
set arglist [lindex $def 0] |
|
set argspec [punk::lib::tstr -return string { |
|
*id "${$location} ${$c1}" |
|
*proc -name "${$location} ${$c1}" -help\ |
|
"arglist:${$arglist}" |
|
*values |
|
}] |
|
set i 0 |
|
foreach a $arglist { |
|
switch -- [llength $a] { |
|
1 { |
|
if {$i == [llength $arglist]-1 && $a eq "args"} { |
|
#'args' is only special if last |
|
append argspec \n "args -optional 1 -multiple 1" |
|
} else { |
|
append argspec \n "$a" |
|
} |
|
} |
|
2 { |
|
append argspec \n "[lindex $a 0] -default {[lindex $a 1]} -optional 1" |
|
} |
|
default { |
|
error "punk::ns::arginfo unexpected argument signature '$arglist'\ndef:$def\nimplementaions:$implementations" |
|
} |
|
} |
|
incr i |
|
} |
|
punk::args::definition $argspec |
|
return [punk::args::usage {*}$opts "$location $c1"] |
|
} else { |
|
return "unable to resolve $origin method $c1" |
|
} |
|
|
|
} |
|
} |
|
} |
|
} |
|
set choicelabeldict [dict create] |
|
foreach cmd $public_methods { |
|
switch -- $cmd { |
|
new - create - destroy { |
|
#todo |
|
} |
|
default { |
|
set implementations [::info object call $origin $cmd] |
|
set def "" |
|
foreach impl $implementations { |
|
lassign $impl generaltype mname location methodtype |
|
switch -- $generaltype { |
|
method - private { |
|
if {$location eq "object"} { |
|
set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" |
|
} else { |
|
set id "[string trimleft $location :] $cmd" ;# "<class> <method>" |
|
} |
|
if {[info commands ::punk::args::id_exists] ne ""} { |
|
if {[punk::args::id_exists $id]} { |
|
dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" |
|
} |
|
} |
|
break |
|
} |
|
filter { |
|
} |
|
unknown { |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceprefix 0] ;#methods must be specified in full always? - review |
|
#puts stderr "--->$vline" |
|
set argspec [punk::lib::tstr -return string { |
|
*id ${$origin} |
|
*proc -name "Object: ${$origin}" -help\ |
|
"Instance of class: ${$class}" |
|
*values -min 1 |
|
}] |
|
append argspec \n $vline |
|
punk::args::definition $argspec |
|
return [punk::args::usage {*}$opts $origin] |
|
} |
|
privateObject { |
|
return "Command is a privateObject - no info currently available" |
|
} |
|
privateClass { |
|
return "Command is a privateClass - no info currently available" |
|
} |
|
interp { |
|
#todo |
|
} |
|
} |
|
|
|
#check ensemble before testing punk::arg::id_exists |
|
#we want to recalculate ensemble usage info in case ensemble has been modified |
|
|
|
if {[namespace ensemble exists $origin]} { |
|
#review |
|
#todo - check -unknown |
|
#if there is a -unknown handler - we can't be sure the choices in -map or from -namespace are exhaustive. |
|
#presumably -choiceprefix should be zero in that case?? |
|
|
|
set ensembleinfo [namespace ensemble configure $origin] |
|
set prefixes [dict get $ensembleinfo -prefixes] |
|
set map [dict get $ensembleinfo -map] |
|
set ns [dict get $ensembleinfo -namespace] |
|
|
|
#review - we can have a combination of commands from -map as well as those exported from -namespace |
|
# if and only if -subcommands is specified |
|
|
|
set subcommand_dict [dict create] |
|
set commands [list] |
|
set nscommands [list] |
|
if {[llength [dict get $ensembleinfo -subcommands]]} { |
|
#set exportspecs [namespace eval $ns {namespace export}] |
|
#foreach pat $exportspecs { |
|
# lappend nscommands {*}[info commands ${ns}::$pat] |
|
#} |
|
#when using -subcommands, even unexported commands are available |
|
set nscommands [info commands ${ns}::*] |
|
foreach sub [dict get $ensembleinfo -subcommands] { |
|
if {[dict exists $map $sub]} { |
|
#-map takes precence over same name exported from -namespace |
|
dict set subcommand_dict $sub [dict get $map $sub] |
|
} elseif {"${ns}::$sub" in $nscommands} { |
|
dict set subcommand_dict $sub ${ns}::$sub |
|
} else { |
|
#subcommand probably supplied via -unknown handler? |
|
dict set subcommand_dict $sub "" |
|
} |
|
} |
|
} else { |
|
if {[dict size $map]} { |
|
set subcommand_dict $map |
|
} else { |
|
set exportspecs [namespace eval $ns {namespace export}] |
|
foreach pat $exportspecs { |
|
lappend nscommands {*}[info commands ${ns}::$pat] |
|
} |
|
foreach fqc $nscommands { |
|
dict set subcommand_dict [namespace tail $fqc] $fqc |
|
} |
|
} |
|
} |
|
|
|
|
|
set subcommands [lsort [dict keys $subcommand_dict]] |
|
if {[llength $commandargs]} { |
|
set match [tcl::prefix::match $subcommands [lindex $commandargs 0]] |
|
if {$match in $subcommands} { |
|
set subcmd [dict get $subcommand_dict $match] |
|
return [arginfo {*}$subcmd {*}[lrange $commandargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") |
|
} |
|
} |
|
|
|
set namespaces [list] ;# usually only 1 or 2 namespaces - but could be any number. |
|
dict for {sub subwhat} $subcommand_dict { |
|
set ns [::namespace which $subwhat] |
|
if {$ns ni $namespaces} { |
|
lappend namespaces $ns |
|
} |
|
} |
|
set have_usageinfo [list] |
|
set is_ensemble [list] |
|
set is_object [list] |
|
foreach ns $namespaces { |
|
set nsinfo [lindex [punk::ns::nslist_dict [nsjoin [nsprefix $ns] *]] 0] |
|
lappend have_usageinfo {*}[dict get $nsinfo usageinfo] |
|
lappend is_ensemble {*}[dict get $nsinfo ensembles] |
|
lappend is_object {*}[dict get $nsinfo ooobjects] |
|
} |
|
|
|
set choicelabeldict [dict create] |
|
foreach sub $subcommands { |
|
if {$sub in $have_usageinfo} { |
|
dict set choicelabeldict $sub " [Usageinfo_mark brightgreen]" |
|
} elseif {$sub in $is_ensemble} { |
|
dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" |
|
} elseif {$sub in $is_object} { |
|
dict set choicelabeldict $sub " [Usageinfo_mark brightyellow]" |
|
} |
|
} |
|
|
|
set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict] |
|
set argspec [punk::lib::tstr -return string { |
|
*id ${$origin} |
|
*proc -help "ensemble: ${$origin}" |
|
*values -min 1 |
|
}] |
|
append argspec \n $vline |
|
punk::args::definition $argspec |
|
return [punk::args::usage {*}$opts $origin] |
|
} |
|
|
|
#check for tepam help |
|
if {[info exists ::tepam::ProcedureList]} { |
|
if {$origin in $::tepam::ProcedureList} { |
|
return [tepam::ProcedureHelp $origin 1] ;#use 1 to return rather than emit to stdout |
|
} else { |
|
#handle any tepam functions that don't eat their own dogfood but have help variables |
|
#e.g tepam::procedure, tepam::argument_dialogbox |
|
#Rather than hardcode these - we'll guess that any added will use the same scheme.. |
|
if {[namespace qualifiers $origin] eq "::tepam"} { |
|
set func [namespace tail $origin] |
|
#tepam XXXHelp vars don't exactly match procedure names :/ |
|
if {[info exists ::tepam::${func}Help]} { |
|
return [set ::tepam::${func}Help] |
|
} else { |
|
set f2 [string totitle $func] |
|
if {[info exists ::tepam::${f2}Help]} { |
|
return [set ::tepam::${f2}Help] |
|
} |
|
#e.g argument_dialogbox -> ArgumentDialogboxHelp |
|
set parts [split $func _] |
|
set uparts [lmap p $parts {string totitle $p}] |
|
set f3 [join [list {*}$uparts Help] ""] |
|
if {[info exists ::tepam::${f3}]} { |
|
return [set ::tepam::${f3}] |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
set id [string trimleft $origin :] |
|
if {[info commands ::punk::args::id_exists] ne ""} { |
|
if {[punk::args::id_exists $id]} { |
|
return [uplevel 1 [list punk::args::usage {*}$opts $id]] |
|
} |
|
} |
|
set origin_ns [nsprefix $origin] |
|
set parts [nsparts $origin_ns] |
|
set weird_ns 0 |
|
if {[lsearch $parts :*] >=0} { |
|
set weird_ns 1 |
|
} |
|
if {$weird_ns} { |
|
set argl {} |
|
set tail [nstail $origin] |
|
foreach a [nseval_ifexists $origin_ns [list info args $tail]] { |
|
if {[nseval_ifexists $origin_ns [list info default $tail $a def]]} { |
|
lappend a $def |
|
} |
|
lappend argl $a |
|
} |
|
} else { |
|
set argl {} |
|
foreach a [info args $origin] { |
|
if {[info default $origin $a def]} { |
|
lappend a $def |
|
} |
|
lappend argl $a |
|
} |
|
} |
|
|
|
set msg "No argument processor detected" |
|
append msg \n "function signature: $resolved $argl" |
|
return $msg |
|
} |
|
|
|
#todo - package up as navns |
|
proc corp {path} { |
|
#thanks to Richard Suchenwirth for the original - wiki.tcl-lang.org/page/corp |
|
#Note: modified here to support aliases and relative/absolute name (with respect to namespace .ie ::name vs name) |
|
if {[info exists punk::console::tabwidth]} { |
|
set tw $::punk::console::tabwidth |
|
} else { |
|
set tw 8 |
|
} |
|
set indent [string repeat " " $tw] ;#match |
|
#set indent [string repeat " " $tw] ;#A more sensible default for code - review |
|
|
|
if {[info exists ::auto_index($path)]} { |
|
set body "\n${indent}#corp# auto_index $::auto_index($path)" |
|
} else { |
|
set body "" |
|
} |
|
|
|
#we want to handle edge cases of commands such as "" or :x |
|
#various builtins such as 'namespace which' won't work |
|
if {[string match ::* $path]} { |
|
set targetns [nsprefix $path] |
|
set name [nstail $path] |
|
} else { |
|
set thispath [uplevel 1 [list ::nsthis $path]] |
|
set targetns [nsprefix $thispath] |
|
set name [nstail $thispath] |
|
} |
|
#puts stderr "corp upns:$upns" |
|
|
|
#set name [string trim $name :] |
|
#set origin [namespace origin ${upns}::$name] |
|
set origin [nseval $targetns [list ::namespace origin $name]] |
|
set resolved [nseval $targetns [list ::namespace which $name]] |
|
|
|
#An renamed alias may exist that is the same name as a proc that was created later.. so we must check for the proc before looking into aliases! |
|
if {$origin ni [info procs $origin]} { |
|
|
|
#It seems an interp alias of "::x"" behaves the same as "x" |
|
#But we can't create both at the same time - and they have to be queried by the exact name. |
|
#So we query for alias with and without leading :: |
|
set alias_qualified [interp alias {} [string trim $origin :]] |
|
set alias_unqualified [interp alias {} $origin] |
|
if {[string length $alias_qualified] && [string length $alias_unqualified]} { |
|
#our assumptions are wrong.. change in tcl version? |
|
puts stderr "corp: Found alias for unqualified name:'[string trim $origin :]' and qualified name: '$origin' - unexpected (assumed impossible as at Tcl 8.6)" |
|
if {$alias_qualified ne $alias_unqalified} { |
|
|
|
} else { |
|
set alias $alias_unqualified |
|
} |
|
} else { |
|
set alias ${alias_qualified}${alias_unqualified} ;#concatenate - as at least one should be empty |
|
} |
|
|
|
if {[string length $alias]} { |
|
#todo - consider following alias-chain to ultimate proc? |
|
#it can always be manually done with: |
|
#.= corp $name |/1> corp |/1> corp .. |
|
#depending on number of aliases in the chain |
|
return [list alias {*}$alias] |
|
} |
|
} |
|
if {[nsprefix $origin] ne [nsprefix [nsjoin ${targetns} $name]]} { |
|
append body \n "${indent}#corp# namespace origin $origin" |
|
} |
|
|
|
if {$body ne "" && [string index $body end] ne "\n"} { |
|
append body \n |
|
} |
|
if {![catch {package require textutil::tabify} errpkg]} { |
|
set bodytext [info body $origin] |
|
#punk::lib::indent preserves trailing empty lines - unlike textutil version |
|
set bodytext [punk::lib::undent [textutil::untabify2 $bodytext $tw]] |
|
append body [punk::lib::indent $bodytext $indent] |
|
} else { |
|
append body [info body $origin] |
|
} |
|
set argl {} |
|
foreach a [info args $origin] { |
|
if {[info default $origin $a def]} { |
|
lappend a $def |
|
} |
|
lappend argl $a |
|
} |
|
#list proc [nsjoin ${targetns} $name] $argl $body |
|
list proc $resolved $argl $body |
|
} |
|
|
|
|
|
#review ??? |
|
proc ns_relative_to_location {name} { |
|
if {[string match ::* $name]} { |
|
error "ns_relative_to_location accepts a relative namespace name only ie one without leading ::" |
|
} |
|
|
|
} |
|
proc ns_absolute_to_location {name} { |
|
|
|
} |
|
|
|
|
|
tcl::namespace::eval internal { |
|
|
|
|
|
#maintenance: similar in punk::winrun |
|
proc get_run_opts {options alias_dict arglist} { |
|
if {[catch { |
|
set callerinfo [info level -1] |
|
} errM]} { |
|
set caller "" |
|
} else { |
|
set caller [lindex $callerinfo 0] |
|
} |
|
|
|
#update alias dict mapping shortnames to longnames - longnames to self |
|
foreach o $options { |
|
dict set alias_dict $o $o |
|
} |
|
set known_runopts [dict keys $alias_dict] |
|
set runopts [list] |
|
set cmdargs [list] |
|
|
|
set first_eopt_posn [lsearch $arglist --] |
|
if {$first_eopt_posn >=0} { |
|
set pre_eopts [lrange $arglist 0 $first_eopt_posn-1] |
|
set is_eopt_for_runopts 1 ;#default assumption that it is for this function rather than part of user's commandline - cycle through previous args to disprove. |
|
foreach pre $pre_eopts { |
|
if {$pre ni $known_runopts} { |
|
set is_eopt_for_runopts 0; #the first -- isn't for us. |
|
} |
|
} |
|
} else { |
|
set is_eopt_for_runopts 0 |
|
} |
|
#split on first -- if only known opts preceding (or nothing preceeding) - otherwise split on first arg that doesn't look like an option and bomb if unrecognised flags before it. |
|
if {$is_eopt_for_runopts} { |
|
set idx_first_cmdarg [expr $first_eopt_posn + 1] |
|
set runopts [lrange $arglist 0 $idx_first_cmdarg-2] ;#exclude -- from runopts - it's just a separator. |
|
} else { |
|
set idx_first_cmdarg [lsearch -not $arglist "-*"] |
|
set runopts [lrange $arglist 0 $idx_first_cmdarg-1] |
|
} |
|
set cmdargs [lrange $arglist $idx_first_cmdarg end] |
|
foreach o $runopts { |
|
if {$o ni $known_runopts} { |
|
error "$caller: Unknown runoption $o - known options $known_runopts" |
|
} |
|
} |
|
set runopts [lmap o $runopts {dict get $alias_dict $o}] |
|
#todo - get these out of here. Should be supplied by caller. |
|
if {"-allowvars" in $runopts && "-disallowvars" in $runopts} { |
|
puts stderr "Warning - conflicting options -allowvars & -disallowvars specified: $arglist" |
|
} |
|
|
|
#maintain order: runopts $runopts cmdargs $cmdargs as first 4 args (don't break 'lassign [get_runopts $args] _ runopts _ cmdargs') |
|
#todo - add new keys after these indicating type of commandline etc. |
|
return [list runopts $runopts cmdargs $cmdargs] |
|
} |
|
|
|
proc _pkguse_vars {varnames} { |
|
while {"pkguse_vars_[incr n]" in $varnames} {} |
|
#return [concat $varnames pkguse_vars_$n] |
|
return [list {*}$varnames pkguse_vars_$n] |
|
} |
|
proc tracehandler_nowrite {args} { |
|
error "readonly in use block" |
|
} |
|
|
|
} |
|
|
|
|
|
#load package and move to namespace of same name if run interactively with only pkg/namespace argument. |
|
#if args is supplied - first word is script to run in the namespace remaining args are args passed to scriptblock |
|
#if no newline or $args in the script - treat as one-liner and supply {*}$args automatically |
|
proc pkguse {pkg_or_existing_ns args} { |
|
lassign [internal::get_run_opts {-vars -nowarnings} {} $args] _r runopts _c cmdargs |
|
set use_vars [expr {"-vars" in $runopts}] |
|
set no_warnings [expr {"-nowarnings" in $runopts}] |
|
set ver "" |
|
|
|
|
|
#todo support leading solo flags such as -capture to control whether we do a static capture of local vars in the ns |
|
switch -- [string tolower $pkg_or_existing_ns] { |
|
"::" - global { |
|
set ns :: |
|
set ver "";# tcl version? |
|
} |
|
default { |
|
if {[string match ::* $pkg_or_existing_ns]} { |
|
set pkg_unqualified [string range $pkg_or_existing_ns 2 end] |
|
if {![tcl::namespace::exists $pkg_or_existing_ns]} { |
|
set ver [package require $pkg_unqualified] |
|
} else { |
|
set ver "" |
|
} |
|
set ns $pkg_or_existing_ns |
|
} else { |
|
set pkg_unqualified $pkg_or_existing_ns |
|
set ver [package require $pkg_unqualified] |
|
set ns ::$pkg_unqualified |
|
} |
|
#some packages don't create their namespace immediately and/or don't populate it with commands and instead put entries in ::auto_index |
|
set previous_command_count 0 |
|
if {[namespace exists $ns]} { |
|
set previous_command_count [llength [info commands ${ns}::*]] |
|
} |
|
|
|
|
|
#also if a sub package was loaded first - then the namespace for the base or lower package may exist but have no commands |
|
#for the purposes of pkguse - which most commonly interactive - we want the namespace populated |
|
#It may still not be *fully* populated because we stop at first source that adds commands - REVIEW |
|
set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}] |
|
|
|
if {!$ns_populated} { |
|
#we will catch-run an auto_index entry if any |
|
#auto_index entry may or may not be prefixed with :: |
|
set keys [list] |
|
#first look for exact pkg_unqualified and ::pkg_unqualified |
|
#leave these at beginning of keys list |
|
if {[array exists ::auto_index($pkg_unqualified)]} { |
|
lappend keys $pkg_unqualified |
|
} |
|
if {[array exists ::auto_index(::$pkg_unqualified)]} { |
|
lappend keys ::$pkg_unqualified |
|
} |
|
#as auto_index is an array - we could get keys in arbitrary order |
|
set matches [lsort [array names ::auto_index ${pkg_unqualified}::*]] |
|
lappend keys {*}$matches |
|
set matches [lsort [array names ::auto_index ::${pkg_unqualified}::*]] |
|
lappend keys {*}$matches |
|
set ns_populated 0 |
|
set i 0 |
|
set already_sourced [list] ;#often multiple triggers for the same source - don't waste time re-sourcing |
|
set ns_depth [llength [punk::ns::nsparts [string trimleft $ns :]]] |
|
while {!$ns_populated && $i < [llength $keys]} { |
|
#todo - skip sourcing deeper entries from a subpkg which may have been loaded earlier than the base |
|
#e.g if we are loading ::x::y |
|
#only source for keys the same depth, or one deeper ie ::x::y, x::y, ::x::y::z not ::x or ::x::y::z::etc |
|
set k [lindex $keys $i] |
|
set k_depth [llength [punk::ns::nsparts [string trimleft $k :]]] |
|
if {$k_depth == $ns_depth || $k_depth == $ns_depth + 1} { |
|
set auto_source [set ::auto_index($k)] |
|
if {$auto_source ni $already_sourced} { |
|
uplevel 1 $auto_source |
|
lappend already_sourced $auto_source |
|
set ns_populated [expr {[tcl::namespace::exists $ns] && [llength [info commands ${ns}::*]] > $previous_command_count}] |
|
} |
|
} |
|
incr i |
|
} |
|
|
|
} |
|
} |
|
} |
|
if {[tcl::namespace::exists $ns]} { |
|
if {[llength $cmdargs]} { |
|
set binding {} |
|
#if {[info level] == 1} { |
|
# #up 1 is global |
|
# set get_vars [list info vars] |
|
#} else { |
|
# set get_vars [list info locals] |
|
#} |
|
#set vars [uplevel 1 {*}$get_vars] |
|
|
|
#set vars [tcl::namespace::eval $ns {info vars}] |
|
|
|
#review - upvar in apply within ns eval vs direct access of ${ns}::varname |
|
set capture [tcl::namespace::eval $ns { |
|
apply { varnames { |
|
while {"prev_args[incr n]" in $varnames} {} |
|
set capturevars [dict create] |
|
set capturearrs [dict create] |
|
foreach fullv $varnames { |
|
set v [namespace tail $fullv] |
|
upvar 1 $v var |
|
if {[info exists var]} { |
|
if {$v eq "args"} { |
|
dict set capturevars "prev_args$n" [list var $var] |
|
} else { |
|
if {(![array exists var])} { |
|
dict set capturevars $v $var |
|
} else { |
|
dict set capturearrs $v [array get var] |
|
} |
|
} |
|
} else { |
|
#A variable can show in the results for 'info vars' (or nsvars) 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] |
|
} } [info vars [namespace current]::*] ;#we are relying on info vars ::::* returning same as info vars ::* - a bit hacky (don't want to set any extra vars in the ns) |
|
} ] |
|
|
|
|
|
set arglist [lassign $cmdargs scriptblock] |
|
if {[string first "\n" $scriptblock] <0 && [string first {$args} $scriptblock] <0} { |
|
#one liner without use of $args |
|
append scriptblock { {*}$args} |
|
#tailcall apply [list args [string cat $scriptblock { {*}$args}] $ns] {*}$arglist |
|
} |
|
if {!$no_warnings & $use_vars} { |
|
set script "" |
|
foreach v [dict keys [dict get $capture vars]] { |
|
append script [string map [list <v> $v] { |
|
trace add variable <v> write ::punk::ns::internal::tracehandler_nowrite |
|
#unset? |
|
}] |
|
} |
|
append script \n $scriptblock |
|
} else { |
|
set script $scriptblock |
|
} |
|
if {$use_vars} { |
|
tailcall apply [list [concat [dict keys [dict get $capture vars]] args] $script $ns] {*}[concat [dict values [dict get $capture vars]] $arglist] |
|
} else { |
|
tailcall apply [list args $scriptblock $ns] {*}$arglist |
|
} |
|
} else { |
|
set out [punk::ns::ns/ / $ns] |
|
append out \n $ver |
|
return $out |
|
} |
|
} else { |
|
if {$ver eq ""} { |
|
error "Namespace $ns not found. No package version found." |
|
} else { |
|
set out "(no package namespace found) remaining in [uplevel 1 {namespace current}]" |
|
append out \n $ver |
|
return $out |
|
} |
|
} |
|
return $out |
|
} |
|
interp alias "" use "" punk::ns::pkguse |
|
|
|
punk::args::definition { |
|
*id punk::ns::nsimport_noclobber |
|
*proc -name punk::ns::nsimport_noclobber -help\ |
|
"Import exported commands from a namespace into either the current namespace, |
|
or that specified in -targetnamespace. |
|
Return list of imported commands, ignores failures due to name conflicts" |
|
-targetnamespace -optional 1 -help\ |
|
"Namespace in which to import commands. |
|
If namespace is relative (no leading ::), |
|
the namespace is relative to the caller'd namespace. |
|
If not supplied, caller's namespace is used." |
|
-prefix -optional 1 -help\ |
|
"string prefix for command names in target namespace" |
|
*values -min 1 -max 1 |
|
sourcepattern -type string -optional 0 -help\ |
|
"Glob pattern for source namespace. |
|
Globbing only active in the tail segment. |
|
e.g ::mynamespace::*" |
|
} |
|
proc nsimport_noclobber {args} { |
|
lassign [dict values [punk::args::get_by_id punk::ns::nsimport_noclobber $args]] leaders opts values received |
|
set sourcepattern [dict get $values sourcepattern] |
|
|
|
set source_ns [tcl::namespace::qualifiers $sourcepattern] |
|
if {![tcl::namespace::exists $source_ns]} { |
|
error "nsimport_noclobber error namespace $source_ns not found" |
|
} |
|
set nscaller [uplevel 1 {namespace current}] |
|
if {![dict exists $received -targetnamespace]} { |
|
set target_ns $nscaller |
|
} else { |
|
set target_ns [dict get $opts -targetnamespace] |
|
if {![string match ::* $target_ns]} { |
|
set target_ns [punk::nsjoin $nscaller $target_ns] |
|
} |
|
} |
|
|
|
set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] |
|
set a_commands [info commands $sourcepattern] |
|
set a_tails [lmap v $a_commands {tcl::namespace::tail $v}] |
|
set a_exported_tails [list] |
|
foreach epattern $a_export_patterns { |
|
set matches [lsearch -all -inline $a_tails $epattern] |
|
foreach m $matches { |
|
if {$m ni $a_exported_tails} { |
|
lappend a_exported_tails $m |
|
} |
|
} |
|
} |
|
set nstemp ::punk::ns::temp_import |
|
if {[tcl::dict:::exists $received -prefix]} { |
|
set pfx [dict get $opts -prefix] |
|
set imported_commands [list] |
|
if {[namespace exists $nstemp]} { |
|
namespace delete $nstemp |
|
} |
|
namespace eval $nstemp {} |
|
foreach e $a_exported_tails { |
|
set imported [tcl::namespace::eval $nstemp [string map [list <func> $e <a> $source_ns <pfx> $pfx <tgtns> $target_ns] { |
|
set cmd "" |
|
if {![catch {namespace import <a>::<func>}]} { |
|
#renaming will fail if target already exists |
|
#renaming a command into another namespace still results in a command with 'info cmdtype' = 'import' |
|
if {![catch {rename <func> [punk::ns::nsjoin <tgtns> <pfx><func>]}]} { |
|
set cmd <pfx><func> |
|
} |
|
} |
|
set cmd |
|
}]] |
|
if {$imported ne ""} { |
|
lappend imported_commands $imported |
|
} |
|
} |
|
namespace delete $nstemp |
|
return $imported_commands |
|
} |
|
|
|
set imported_commands [list] |
|
foreach e $a_exported_tails { |
|
set imported [tcl::namespace::eval $target_ns [string map [list <func> $e <a> $source_ns] { |
|
set cmd "" |
|
if {![catch {namespace import <a>::<func>}]} { |
|
set cmd <func> |
|
} |
|
set cmd |
|
}]] |
|
if {[string length $imported]} { |
|
lappend imported_commands $imported |
|
} |
|
} |
|
return $imported_commands |
|
} |
|
|
|
#todo - use ns::nsimport_noclobber instead ? |
|
|
|
interp alias {} nsthis {} punk::ns::nspath_here_absolute |
|
interp alias {} nsorigin {} apply {ns {namespace origin [uplevel 1 ::punk::ns::nspath_here_absolute $ns]} ::} |
|
interp alias {} nsvars {} punk::ns::nsvars |
|
interp alias {} nsjoin {} punk::ns::nsjoin |
|
interp alias {} nsprefix {} punk::ns::nsprefix |
|
interp alias {} nstail {} punk::ns::nstail |
|
interp alias {} nsparts {} punk::ns::nsparts |
|
interp alias {} nschildren {} punk::ns::nschildren |
|
interp alias {} nstree {} punk::ns::nstree |
|
#namespace/command/proc query |
|
interp alias {} nslist {} punk::ns::nslist |
|
interp alias {} nslist_dict {} punk::ns::nslist_dict |
|
|
|
#extra slash implies more verbosity (ie display commands instead of just nschildren) |
|
interp alias {} n/ {} punk::ns::ns/ / |
|
interp alias {} n// {} punk::ns::ns/ // |
|
interp alias {} n/// {} punk::ns::ns/ /// |
|
interp alias {} n/new {} punk::ns::n/new |
|
interp alias {} nn/ {} punk::ns::nsup/ / |
|
interp alias {} nn// {} punk::ns::nsup/ // |
|
if 0 { |
|
#we can't have ::/ without just plain / which is confusing. |
|
interp alias {} :/ {} punk::ns::ns/ / |
|
interp alias {} :// {} punk::ns::ns/ // |
|
interp alias {} :/new {} punk::ns::n/new |
|
interp alias {} ::/ {} punk::ns::nsup/ / |
|
interp alias {} ::// {} punk::ns::nsup/ // |
|
} |
|
|
|
|
|
interp alias {} corp {} punk::ns::corp |
|
interp alias {} i {} punk::ns::arginfo |
|
|
|
|
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::ns [tcl::namespace::eval punk::ns { |
|
variable version |
|
set version 999999.0a1.0 |
|
}] |
|
return |