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.
7374 lines
350 KiB
7374 lines
350 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 0.1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
#BUGS |
|
# 2025-08 |
|
# n// and n/// won't output info about 'namespace path' if there are no commands in the namespace |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## 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 { |
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
tcl::namespace::import ::punk::ansi::a+ ::punk::ansi::a |
|
# -- --- --- --- --- |
|
#non colour SGR codes |
|
# we can use these directly via ${$I} etc without marking a definition with @dynamic |
|
#This is because they don't need to change when colour switched on and off. |
|
set I [a+ italic] |
|
set NI [a+ noitalic] |
|
set B [a+ bold] |
|
set N [a+ normal] |
|
set T [a+ bold underline] |
|
set NT [a+ normal nounderline] |
|
set LC \u007b ;#left curly brace |
|
set RC \u007d ;#right curly brace |
|
# -- --- --- --- --- |
|
|
|
namespace import ::punk::args::helpers::* |
|
|
|
} |
|
} |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
tcl::namespace::eval punk::ns { |
|
variable ns_current |
|
#allow presetting |
|
if {![info exists ::punk::ns::ns_current]} { |
|
set 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 pkguse cmdtype synopsis |
|
namespace path {::punk::lib ::punk::ansi} ;#list_as_lines etc |
|
|
|
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 {::tcl::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 -types $types -nspathcommands $nspathcommands [nsjoin $ns_current *]] |
|
} else { |
|
set is_absolute [string match ::* $ns_or_glob] |
|
set has_globchars [regexp {[*?]} $ns_or_glob] ;#basic globs only? |
|
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 -types $types -nspathcommands $nspathcommands $ns_or_glob] |
|
} |
|
} 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 -types $types -nspathcommands $nspathcommands [nsjoin $nsnext *]] |
|
} else { |
|
set ns_queried [nsjoin $ns_current $ns_or_glob] |
|
set out [nslist -types $types -nspathcommands $nspathcommands [nsjoin $ns_current $ns_or_glob]] |
|
} |
|
} |
|
} |
|
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_cached $nspath] |
|
if {[lindex $parts 0] ne ""} { |
|
#relative |
|
set ns_caller [uplevel 1 [list ::tcl::namespace::current]] |
|
set fq_nspath [nsjoin $ns_caller $nspath] |
|
} else { |
|
set fq_nspath $nspath |
|
} |
|
if {[nseval_ifexists $fq_nspath {::string cat ok}] eq "ok"} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
|
|
#todo - consider coroutine-based implementation? |
|
|
|
#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_cached $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 |
|
} |
|
|
|
#for 'weird' namespaces, this uses a generated nested script |
|
#It has to run this (probably non byte-compiled?) script twice in some cases |
|
#consider coroutine-based alternative? |
|
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 |
|
} |
|
if {[lsearch [nsparts $nsfq] :*] >=0} { |
|
#weird_ns |
|
set ns_script [nseval_ifexists_getscript $nsfq] |
|
#we need to return an error if the script itself errors - but not return an error due to ns not existing |
|
if {[catch {uplevel 1 [list {*}$ns_script {::string cat ok}]} isok]} { |
|
#the error must be due to ns path not existing |
|
return |
|
} else { |
|
#only re-run if script is something else |
|
if {$script ne {::string cat ok}} { |
|
#some other script - if it raises an error we want to see it. |
|
return [uplevel 1 [list {*}$ns_script $script]] |
|
} else { |
|
return $isok |
|
} |
|
} |
|
} else { |
|
if {[namespace exists $nsfq]} { |
|
return [namespace eval $nsfq $script] |
|
} |
|
} |
|
} |
|
|
|
#resulting script can error for non-existant ns |
|
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>" |
|
} |
|
}] |
|
} |
|
|
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::nschildren |
|
@cmd -name punk::ns::nschildren |
|
@opts |
|
-sort -default "natural" -choices {none natural ascii dictionary} |
|
ns |
|
} |
|
proc nschildren {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::ns::nschildren] |
|
set opt_sort [dict get $argd opts -sort] |
|
set ns [dict get $argd values 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]] |
|
switch -- $opt_sort { |
|
ascii { |
|
return [lsort $nslist] |
|
} |
|
dictionary { |
|
return [lsort -dictionary $nslist] |
|
} |
|
natural { |
|
package require natsort |
|
return [natsort::sort $nslist] |
|
} |
|
default { |
|
return $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 ::] |
|
} |
|
|
|
#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 nsparts1 {nspath} { |
|
set nspath [string map {:::: ::} $nspath] |
|
set mapped [string map {:: \u0FFF} $nspath] |
|
set parts [split $mapped \u0FFF] |
|
#if {[lindex $parts end] eq ""} { |
|
#} |
|
return $parts |
|
} |
|
|
|
|
|
#Memory leak for systems that create and delete a lot of differently names namespaces/commands - review |
|
#consider configuration option to disable for large long-running systems? |
|
#re-code nsparts in c/zig to make a performant version and avoid caching? |
|
variable nsparts_cache [dict create] |
|
proc nsparts_cached {nspath} { |
|
variable nsparts_cache |
|
if {[dict exists $nsparts_cache $nspath]} { |
|
return [dict get $nsparts_cache $nspath] |
|
} |
|
set parts [nsparts $nspath] |
|
dict set nsparts_cache $nspath $parts |
|
return $parts |
|
} |
|
#not that nsparts is insanely slow - but it's called frequently - hence nsparts_cached |
|
#noticeable for example when calling punk::ns::aliases whilst in global namespaces. |
|
proc nsparts {nspath} { |
|
#note that if all of :, :ns and ns: are valid namespace names (and they technically are in Tcl) |
|
#we get ambiguities if trying to join them. |
|
#eg ::a:::b could be "::a: b" or "::a :b" |
|
#however a::::b would unambiguously be "a: :b" |
|
#and a:::::b could only be "a : b" |
|
# a::::::b could be "a: : b" or "a : :b" |
|
#(ambiguities on mod 3 == 0 number of colons only?) |
|
#leading ::::x could be ": :x" - but it is probably commonly relied on in tcl scripts that this resolves to just ::x |
|
#A consistent rule to avoid ambiguity would need to be |
|
# "no leading/trailing colons in namespace names" |
|
# or "no leading colons in namespace names (except bare colon)" |
|
# or "no trailing colons in namespace names (except bare colon)" |
|
# |
|
#The no trailing version has more utility - (sorting of colon namespaces together) and would allow processing of runs of colons left-to-right |
|
#There remains ambiguity in that a relative namespace involving leading colons can't always be distinguished from an absolute namespace. |
|
#ie :::x could represent ":x" in absolute terms or ": x" as a relative path. |
|
#as leading :: is the normal way to decide a namespace is absolute - this leaves no way of specifying a relative namespace if the next sub namespace is just ":" |
|
# |
|
#for no trailing colon |
|
#number of intermediate colons cannot be a number in the sequence |
|
#4,7,10,13,16,19,22... |
|
#if it is - we must trip 2 colons |
|
#4 x::::x -> x::x = x,x |
|
#7 x:::::::x -> x:::::x = x,:,x |
|
#10 x::::::::::x -> x::::::::x = x,:,:,x |
|
|
|
#after stripping 2 - valid nums are |
|
#1 x:x (internal - part of ns) |
|
#2 x::x |
|
#3 x:: :x |
|
#5 x:: : ::x |
|
#6 x:: : :: :x |
|
#8 x:: : :: : ::x |
|
#9 x:: : :: : :: :x |
|
#11 x:: : :: : :: : ::x |
|
#12 x:: : :: : :: : :: :x |
|
#14 x:: : :: : :: : :: : ::x |
|
#15 x:: : :: : :: : :: : :: :x |
|
#17 x:: : :: : :: : :: : :: : ::x |
|
#18 x:: : :: : :: : :: : :: : :: :x |
|
|
|
if {$nspath eq ""} { |
|
return "" |
|
} |
|
|
|
set s 0 |
|
set parts [list] |
|
set p "" |
|
set cend -1 |
|
while {[regexp -start $s -indices {(:+)[^:]*} $nspath _all cindices]} { |
|
lassign $cindices cstart cend |
|
append p [string range $nspath $s $cstart-1] |
|
set numcolons [expr {$cend - $cstart + 1}] |
|
#assert numcolons != 0 due to regexp + |
|
switch -exact -- $numcolons { |
|
2 - 4 { |
|
#4 is a somewhat common case - could handle with default branch but may as well short circuit here. |
|
lappend parts $p |
|
set p "" |
|
set s [expr {$cend+1}] |
|
#continue |
|
} |
|
1 { |
|
#internal colon |
|
append p : |
|
set s [expr {$cend+1}] |
|
#continue |
|
} |
|
default { |
|
if {($numcolons -1) %3 == 0} { |
|
set numcolons [expr {$numcolons -2}] |
|
} |
|
#assert numcolons >=4 and not in 7,10,13,16,19,22... sequence |
|
if {$numcolons % 3 == 0} { |
|
#if numcolons % 3 == 0 we have a leading colon left for next ns |
|
#this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y |
|
#we resolve with allowing leading colons only for each ns. |
|
set singlec_count [expr {($numcolons /3) -1}] |
|
if {$singlec_count > 0} { |
|
lappend parts $p {*}[lrepeat $singlec_count :] |
|
} else { |
|
lappend parts $p |
|
} |
|
set p ":" |
|
set s [expr {$cend+1}] |
|
#continue |
|
} else { |
|
set singlec_count [expr {(($numcolons +1)/3) -1}] |
|
if {$singlec_count > 0} { |
|
lappend parts $p {*}[lrepeat $singlec_count :] |
|
} else { |
|
lappend parts $p |
|
} |
|
set p "" |
|
set s [expr {$cend+1}] |
|
} |
|
} |
|
} |
|
} |
|
if {$cend < ([string length $nspath]-1)} { |
|
lappend parts $p[string range $nspath $cend+1 end] |
|
} else { |
|
#trailing colons |
|
set numcolons [expr {$cend - $cstart + 1}] |
|
lappend parts $p |
|
} |
|
return $parts |
|
} |
|
|
|
proc nsprefix {{nspath ""}} { |
|
set prefixparts [lrange [nsparts_cached $nspath] 0 end-1] |
|
if {[llength $prefixparts] == 1 && [lindex $prefixparts 0] eq ""} { |
|
return :: |
|
} |
|
return [join $prefixparts ::] |
|
} |
|
|
|
#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. |
|
# |
|
#nsprefix is *somewhat* like 'namespace parent' except that it is string based - ie no requirement for the namespaces to actually exist |
|
# - this is an important usecase even if the handling of 'unwise' command names isn't so critical. |
|
#nsprefix is more like 'namespace qualifiers' - but can return the global namespace as :: instead of empty string. |
|
proc nsprefix1 {{nspath ""}} { |
|
#normalize the common case of leading :::: and also collapse any internal runs of 4 (there can be no namespace named as empty string - as this is reserved for global ns by Tcl) |
|
|
|
while {[regexp {::::} $nspath]} { |
|
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 :] |
|
} |
|
} |
|
#deprecated |
|
proc nsprefix_orig {{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 :] |
|
} |
|
} |
|
|
|
proc nstail {nspath} { |
|
return [lindex [nsparts_cached $nspath] end] |
|
} |
|
|
|
#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. |
|
#This is only necessary in the context of requirement to browse namespaces with 'unwisely' named commands |
|
#For most purposes 'namespace tail' is fine. |
|
proc nstail1 {nspath args} { |
|
#normalize the common case of :::: |
|
while {[regexp {::::} $nspath]} { |
|
set nspath [string map {:::: ::} $nspath] |
|
} |
|
#it's unusual - but namespaces *can* have spaced in them. |
|
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] |
|
} |
|
#deprecated |
|
proc nstail_orig {nspath args} { |
|
#normalize the common case of :::: |
|
set nspath [string map {:::: ::} $nspath] |
|
#it's unusual - but namespaces *can* have spaced in them. |
|
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] |
|
} |
|
|
|
|
|
#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_cached $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_cached $glob] { |
|
switch -exact -- $seg { |
|
"" { |
|
lappend pats "" |
|
} |
|
* { |
|
#review - ::g*t will not find ::got:it (won't match single inner colon) - this should be fixed |
|
#lappend pats {[^:]*} |
|
#negative lookahead |
|
#any number of chars not followed by ::, followed by any number of non : |
|
lappend pats {(?:.(?!::))*[^:]*} |
|
} |
|
** { |
|
lappend pats {.*} |
|
} |
|
default { |
|
set seg [string map {. [.]} $seg] |
|
if {[regexp {[*?]} $seg]} { |
|
#set pat [string map [list ** {.*} * {[^:]*} ? {[^:]}] $seg] |
|
set pat [string map [list ** {.*} * {(?:.(?!::))*[^:]*} ? {[^:]}] $seg] |
|
lappend pats "$pat" |
|
} else { |
|
lappend pats "$seg" |
|
} |
|
} |
|
} |
|
} |
|
return "^[join $pats ::]\$" |
|
} |
|
#obsolete |
|
proc nsglob_as_re1 {glob} { |
|
#any segment that is not just * must match exactly one segment in the path |
|
set pats [list] |
|
foreach seg [nsparts_cached $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] |
|
} |
|
|
|
#namespace tree without globbing or weird ns consideration |
|
proc nstree_raw {{location ::}} { |
|
if {![string match ::* $location]} { |
|
error "nstree_raw requires a fully qualified namespace" |
|
} |
|
nstree_rawlist $location |
|
} |
|
proc nstree_rawlist {location} { |
|
set nslist [list $location] |
|
foreach ch [::namespace children $location] { |
|
lappend nslist {*}[nstree_rawlist $ch] |
|
} |
|
return $nslist |
|
} |
|
|
|
proc nstree {{location ""}} { |
|
if {![string match ::* $location]} { |
|
set nscaller [uplevel 1 {::tcl::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_cached $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] |
|
|
|
#jjj |
|
#set allchildren [lsort [nseval $base [list ::namespace children]]] |
|
#set allchildren [lsort [tcl::namespace::eval $base [list ::namespace children]]] |
|
set allchildren [lsort [nseval $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 |
|
} |
|
|
|
#The information symbol - usually i in a circle |
|
#punkargs " symbol \U1f6c8" ;#problematic on terminals that lie about cursor position after emitting this character |
|
#The older \u2139 could be used - but it is sometimes a boxed i, sometimes a bold stylized i, sometimes a pre-coloured boxed i |
|
#\u24d8 (circled latein small letter i) seems more consistent and can have our own colour applied. |
|
#variable usageinfo_char \U1f6c8 |
|
variable usageinfo_char \u24d8 |
|
|
|
# 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 ooc vs classmethod ooo vs objectmethod ? |
|
punk::args::define { |
|
@id -id ::punk::ns::Cmark |
|
@cmd -name punk::ns::Cmark |
|
@leaders |
|
type -choices {oo ooc classmethod coremethod ooo objectmethod punkargs ensemble native} -choicelabels { |
|
oo " symbol \u25c6" |
|
ooc " symbol \u25c7" |
|
classmethod " symbol \u25c7" |
|
coremethod " symbol \u25c9" |
|
ooo " symbol \u25c8" |
|
objectmethod " symbol \u25c8" |
|
punkargs " symbol \u24d8" |
|
ensemble " symbol \u24ba" |
|
native " symbol \u24c3" |
|
unknown " symbol \u2370" |
|
} |
|
@opts |
|
@values -min 0 -max -1 |
|
ansiname -type string -optional 1 -multiple 1 -help\ |
|
"ansi names as accepted by punk::ansi::a+ |
|
e.g |
|
red bold |
|
(Not raw ansi codes)" |
|
} |
|
proc Cmark {args} { |
|
if {[llength $args] == 0} { |
|
punk::args::parse {} -cache 1 withid ::punk::ns::Cmark |
|
return; #should be unreachable - parse should raise usage error |
|
} |
|
set type [lindex $args 0] |
|
set type [tcl::prefix::match -error "" {oo ooc classmethod coremethod ooo objectmethod punkargs ensemble native unknown} $type] |
|
set ansinames [lrange $args 1 end] |
|
switch -- $type { |
|
oo - ooc - classmethod - coremethod - ooo - objectmethod - punkargs - ensemble - native - unknown {} |
|
default { |
|
#punk::args::usage ::punk::ns::Cmark |
|
punk::args::parse $args withid ::punk::ns::Cmark |
|
return; #should be unreachable - parse should raise usage error |
|
} |
|
} |
|
set marks [dict create oo \u25c6 ooc \u25c7 classmethod \u25c7 coremethod \u25c9 ooo \u25c8 objectmethod \u25c8 punkargs \u24d8 ensemble \u24ba native \u24c3 unknown \U2370] |
|
if {[llength $ansinames]} { |
|
return "[punk::ansi::a+ {*}$ansinames][dict get $marks $type]\x1b\[0m" |
|
} else { |
|
return [dict get $marks $type] |
|
} |
|
} |
|
#NOTE: an alias may match in a namespace - but not have a corresponding command that matches that name (alias renamed) |
|
proc aliases {{tailglob *}} { |
|
set ns [uplevel 1 {::tcl::namespace::current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command |
|
|
|
set ns_segments [nsparts_cached $ns] ;#include empty string before leading :: |
|
if {![string length [lindex $ns_segments end]]} { |
|
#special case for :: only include leading segment rather than {} {} |
|
set ns_segments [lrange $ns_segments 0 end-1] |
|
} |
|
set segcount [llength $ns_segments] ;#only match number of segments matching current ns |
|
|
|
set all_aliases [interp aliases {}] |
|
set matched [list] |
|
foreach a $all_aliases { |
|
#normalize with leading :: |
|
if {![string match ::* $a]} { |
|
set abs ::$a |
|
} else { |
|
set abs $a |
|
} |
|
if {[string match ${ns}* $abs] && [string match *::$tailglob $abs]} { |
|
#Note that string match *::$tailglob $abs is not a proper match for all possible tailglobs |
|
#It reduces our search space to avoid too many 'nsparts' calls, but has false positives - still need to match tailglob to last segment only in the loop. |
|
set asegs [nsparts_cached $abs] |
|
#set asegs [split [string map {:: \uFFFF} $abs] \uFFFF] |
|
set acount [llength $asegs] |
|
#puts "alias $abs acount:$acount asegs:$asegs segcount:$segcount segments: $ns_segments" |
|
if {($acount - 1) == $segcount} { |
|
if {[lrange $asegs 0 end-1] eq $ns_segments} { |
|
if {[string match $tailglob [lindex $asegs end]]} { |
|
#report this alias in the current namespace - even though there may be no matching command |
|
lappend matched $a ;#add raw alias token which may or may not have leading :: |
|
} |
|
} |
|
} |
|
} |
|
} |
|
#set matched_abs [lsearch -all -inline $all_aliases $glob] |
|
return $matched |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::alias |
|
@cmd -name punk::ns::alias\ |
|
-summary\ |
|
"Get/set alias in current namespace."\ |
|
-help\ |
|
"" |
|
@opts |
|
-force -type none -help\ |
|
"" |
|
@values -min 0 -max -1 |
|
aliasorglob -default "" -optional 1 |
|
arg -type any -multiple 1 -optional 1 |
|
} |
|
#todo - use punk::args |
|
#enforce overwrite of alias or shadowing of resolvable command to require -force argument |
|
#todo - mechanism to keep track of all aliases made in session and allow saving to config? |
|
proc alias {args} { |
|
set argd [punk::args::parse $args withid ::punk::ns::alias] |
|
lassign [dict values $argd] leaders opts values received |
|
set aliasorglob [dict get $values aliasorglob] |
|
if {[dict exists $received arg]} { |
|
set arglist [dict get $values arg] |
|
} else { |
|
set arglist [list] |
|
} |
|
|
|
set nsthis [uplevel 1 {::tcl::namespace::current}] ;#must use :: - we can find ourselves in a namespace with a different 'namespace' command |
|
if {[llength $arglist]} { |
|
set nsparts [nsparts $aliasorglob] |
|
if {[lindex $nsparts 0] ne ""} { |
|
#relative ns path specified for aliasorglob |
|
set fqns [nsjoin $nsthis $aliasorglob] |
|
} else { |
|
set fqns $aliasorglob |
|
} |
|
set plain_fqns [string range $fqns 2 end] ;#tcl treats alias ::blah::etc the same as blah::etc |
|
#we will test for collisions with plain_fqns - but always create as fully qualified |
|
set all_aliases [interp aliases ""] |
|
set existing_target "" |
|
if {$fqns in $all_aliases} { |
|
set existing_target [interp alias "" $fqns] |
|
set aliasname $fqns |
|
} elseif {$plain_fqns in $all_aliases} { |
|
set existing_target [interp alias "" $plain_fqns] |
|
set aliasname $plain_fqns |
|
} |
|
if {([llength $arglist] ==1) && [string trim [lindex $arglist 0]] eq ""} { |
|
#use empty string/whitespace as intention to delete alias |
|
if {$existing_target ne ""} { |
|
puts stderr "Removing existing alias $aliasname -> $existing_target (in current session only)" |
|
} |
|
return [interp alias "" $fqns ""] |
|
} |
|
|
|
set firstword [lindex $arglist 0] |
|
set which [uplevel 1 [list ::tcl::namespace::which $firstword]] |
|
if {$which ne ""} { |
|
#use resolved |
|
lset arglist 0 $which |
|
} |
|
|
|
if {$existing_target ne ""} { |
|
puts stderr "Overwriting existing alias $aliasname -> $existing_target with $fqns -> $arglist (in current session only)" |
|
} else { |
|
#check if we are shadowing a resolvable command |
|
set resolved [namespace which $aliasorglob] |
|
if {$resolved ne ""} { |
|
puts stderr "Alias $fqns will shadow existing command $resolved when in current namespace" |
|
} |
|
} |
|
return [interp alias "" $fqns "" {*}$arglist] |
|
} else { |
|
if {![string length $aliasorglob]} { |
|
#no arguments or specific alias query - display all in current namespace |
|
puts stderr [uplevel 1 [list punk::ns::aliases]] |
|
return |
|
} |
|
|
|
set nsparts [nsparts $aliasorglob] |
|
if {[lindex $nsparts 0] ne ""} { |
|
#relative ns path specified for aliasorglob |
|
set fqns [nsjoin $nsthis $aliasorglob] |
|
} else { |
|
set fqns $aliasorglob |
|
} |
|
set plain_fqns [string range $fqns 2 end] ;#tcl treats alias ::blah::etc the same as blah::etc |
|
|
|
#we need to first check for exact match of alias that happens to have glob chars i.e the supplied aliasorglob looks like a glob but is actually directly an alias |
|
set target [interp alias "" $fqns] |
|
if {[llength $target]} { |
|
return $target |
|
} |
|
set target [interp alias "" $plain_fqns] |
|
if {[llength $target]} { |
|
return $target |
|
} |
|
|
|
#review |
|
if {([string first "*" $aliasorglob] >= 0) || ([string first "?" $aliasorglob] >= 0)} { |
|
set aliaslist [uplevel 1 [list punk::ns::aliases $aliasorglob]] |
|
puts stderr $aliaslist |
|
return |
|
} |
|
return [list] |
|
} |
|
} |
|
|
|
#REVIEW - ansi codes can be *very* confusing to the user when trying to handle lists etc.. |
|
punk::args::define { |
|
@id -id ::punk::ns::get_nslist |
|
@cmd -name punk::ns::get_nslist |
|
@opts |
|
-match -default "" |
|
-nsdict -type dict -default {} |
|
} |
|
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] |
|
if {$fq_glob eq ""} { |
|
set fq_glob [uplevel 1 nsthis]::* |
|
} |
|
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 {![dict size $opt_nsdict]} { |
|
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] |
|
} |
|
set usageinfo [dict get $contents usageinfo] |
|
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 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 " [Cmark punkargs brightgreen]" |
|
} else { |
|
set u "" |
|
} |
|
#set cmd$i "${prefix} $c$cmd_display$u" |
|
set cmd$i "${prefix} [punk::ansi::ansiwrap -rawansi $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 {::tcl::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] |
|
} |
|
|
|
variable has_textblock |
|
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] |
|
} |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::nslist |
|
@cmd -name punk::ns::nslist -help\ |
|
"Return a textual representation of |
|
the child namespaces and commands within |
|
the namespace(s) matched by glob." |
|
@opts |
|
-nspathcommands -type boolean -default 0 -help\ |
|
"When a namespace has entries configured in 'namespace path', the default result for nslist |
|
will display just a basic note: 'Also resolving cmds in namespace paths: <namespaces>'. |
|
If -nspathcommands is true, it will also display subtables showing the commands resolvable |
|
via any such listed namespaces." |
|
-types |
|
@values -min 0 -max -1 |
|
glob -multiple 1 -optional 1 -default "*" |
|
} |
|
proc nslist {args} { |
|
set argd [punk::args::parse $args withid ::punk::ns::nslist] |
|
lassign [dict values $argd] leaders opts values received solos multis |
|
|
|
#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 globlist [dict get $values glob] |
|
set with_results [list] |
|
foreach glob $globlist { |
|
set ns_absolute [uplevel 1 [list ::punk::ns::nspath_here_absolute $glob]] |
|
set ns_matches [get_ns_dicts $ns_absolute -nspathcommands $opt_nspathcommands] |
|
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 "" |
|
variable has_textblock |
|
foreach nsdict $with_results { |
|
set loc [dict get $nsdict location] |
|
set block [get_nslist -nsdict $nsdict -match ${loc}::* {*}$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]] (use n/// to display)" |
|
} else { |
|
append path_text \n " Also resolving cmds in namespace paths:" |
|
set nspathdict [dict get $nsdict namespacepath] |
|
if {!$has_textblock} { |
|
dict for {k v} $nspathdict { |
|
set cmds [dict get $v commands] |
|
append path_text \n " path: $k" |
|
append path_text \n " cmds: $cmds" |
|
} |
|
} else { |
|
#todo - change to display in column order - so as to be same as main command listing |
|
set parentcommands [dict get $nsdict commands] |
|
dict for {k v} $nspathdict { |
|
set rawpathcommands [dict get $v commands] |
|
set pathcommands [list] |
|
foreach c $rawpathcommands { |
|
if {$c in $parentcommands} { |
|
lappend pathcommands [punk::ansi::a strike]$c[a] |
|
} else { |
|
lappend pathcommands $c |
|
} |
|
} |
|
set columns 6 |
|
if {[llength $pathcommands] < 6} { |
|
set columns [llength $v] |
|
} |
|
set t [textblock::list_as_table -title $k -columns $columns [lsort $pathcommands]] |
|
append path_text \n $t |
|
} |
|
} |
|
} |
|
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] |
|
} |
|
|
|
#return a dict of info about keys and switches in a switch block |
|
#In particular we need the line-numbers from the raw scriptblock where each script begins and where each key begins. |
|
#(used to calculate line offsets in execution trace callbacks for debug display) |
|
#(for switch -form 1 - combined patterns and bodies in single argument) |
|
#test with: switchblock_scriptindex_line [string trim [info body test_switch]] <n> |
|
#note that "-" between keys is considered a scriptblock in this context |
|
#NOTE: in *nearly* every case - the script starts on the same line as the key |
|
|
|
|
|
variable switchblock_cache ;#review - when do we clear it? |
|
set switchblock_cache [dict create] |
|
proc switchblock_info {switchblock} { |
|
variable switchblock_cache |
|
set patternblock [lindex $switchblock end] |
|
if {[dict exists $switchblock_cache $patternblock]} { |
|
return [dict get $switchblock_cache $patternblock] |
|
} |
|
#eg for: |
|
#switch <opts> -- $val {...} |
|
#(where newlines may be present in ...) |
|
#return only the lines in ... |
|
set lines [split $patternblock \n] |
|
set scriptline 0 |
|
set current_scriptindex 0 |
|
set keys [list] |
|
set key "" |
|
set scriptblock "" |
|
set scripts [list] |
|
set in_script 0 |
|
set linenum 0 |
|
set index_to_linenums [dict create] |
|
foreach ln $lines { |
|
incr linenum |
|
set chars [split $ln ""] |
|
set cidx 0 |
|
foreach ch $chars { |
|
incr cidx ;#1-based |
|
if {!$in_script} { |
|
if {$key eq ""} { |
|
if {![string is space $ch]} { |
|
append key $ch |
|
#add the linenum info before key is ready |
|
dict set index_to_linenums [llength $keys] [dict create k $linenum s ""] |
|
if {[info complete $key] && $cidx == [llength $chars]} { |
|
#complete key at end of line |
|
append key \n |
|
lappend keys $key |
|
set key "" |
|
set in_script 1 |
|
} |
|
} |
|
} else { |
|
if {![info complete $key]} { |
|
append key $ch |
|
} else { |
|
if {[string is space $ch]} { |
|
lappend keys $key |
|
set key "" |
|
set in_script 1 |
|
} else { |
|
append key $ch |
|
if {$cidx == [llength $chars]} { |
|
lappend keys $key |
|
set key "" |
|
set in_script 1 |
|
} |
|
} |
|
} |
|
} |
|
} else { |
|
if {$scriptblock eq ""} { |
|
if {![string is space $ch]} { |
|
#start of script - record linenumber |
|
set idx [expr {[llength $keys]-1}] |
|
set lineinfo [dict get $index_to_linenums $idx] ;#entry already created by key |
|
dict set lineinfo s $linenum |
|
dict set index_to_linenums $idx $lineinfo ;#updated so now has linenums for both k and s |
|
append scriptblock $ch |
|
} |
|
} else { |
|
if {![info complete $scriptblock]} { |
|
append scriptblock $ch |
|
} else { |
|
if {[string is space $ch]} { |
|
|
|
lappend scripts $scriptblock |
|
set scriptblock "" |
|
set in_script 0 |
|
} else { |
|
append scriptblock $ch |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
if {[llength $keys] != [llength $scripts]} { |
|
error "switchblock_info failed to parse patternblock [llength keys] keys vs [llength $scripts] scripts\npatternblock:\n$patternblock" |
|
} |
|
|
|
set result [list keys $keys scripts $scripts lineinfo $index_to_linenums] |
|
dict set switchblock_cache $patternblock $result |
|
return $result |
|
} |
|
proc test_switch {s} { |
|
switch -- $s { x {return x} |
|
a - b { |
|
return AB |
|
} |
|
c - d - |
|
e { |
|
#line number effect of this comment? |
|
set result CDE |
|
return $result |
|
} |
|
f - g\ |
|
- h { |
|
return FGH |
|
} i - j - k {return IJK} l - m - n { |
|
set result LMN |
|
#test |
|
return $result |
|
} |
|
o - |
|
p - q |
|
{return OPQ} |
|
"quirk |
|
y" {return quirkykeyscript} |
|
default { |
|
return default |
|
} |
|
} |
|
} |
|
proc test_switch2 {s} { |
|
switch -- [string index $s 0] { |
|
a { |
|
switch -- [string index $s 1] { |
|
1 { |
|
return a1 |
|
} |
|
2 { |
|
#etc |
|
#blah |
|
set msg "test" |
|
return "a2_$msg" |
|
} |
|
3 { |
|
set slen [string length $s] |
|
switch -- $slen { |
|
1 { |
|
return a3-1 |
|
} |
|
2 { |
|
return a3-2 |
|
} |
|
default { |
|
return a3-more |
|
} |
|
} |
|
} |
|
default { |
|
return a[string index $s 1]-default |
|
} |
|
} |
|
} |
|
b { |
|
if {[string length $s] == 1} { |
|
return b-1 |
|
} elseif {[string length $s] == 2} { |
|
return b-2 |
|
} else { |
|
return b-more |
|
} |
|
} |
|
default { |
|
return default |
|
} |
|
} |
|
} |
|
proc test_switch3 {s} { |
|
switch -- [string index $s 0] { |
|
a { |
|
switch -- [string index $s 1] { |
|
1 { |
|
call_frame |
|
return a1 |
|
} |
|
2 { |
|
call_frame |
|
return a2 |
|
} |
|
3 { |
|
set c3 [string index $s 2] |
|
# |
|
# |
|
switch -- $c3 { |
|
1 { |
|
call_frame |
|
return a31 |
|
} |
|
2 { |
|
call_frame |
|
return a32 |
|
} |
|
3 { |
|
call_frame |
|
return a33 |
|
} |
|
4 { |
|
#test |
|
call_frame |
|
#etc |
|
call_frame |
|
return a34 |
|
} |
|
default { |
|
call_frame |
|
return a3-default |
|
} |
|
} |
|
} |
|
4 { |
|
#etc |
|
#blah |
|
call_frame |
|
#return a2 |
|
return a4 |
|
} |
|
default { |
|
call_frame |
|
return a[string index $s 1]-default |
|
} |
|
} |
|
} |
|
b { |
|
if {[string length $s] == 1} { |
|
call_frame |
|
return b-1 |
|
} elseif {[string length $s] == 2} { |
|
call_frame |
|
return b-2 |
|
} else { |
|
call_frame |
|
return b-more |
|
} |
|
} |
|
c { |
|
#test |
|
call_frame |
|
return c |
|
} |
|
d { |
|
call_frame |
|
return d |
|
} |
|
default { |
|
return default |
|
} |
|
} |
|
} |
|
|
|
#2 arg form of nested switch - no problem with line-numbers for first 2 arms |
|
proc test_switch4 {s} { |
|
switch [string index $s 0] { |
|
a { |
|
set ch2 [string index $s 1] |
|
switch $ch2 { |
|
x { |
|
call_frame |
|
return ax |
|
} |
|
y { |
|
call_frame |
|
return ay |
|
} |
|
z { |
|
call_frame |
|
return az |
|
} |
|
a { |
|
call_frame |
|
return aa |
|
} |
|
b { |
|
call_frame |
|
return ab |
|
} |
|
default { |
|
call_frame |
|
return a_ |
|
} |
|
} |
|
} |
|
} |
|
} |
|
#3 arg form of nested switch - first 2 arms misreport line numbers |
|
proc test_switch4b {s} { |
|
switch -- [string index $s 0] { |
|
a { |
|
set ch2 [string index $s 1] |
|
switch -- $ch2 { |
|
x { |
|
call_frame |
|
return ax |
|
} |
|
y { |
|
call_frame |
|
return ay |
|
} |
|
z { |
|
call_frame |
|
return az |
|
} |
|
a { |
|
call_frame |
|
return aa |
|
} |
|
b { |
|
call_frame |
|
return ab |
|
} |
|
default { |
|
call_frame |
|
return a_ |
|
} |
|
} |
|
} |
|
} |
|
} |
|
proc test_switch4c {s} { |
|
set ch1 [string index $s 0] |
|
set ch2 [string index $s 1] |
|
switch -- $ch1 { |
|
a { |
|
switch -- $ch2 { |
|
x { |
|
call_frame |
|
return ax |
|
} |
|
y { |
|
call_frame |
|
return ay |
|
} |
|
z { |
|
call_frame |
|
return az |
|
} |
|
a { |
|
call_frame |
|
return aa |
|
} |
|
b { |
|
call_frame |
|
return ab |
|
} |
|
default { |
|
call_frame |
|
return a_ |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
proc test_switch4d {s} { |
|
switch -exact [string index $s 0] { |
|
a { |
|
switch -exact [string index $s 1] { |
|
a { |
|
return aa |
|
} |
|
b { |
|
return ab |
|
} |
|
c { |
|
return ac |
|
} |
|
default { |
|
return a-default |
|
} |
|
} |
|
} |
|
b { |
|
switch -exact [string index $s 1] { |
|
a { |
|
return ba |
|
} |
|
b { |
|
switch -exact [string index $s 2] { |
|
a { |
|
return bba |
|
} |
|
b { |
|
return bbb |
|
} |
|
c { |
|
return bbc |
|
} |
|
default { |
|
return bb-default |
|
} |
|
} |
|
} |
|
c { |
|
return bc |
|
} |
|
default { |
|
return b-default |
|
} |
|
} |
|
} |
|
c { |
|
switch -exact [string index $s 1] { |
|
a { |
|
switch -exact [string index $s 2] { |
|
a { |
|
return caa |
|
} |
|
b { |
|
return cab |
|
} |
|
c { |
|
return cac |
|
} |
|
default { |
|
return ca-default |
|
} |
|
} |
|
|
|
} |
|
b { |
|
return cb |
|
} |
|
c { |
|
switch -exact [string index $s 2] { |
|
a { |
|
return cca |
|
} |
|
b { |
|
return ccb |
|
} |
|
c { |
|
return ccc |
|
} |
|
default { |
|
return cc-default |
|
} |
|
} |
|
} |
|
default { |
|
return c-default |
|
} |
|
} |
|
} |
|
} |
|
} |
|
proc test_switch5 {s} { |
|
set ch1 [string index $s 0] |
|
switch -- $ch1 { |
|
x { |
|
return ax |
|
} |
|
y { |
|
return ay |
|
} |
|
z { |
|
return az |
|
} |
|
a { |
|
return aa |
|
} |
|
b { |
|
return ab |
|
} |
|
default { |
|
return a_ |
|
} |
|
} |
|
} |
|
|
|
variable tinfo |
|
proc _cmdtrace_enter {vname target args} { |
|
variable _cmdtrace_disabled |
|
if {$_cmdtrace_disabled} return |
|
|
|
variable tinfo |
|
#----------------------------------------------------------------------------------------------------------------- |
|
#traces are still in place at this point for $target - but according to trace documentation are disabled |
|
# (they still show in 'trace info execution $target' output) |
|
#NOTE however that traces for other targets will still run on anything we do here. |
|
#We don't seem to be able to stop the callbacks - but we can flag with _cmdtrace_disabled until were done here. |
|
#--------------------------------------------------- |
|
#Note that in an environment with channel transforms - even a basic puts to stderr/stdout may invoke a slew of commands |
|
#--------------------------------------------------- |
|
set _cmdtrace_disabled true |
|
#----------------------------------------------------------------------------------------------------------------- |
|
|
|
tcl::dict::set tinfo($target) firstline -1 |
|
tcl::dict::set tinfo($target) procoffset 0 |
|
tcl::dict::set tinfo($target) level [expr {[::tcl::info::level]+1}] |
|
tcl::dict::set tinfo($target) subcmds 0 |
|
puts "enter: $target -- $args" |
|
puts "frame-2: [::tcl::info::frame -2]" |
|
|
|
set _cmdtrace_disabled false |
|
} |
|
proc _cmdtrace_leave {vname target args} { |
|
|
|
variable _cmdtrace_disabled |
|
if {$_cmdtrace_disabled} return |
|
#----------------------------------------------------------------------------------------------------------------- |
|
#traces are still in place at this point for $target - but according to trace documentation are disabled |
|
# (they still show in 'trace info execution $target' output) |
|
#NOTE however that traces for other targets will still run on anything we do here. |
|
#We don't seem to be able to stop the callbacks - but we can flag with _cmdtrace_disabled until were done here. |
|
#puts "-----------" |
|
#puts [trace info execution $target] |
|
#puts "-----------" |
|
set _cmdtrace_disabled true |
|
#----------------------------------------------------------------------------------------------------------------- |
|
|
|
|
|
#variable tinfo |
|
upvar $vname linedict |
|
|
|
lassign $args commandstring code result op |
|
if {$code == 0} { |
|
::dictn::incr linedict [list $target successcalls] 1 |
|
} else { |
|
::dictn::incr linedict [list $target errorcalls] 1 |
|
} |
|
|
|
puts stdout "leaving $target" |
|
puts stdout "call $commandstring\x1b\[m" |
|
puts stdout "result:" |
|
puts stdout $result |
|
puts stdout \x1b\[m ;#result may leave terminal with ansi SGR attributes in effect - emit a reset |
|
|
|
set cmdtype [dict get $linedict $target cmdtype] |
|
if {$cmdtype eq "proc"} { |
|
set procbody [punk::ns::corp -n $target] ;#may commonly be repeated in a cmdtrace operation - cache? |
|
|
|
dict for {k v} [dict get $linedict $target lines] { |
|
set t [dict get $v type] |
|
set c [dict get $v calls] |
|
switch -- $t { |
|
proc - eval { |
|
set procbody [grepstr -r a -highlight {red bold underline} "^\\s*${k}\\s+" $procbody] |
|
} |
|
source { |
|
set procbody [grepstr -r a -highlight {yellow bold underline} "^\\s*${k}\\s+" $procbody] |
|
puts stderr "source $k" |
|
} |
|
default { |
|
#set procbody [grepstr -r a -highlight {cyan bold underline} "^\\s*${k}\\s+" $procbody] |
|
puts stderr "$t $k" |
|
} |
|
} |
|
} |
|
puts stdout $procbody |
|
punk::lib::askuser "paused - hit enter key to continue" |
|
puts stdout "continuing..." |
|
} |
|
|
|
set _cmdtrace_disabled false |
|
} |
|
proc dkf_enterstep {vname target args} { |
|
#dkf sample on wiki |
|
variable tinfo |
|
variable _cmdtrace_disabled |
|
if {$_cmdtrace_disabled} return |
|
|
|
#only trace top level steps in the proc |
|
if {[info level] == [dict get $tinfo($target) level]} { |
|
if {[dict get $tinfo($target) firstline] < 0} { |
|
# make line numbers relative to the start of the proc rather than the file |
|
set finfo [info frame -4] |
|
set firstline [dict get $finfo line] |
|
dict set tinfo($target) firstline $firstline |
|
} |
|
dkf_DumpFrame $target -3 |
|
} |
|
} |
|
proc dkf_DumpFrame {procname frame} { |
|
variable tinfo |
|
set d [info frame [expr {$frame -1}]] |
|
if {![dict exists $d proc]} { |
|
return |
|
} |
|
# This test prevents tracing of stuff uplevelled from called procs |
|
if {"[dict get $d proc]" ne "$procname"} { |
|
return |
|
} |
|
set cmd [dict get $d cmd] |
|
# limit output to one line |
|
set nl [string first "\n" $cmd] |
|
if {$nl >= 0} { |
|
set cmd [string range $cmd 0 $nl-1]... |
|
} |
|
# calculate proc line number rather than file line number |
|
set procline [expr {[dict get $d line] - [dict get $tinfo($procname) firstline] + 1}] |
|
puts stdout "TRACE $procname line $procline $cmd" |
|
# by performing a vwait at this point you can easily implement single stepping etc |
|
#vwait ::step |
|
} |
|
|
|
proc _cmdtrace_get_eval_offset {cmdlist} { |
|
set eval_offset "default" ;#we need to detect default vs having been set to 1 (which happens to be the default) |
|
#cmdlist has already been 'expanded' by Tcl |
|
#so we don't get things like {switch -$matchtype [lindex $args 0] {....}} |
|
|
|
set cmd_firstword [lindex $cmdlist 0] |
|
switch -- $cmd_firstword { |
|
"switch" { |
|
puts "found a switch" |
|
set cmd_args [lrange $cmdlist 1 end] |
|
|
|
#review - why do we punk::args::parse it for form 1? 2nd last in cmdlist is string to match, last element in cmdlist is patternbody block (curly wrapped) |
|
if {![catch {punk::args::parse $cmd_args -cache 1 -form 1 withid ::switch} parseresult]} { |
|
#determine which switch arm any following 'eval' callbacks will belong to. |
|
#puts ">>> $parseresult" |
|
set patterndict [dict get $parseresult values {{pattern body ?pattern body?...}}] ;#review - fragile name in punk::args::define script for ::switch? |
|
#set patterndict [lindex $cmdlist end 0] ? |
|
#set switchstring [dict get $parseresult values string] ;#string being matched |
|
#match using same flags as original switch statement |
|
#we just need the index of which arm matches - then we can use switchblock_info to determine the right line within the raw switch body |
|
set testswitch [lrange $cmdlist 0 end-1] ;# switch <opts> -- <switchstring> |
|
set testbody [list] |
|
set idx -1 |
|
dict for {k v} $patterndict { |
|
incr idx |
|
lappend testbody $k "expr $idx" |
|
} |
|
lappend testswitch $testbody |
|
#puts stderr "--------------" |
|
puts stderr $testswitch |
|
#puts stderr "--------------" |
|
if {[catch { |
|
set switch_arm_index [eval $testswitch] |
|
} errM]} { |
|
puts stderr "testswitch error: $errM" |
|
} else { |
|
puts stderr "switch arm $switch_arm_index" |
|
#Tcl switch doesn't have to have a default case, so our testswitch can legitimately produce an empty |
|
#result when no arms matched |
|
if {$switch_arm_index ne ""} { |
|
set ts_start [clock millis] |
|
set switchinfo [punk::ns::switchblock_info $cmdlist] |
|
set ts_now [clock millis] |
|
puts stderr "switchblock_info gathered in [expr {$ts_now - $ts_start}] ms" |
|
#puts stderr $switchinfo |
|
|
|
set keys [dict get $switchinfo keys] |
|
set scripts [dict get $switchinfo scripts] |
|
set numkeys [llength $keys] |
|
set lineinfo [dict get $switchinfo lineinfo] |
|
set script_start_line "" |
|
for {set kidx $switch_arm_index} {$kidx < $numkeys} {incr kidx} { |
|
set scr [lindex $scripts $kidx] |
|
if {$scr ne "-"} { |
|
set linedata [dict get $lineinfo $kidx] |
|
set script_start_line [dict get $linedata s] |
|
break |
|
} |
|
} |
|
puts stderr "script_start_line: $script_start_line" |
|
set eval_offset $script_start_line |
|
} |
|
} |
|
|
|
} else { |
|
puts stderr "_cmdtrace_get_eval_offset failed to parse switch statement (wrong form?)\n$parseresult" |
|
} |
|
} |
|
default { |
|
} |
|
} |
|
return $eval_offset |
|
} |
|
|
|
#set a (1-based) eval_offset for commands which generate subsequent enterstep trace callbacks of type 'eval' e.g switch statements |
|
proc _cmdtrace_get_eval_offset1 {cmd} { |
|
set eval_offset 1 ;#default |
|
|
|
#list operations not safe on cmd. eg {mycmd {*}$something} |
|
set endw1 [string wordend $cmd 0] |
|
set cmd_firstword [string range $cmd 0 $endw1-1] |
|
switch -- $cmd_firstword { |
|
"switch" { |
|
puts "found a switch" |
|
set cmd_string [string range $cmd $endw1 end] |
|
puts "--------->" |
|
puts $cmd_string |
|
puts "--------->" |
|
#scripts are of a form that hasn't been parsed into arguments. |
|
#ie Tcl hasn't expanded it, so we don't have a tcl list of arguments to punk::args::parse against the ::switch definition forms. |
|
#eg " -- [lindex $args 0] {....}" |
|
#eg " {*}[get opts] -- ${match} {....}" |
|
#eg " -[get matchtype] -- {....} |
|
#eg " -- $prefix$etc [get my switch body]" |
|
# |
|
#Even the switch body (for switch -form 1, combined pattern/script block) can't simply be retrieved as the last element in the script - especially not using list operations. |
|
# |
|
set scriptlist [punk::lib::tclscript_to_scriptlist $cmd_string] |
|
set cmd_args [lindex $scriptlist 0] ;#should only be one list in the list of lists |
|
#set a [concat {*}$cmd_args] ;#REVIEW - is this roundtrip fundamentally any different to the string? how? |
|
#puts stderr "------------------>" |
|
#puts stderr $a |
|
#puts stderr "------------------>" |
|
set alist [list] |
|
foreach a $cmd_args { |
|
lappend alist [lindex $a 0] |
|
} |
|
|
|
|
|
|
|
if {![catch {punk::args::parse $alist -cache 1 -form 1 withid ::switch} parseresult]} { |
|
#determine which switch arm any following 'eval' callbacks will belong to. |
|
puts ">>> $parseresult" |
|
set patterndict [dict get $parseresult values {{pattern body ?pattern body?...}}] ;#review - fragile name in punk::args::define script for ::switch? |
|
set switchstring [dict get $parseresult values string] ;#string being matched |
|
set string [uplevel 2 [list ::subst $switchstring]] |
|
#match using same flags as original switch statement |
|
#we just need the index of which arm matches - then we can use switchblock_info to determine the right line within the raw switch body |
|
set testswitch [list] |
|
#usually ok for a switch - but we shouldn't really treat $cmd directly as a list here either. review |
|
lappend testswitch {*}[lrange $cmd 0 end-2] ;# switch <opts> -- |
|
lappend testswitch $string |
|
set testbody [list] |
|
set idx -1 |
|
dict for {k v} $patterndict { |
|
incr idx |
|
lappend testbody $k "expr $idx" |
|
} |
|
lappend testswitch $testbody |
|
#puts stderr "--------------" |
|
puts stderr $testswitch |
|
#puts stderr "--------------" |
|
if {[catch { |
|
set switch_arm_index [eval $testswitch] |
|
} errM]} { |
|
puts stderr "testswitch error: $errM" |
|
} else { |
|
puts stderr "switch arm $switch_arm_index" |
|
#Tcl switch doesn't have to have a default case, so our testswitch can legitimately produce an empty |
|
#result when no arms matched |
|
if {$switch_arm_index ne ""} { |
|
set switchinfo [punk::ns::switchblock_info $cmd] |
|
puts stderr $switchinfo |
|
|
|
set keys [dict get $switchinfo keys] |
|
set scripts [dict get $switchinfo scripts] |
|
set numkeys [llength $keys] |
|
set lineinfo [dict get $switchinfo lineinfo] |
|
set script_start_line "" |
|
for {set kidx $switch_arm_index} {$kidx < $numkeys} {incr kidx} { |
|
set scr [lindex $scripts $kidx] |
|
if {$scr ne "-"} { |
|
set linedata [dict get $lineinfo $kidx] |
|
set script_start_line [dict get $linedata s] |
|
break |
|
} |
|
} |
|
puts stderr "script_start_line: $script_start_line" |
|
set eval_offset $script_start_line |
|
} |
|
} |
|
|
|
} else { |
|
puts stderr "_coverage_enterstep failed to parse switch statement (wrong form?)\n$parseresult" |
|
} |
|
} |
|
default { |
|
} |
|
} |
|
return $eval_offset |
|
} |
|
proc _cmdtrace_enterstep {vname target args} { |
|
#note: we get apparent duplicate callbacks when resolving ensembles. |
|
#e.g {string range $x 1 2} will result in enterstep callback being called twice |
|
#whereas {tcl::string::range $x 1 2} will only callback once |
|
#Unknown if this is a bug or a feature - it does give possible indication of minor overhead when using ensemble form (at least during trace operation) |
|
#(presumably there is no difference when byte compiled) |
|
|
|
#puts " --------------> $args <-----------" |
|
variable _cmdtrace_disabled |
|
if {$_cmdtrace_disabled} return |
|
|
|
variable tinfo |
|
if {[::tcl::info::level] != [::tcl::dict::get $tinfo($target) level]} { |
|
#There are often a *huge* number of subcalls. Can easily be millions, so even emitting a dot with nonewline can be overwhelming. |
|
#uncomment for debug on procs which don't have extensive subcalls. |
|
#puts -nonewline stdout . |
|
#puts -nonewline stderr " $args" |
|
::tcl::dict::incr tinfo($target) subcmds |
|
return |
|
} |
|
|
|
|
|
set callinfo [::tcl::info::frame -2] |
|
#call to _cmdtrace_enterstep at level -1 |
|
|
|
#----------------------------------------------------------------------------------------------------------------- |
|
#traces are still in place at this point for $target - but according to trace documentation are disabled |
|
# (they still show in 'trace info execution $target' output) |
|
#NOTE however that traces for other targets will still run on anything we do here. |
|
#We don't seem to be able to stop the callbacks - but we can flag with _cmdtrace_disabled until were done here. |
|
#--------------------------------------------------- |
|
#Note that in an environment with channel transforms - even a basic puts to stderr/stdout may invoke a slew of commands |
|
#--------------------------------------------------- |
|
set _cmdtrace_disabled true |
|
#----------------------------------------------------------------------------------------------------------------- |
|
#make sure to re-enable at each return point |
|
|
|
|
|
set type [::tcl::dict::get $callinfo type] |
|
if {[dict exists $callinfo proc]} { |
|
upvar $vname linedict |
|
if {[dict get $callinfo proc] eq $target} { |
|
set prevline [dict get $linedict $target eval_base] |
|
if {[catch { |
|
set traceline [dict get $callinfo line] |
|
}]} { |
|
#eg cmd {tcl::mathfunc::sqrt 100} |
|
puts "No line info for call: $callinfo" |
|
set _cmdtrace_disabled false |
|
return |
|
} |
|
switch -- $type { |
|
proc { |
|
set line $traceline |
|
dict set linedict $target eval_base $traceline |
|
dict set linedict $target eval_offset 1 |
|
puts " step type: proc traceline:$traceline ** $args" |
|
#puts "** $callinfo" |
|
if {[dict exists $callinfo cmd]} { |
|
#set cmd [string trim [dict get $callinfo cmd]] ;#raw 'unexpanded' script from the stack frame |
|
set cmdlist [lindex $args 0] ;#Tcl has parsed the script - expanded form should be a proper list |
|
#dict set linedict $target eval_offset [_cmdtrace_get_eval_offset $cmdlist] |
|
set getoffset [_cmdtrace_get_eval_offset $cmdlist] |
|
if {$getoffset eq "default"} { |
|
set getoffset 1 |
|
} |
|
dict set linedict $target eval_offset $getoffset |
|
} |
|
} |
|
eval { |
|
#Note that trace considers line 1 for any block to be where the first command is found. |
|
#ie *leading* empty lines/comment lines are not counted |
|
#This contrasts with the output of punk::ns::corp - which counts them. |
|
|
|
#eval_base has been set by previous source or proc |
|
#It can also be set by previous eval - *if* a non default offset was returned by _cmdtrace_get_eval_offset |
|
set eval_offset [dict get $linedict $target eval_offset] |
|
set line [expr {$prevline + ($eval_offset-1) + ($traceline-1)}] |
|
#puts "stack-- $callinfo" |
|
puts " step type: eval traceline: $traceline -- " |
|
if {[dict exists $callinfo cmd]} { |
|
#set cmd [string trim [dict get $callinfo cmd]] |
|
set cmdlist [lindex $args 0] |
|
#dict set linedict $target eval_offset [_cmdtrace_get_eval_offset $cmdlist] |
|
set getoffset [_cmdtrace_get_eval_offset $cmdlist] |
|
if {$getoffset ne "default"} { |
|
dict set linedict $target eval_base [expr {$line}] |
|
dict set linedict $target eval_offset [expr {$getoffset}] |
|
puts "-> line:$line new eval_base: [dict get $linedict $target eval_base] new eval_offset [dict get $linedict $target eval_offset]" |
|
} |
|
} |
|
} |
|
source { |
|
#REVIEW - line continuations in source files make this approach problematic! |
|
if {[dict get $tinfo($target) firstline] < 0} { |
|
# make line numbers relative to the start of the proc rather than the file |
|
|
|
#NOTE - the type key is source, the file key is the sourced file, and |
|
# the line key is the line of the first command, |
|
# *not* the first line in the proc! (this means leading comments, empty lines |
|
# will make this line inaccurate as a relative staring point for proc lines. |
|
|
|
#also - source file can have line continuations - which are never reflected in |
|
#info body <proc> |
|
#we have to build some sort of logical line map the first time we see the file |
|
|
|
|
|
dict set tinfo($target) firstline $traceline |
|
set ns [punk::ns::nsprefix $target] |
|
set nscmd [punk::ns::nstail $target] |
|
set pbody [::tcl::namespace::eval $ns [list ::tcl::info::body $nscmd]] |
|
set offset 0 |
|
foreach ln [split $pbody \n] { |
|
incr offset 1 |
|
set ln [string trim $ln] |
|
if {$ln ne "" && [string index $ln 0] ne "#"} { |
|
#assume it's a command - review (what about line continuations in comments in source file?) |
|
break |
|
} |
|
} |
|
dict set tinfo($target) procoffset $offset |
|
} |
|
set line [expr {$traceline - [dict get $tinfo($target) firstline] + [dict get $tinfo($target) procoffset]}] |
|
#set line $traceline |
|
#puts "--line:$line firstline:[dict get $tinfo($target) firstline] poffset:[dict get $tinfo($target) procoffset] $callinfo" |
|
puts " step type: src traceline $traceline line:$line firstline:[dict get $tinfo($target) firstline] poffset:[dict get $tinfo($target) procoffset]" |
|
dict set linedict $target eval_base $line |
|
} |
|
precompiled { |
|
set line $traceline |
|
puts stderr " step type: PRECOMPILED -- $callinfo" |
|
} |
|
default { |
|
#As at tcl9 - there shouldn't be any unknown types and this branch shouldn't be reached. |
|
set line $traceline |
|
puts stderr " step: $type (unexpected) line:$traceline -- $callinfo" |
|
} |
|
} |
|
|
|
if {![dict exists $linedict $target lines $line]} { |
|
dict set linedict $target lines $line [list type $type calls 1] |
|
} else { |
|
set update [dict get $linedict $target lines $line] |
|
dict incr update calls |
|
dict set linedict $target lines $line $update |
|
} |
|
#puts "-- $callinfo" |
|
} else { |
|
puts ">>step type: $type (nontargeted proc)>> $callinfo" |
|
} |
|
} else { |
|
#todo - handle type 'source' and type 'eval' with keys 'method' 'class' (oo) |
|
#puts ------------------------- |
|
#puts ">[dict get $callinfo cmd]" |
|
#puts "enter type: $type -- $callinfo" |
|
} |
|
set _cmdtrace_disabled false |
|
} |
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::ns::cmdtrace |
|
@cmd -name punk::ns::cmdtrace\ |
|
-summary\ |
|
"Trace command execution."\ |
|
-help\ |
|
"Experimental. |
|
Note that line-continuations in source file |
|
proc definition will make traced line numbers |
|
inaccurate. |
|
Redefine the proc using something like: |
|
|
|
rename procname procname_old |
|
proc procname {args} [info body procname_old] |
|
|
|
and then run the cmdtrace for better results. |
|
|
|
Nested switch statements - traced linenumbers |
|
are dubious when *not* referencing source file. |
|
(inconsistently based on start-of-switch vs |
|
start-of-switcharm script) |
|
Possibly an unreported/unacknowleged |
|
bug in Tcl. |
|
" |
|
@opts |
|
-target -type string -multiple 1 -help\ |
|
"" |
|
-- -type none -help\ |
|
"end of options indicator" |
|
@values -min 1 -max -1 |
|
arg -type any -multiple 1 -optional 0 -help\ |
|
"Elements of cmdline to run. |
|
If no -target values are supplied, |
|
This will also be the target of the |
|
trace." |
|
|
|
}] |
|
} |
|
proc cmdtrace {args} { |
|
package require dictn ;#convenience to allow dictn::incr d {key subkey} |
|
variable tinfo |
|
array unset tinfo |
|
variable _cmdtrace_disabled |
|
set _cmdtrace_disabled false |
|
|
|
set argd [punk::args::parse $args -cache 1 withid ::punk::ns::cmdtrace] |
|
lassign [dict values $argd] leaders opts values received |
|
|
|
set cmdargs [dict get $values arg] |
|
|
|
set cinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdargs]] |
|
set origin [dict get $cinfo origin] |
|
set arglist [dict get $cinfo args_remaining] |
|
|
|
if {[dict exists $received -target]} { |
|
set targets [dict get $opts -target] |
|
} else { |
|
set targets [list $origin] |
|
} |
|
|
|
upvar ::punk::ns::linedict linedict |
|
set ::punk::ns::linedict [::tcl::dict::create] |
|
|
|
set resolved_targets [list] |
|
foreach tgt $targets { |
|
set tgt_info [uplevel 1 [list ::punk::ns::cmdinfo {*}$tgt]] |
|
set tgt_cmd [dict get $tgt_info origin] |
|
set tgt_type [dict get $tgt_info cmdtype] |
|
set tgt_remaining [dict get $tgt_info args_remaining] |
|
if {[llength $tgt_remaining]} { |
|
if {[dict exists $received -target]} { |
|
error "cmdtrace unable to resolve all parts of given target: '$tgt' to a single command to trace" |
|
} |
|
#don't raise the error when no -target supplied - as our launch command can contain extra arguments |
|
} |
|
lappend resolved_targets $tgt_cmd |
|
::tcl::dict::set ::punk::ns::linedict $tgt_cmd [::tcl::dict::create eval_base 1 eval_offset 1 lines {} cmdtype $tgt_type successcalls 0 errorcalls 0] |
|
} |
|
|
|
#if the target command has a leading colon (e.g expr alternative :) we can't put a trace directly on a fully qualified name with a triple colon such as ::: |
|
#we will need to evaluate in the namespace |
|
foreach tgt_cmd $resolved_targets { |
|
set nscmd [nstail $tgt_cmd] |
|
set ns [nsprefix $tgt_cmd] |
|
puts "tracing target: $tgt_cmd whilst running: $origin $arglist" |
|
|
|
::tcl::namespace::eval $ns [list ::trace add execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] |
|
::tcl::namespace::eval $ns [list ::trace add execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] |
|
::tcl::namespace::eval $ns [list ::trace add execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] |
|
} |
|
|
|
|
|
try { |
|
set origin_nscmd [nstail $origin] |
|
set origin_ns [nsprefix $origin] |
|
#uplevel 1 [list $origin {*}$arglist] |
|
::tcl::namespace::eval $origin_ns [list $origin_nscmd {*}$arglist] |
|
} trap {} {errMsg errOptions} { |
|
puts stderr "command error $errMsg" |
|
|
|
} finally { |
|
foreach tgt_cmd $resolved_targets { |
|
set nscmd [nstail $tgt_cmd] |
|
set ns [nsprefix $tgt_cmd] |
|
::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enterstep [list ::punk::ns::_cmdtrace_enterstep ::punk::ns::linedict $tgt_cmd]] |
|
::tcl::namespace::eval $ns [list ::trace remove execution $nscmd enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $tgt_cmd]] |
|
::tcl::namespace::eval $ns [list ::trace remove execution $nscmd leave [list ::punk::ns::_cmdtrace_leave ::punk::ns::linedict $tgt_cmd]] |
|
} |
|
} |
|
|
|
set final_display "" |
|
append final_display [punk::lib::showdict [array get tinfo] */*] |
|
append final_display \n |
|
|
|
#todo - foreach tgt_cmd in resolved_targets? |
|
foreach tgt_cmd $resolved_targets { |
|
set lines [dict get $linedict $tgt_cmd lines] |
|
if {[llength $lines]} { |
|
set procbody [punk::ns::corp -n $tgt_cmd] |
|
dict for {k v} $lines { |
|
set t [dict get $v type] |
|
set c [dict get $v calls] |
|
switch -- $t { |
|
proc - eval { |
|
set procbody [grepstr -r a -highlight {red bold underline} "^\\s*${k}\\s+" $procbody] |
|
} |
|
source { |
|
set procbody [grepstr -r a -highlight {yellow bold underline} "^\\s*${k}\\s+" $procbody] |
|
#puts stderr "source $k" |
|
} |
|
default { |
|
#set procbody [grepstr -r a -highlight {cyan bold underline} "^\\s*${k}\\s+" $procbody] |
|
puts stderr "$t $k" |
|
} |
|
} |
|
} |
|
append final_display $procbody \n |
|
} else { |
|
append final_display "No lines to display for $tgt_cmd" \n |
|
} |
|
append final_display "success_calls: [dict get $linedict $tgt_cmd successcalls]" \n |
|
append final_display "error_calls : [dict get $linedict $tgt_cmd errorcalls]" \n |
|
|
|
} |
|
return $final_display |
|
} |
|
proc cmdtracebasic {args} { |
|
variable tinfo |
|
variable _cmdtrace_disabled |
|
set _cmdtrace_disabled false |
|
|
|
set cinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$args]] |
|
set origin [dict get $cinfo origin] |
|
set arglist [dict get $cinfo args_remaining] |
|
trace add execution $origin enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $origin] |
|
trace add execution $origin enterstep [list ::punk::ns::dkf_enterstep ::punk::ns::linedict $origin] |
|
try { |
|
uplevel 1 [list $origin {*}$arglist] |
|
} trap {} {errMsg errOptions} { |
|
puts stderr "command error $errMsg" |
|
|
|
} finally { |
|
trace remove execution $origin enterstep [list ::punk::ns::dkf_enterstep ::punk::ns::linedict $origin] |
|
trace remove execution $origin enter [list ::punk::ns::_cmdtrace_enter ::punk::ns::linedict $origin] |
|
} |
|
parray tinfo |
|
} |
|
|
|
proc call_frame {} { |
|
puts stdout "\x1b\[93m[info frame -1]\x1b\[m" |
|
} |
|
proc Enterstep_return {target args} { |
|
set d [info frame -2] |
|
#puts $d |
|
if {[dict exists $d cmd]} { |
|
set c [dict get $d cmd] |
|
if {[string match "return *" $c]} { |
|
puts stdout $d |
|
puts stdout $args |
|
} |
|
} |
|
} |
|
proc cmdtracereturn {procname args} { |
|
trace add execution $procname enterstep [list ::punk::ns::Enterstep_return $procname] |
|
try { |
|
uplevel 1 [list $procname {*}$args] |
|
} trap {} {errMsg errOptions} { |
|
puts stderr "command: '$procname' error: $errMsg" |
|
|
|
} finally { |
|
trace remove execution $procname enterstep [list ::punk::ns::Enterstep_return $procname ] |
|
} |
|
} |
|
|
|
variable proc_tracers |
|
proc trace_disable1 {} { |
|
#determine all procs in the call stack above this one |
|
set depth [expr {(-1* [info frame])+1}] |
|
set procs [list] |
|
for {set i -2} {$i > $depth} {incr i -1} { |
|
set f [info frame $i] |
|
if {[dict exists $f proc]} { |
|
set p [dict get $f proc] |
|
if {$p ni $procs} { |
|
lappend procs $p |
|
} |
|
} |
|
} |
|
#puts "procs:------$procs" |
|
set mycaller [dict get [info frame -1] proc] |
|
|
|
variable proc_tracers |
|
dict set proc_tracers $mycaller [list] |
|
foreach procname $procs { |
|
set tracers [trace info execution $procname] |
|
if {[llength $tracers]} { |
|
dict lappend proc_tracers $mycaller [list $procname $tracers] ;#store for re-enabling later |
|
foreach t $tracers { |
|
trace remove execution $procname {*}$t |
|
} |
|
} |
|
} |
|
} |
|
proc trace_disable {} { |
|
#use the regexp {} [...] trick - only runs when non byte-compiled ie in traces |
|
regexp {} [ |
|
#determine all procs in the call stack above this one |
|
set depth [expr {(-1* [info frame])+1}] |
|
set procs [list] |
|
for {set i -2} {$i > $depth} {incr i -1} { |
|
set f [info frame $i] |
|
if {[dict exists $f proc]} { |
|
set p [dict get $f proc] |
|
if {$p ni $procs} { |
|
lappend procs $p |
|
} |
|
} |
|
} |
|
#puts "procs:------$procs" |
|
set mycaller [dict get [info frame -1] proc] |
|
|
|
variable proc_tracers |
|
dict set proc_tracers $mycaller [list] |
|
set removed_tracers [list] |
|
foreach procname $procs { |
|
set tracers [trace info execution $procname] |
|
if {[llength $tracers]} { |
|
#dict lappend proc_tracers $mycaller [list $procname $tracers] ;#store for re-enabling later |
|
set removed [list] |
|
foreach t $tracers { |
|
lassign $t op script |
|
if {$op eq "enterstep"} { |
|
trace remove execution $procname {*}$t |
|
lappend removed $t |
|
} |
|
} |
|
if {[llength $removed]} { |
|
#dict set proc_tracers $mycaller [list $procname $removed] |
|
lappend removed_tracers [list $procname $removed] |
|
} |
|
} |
|
} |
|
dict set proc_tracers $mycaller $removed_tracers |
|
] |
|
} |
|
proc trace_enable {} { |
|
#this must run when tracing off - as we use it after trace_disable |
|
set mycaller [dict get [info frame -1] proc] |
|
variable proc_tracers |
|
if {[dict exists $proc_tracers $mycaller]} { |
|
puts "tracers: $proc_tracers" |
|
set tracers [dict get $proc_tracers $mycaller] |
|
foreach tracegroup $tracers { |
|
lassign $tracegroup pname tlist |
|
foreach tinfo $tlist { |
|
puts "---> trace add execution $pname $tinfo" |
|
trace add execution $pname {*}$tinfo |
|
} |
|
} |
|
} |
|
} |
|
|
|
proc traced_func1 {} { |
|
trace_disable1 |
|
return "DON'T TRACE ME 1" |
|
} |
|
|
|
proc traced_func2 {} { |
|
trace_disable |
|
return "DON'T TRACE ME 2" |
|
} |
|
proc traced_func3 {} { |
|
trace_disable |
|
puts aaa |
|
trace_enable |
|
puts bbb |
|
return done |
|
} |
|
proc traced_outer {} { |
|
traced_func3 |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::cmdtype |
|
@cmd -name punk::ns::cmdtype -help\ |
|
"" |
|
@values -min 1 -max 1 |
|
cmd -help\ |
|
"namespace-relative or namespace-absolute path of command." |
|
} |
|
#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 [uplevel 1 [list ::tcl::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_cached $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]} { |
|
#hack - look for an alias that may have been specifically enabled to bring this back |
|
#review - why this name? |
|
if {[info commands ::info_cmdtype] ne ""} { |
|
return [namespace eval $where [list ::info_cmdtype $what]] |
|
} |
|
#fall-through to below |
|
} 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 { |
|
set tclcmdtype [nseval_ifexists $where [list ::tcl::info::cmdtype $what]] |
|
if {$tclcmdtype eq "object"} { |
|
if {[nseval_ifexists $where [list ::info object isa class $what]]} { |
|
set tclcmdtype ooclass |
|
} else { |
|
set tclcmdtype ooobject |
|
} |
|
} |
|
} |
|
} 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 { |
|
set tclcmdtype [namespace eval $where [list ::tcl::info::cmdtype $what]] |
|
if {$tclcmdtype eq "object"} { |
|
if {[namespace eval $where [list ::info object isa class $what]]} { |
|
set tclcmdtype ooclass |
|
} else { |
|
set tclcmdtype ooobject |
|
} |
|
} |
|
} |
|
} |
|
return $tclcmdtype |
|
} |
|
# CCC |
|
set locationparts [nsparts_cached $where] |
|
set weird_ns 0 |
|
set c "" |
|
if {[lsearch $locationparts :*] >= 0} { |
|
set weird_ns 1 |
|
} |
|
if {$weird_ns} { |
|
if {[nseval_ifexists $where [list ::info commands $what]] eq ""} { |
|
return notfound |
|
} |
|
} 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 |
|
} |
|
} |
|
if {$weird_ns} { |
|
set cmdorigin [nseval_ifexists $where [list ::namespace origin $what]] |
|
} else { |
|
set cmdorigin [namespace eval $where [list ::namespace origin $what]] |
|
} |
|
if {[nsprefix $cmdorigin] ne $where} { |
|
return import |
|
} |
|
if {$weird_ns} { |
|
set c [nseval_ifexists $where [list ::info commands $what]] |
|
} else { |
|
set c [tcl::namespace::eval $where [list ::info commands $what]] |
|
} |
|
if {$c ne ""} { |
|
#if {![catch {nseval_ifexists $origin_location [list ::namespace ensemble configure $cmd]} ensemble_info]} {} |
|
set script [string map [list %w% $what] { |
|
::if {![::catch [::list ::namespace ensemble configure "%w%"]]} { |
|
::return ensemble |
|
} elseif {[::info object isa class "%w%"]} { |
|
::return ooclass |
|
} elseif {[::info object isa object "%w%"]} { |
|
::return ooobject |
|
} |
|
}] |
|
if {$weird_ns} { |
|
set o [nseval_ifexists $where $script] |
|
} else { |
|
set o [tcl::namespace::eval $where $script] |
|
} |
|
if {$o ne ""} { |
|
return $o |
|
} |
|
} else { |
|
return notfound |
|
} |
|
if {$weird_ns} { |
|
set p [nseval_ifexists $where [list ::info procs $what]] |
|
} else { |
|
set p [tcl::namespace::eval $where [list ::info procs $what]] |
|
} |
|
if {$p ne ""} { |
|
return proc |
|
} |
|
|
|
#punk::ns::aliases last - as probably slowest |
|
if {$weird_ns} { |
|
set a [nseval_ifexists $where [list ::punk::ns::aliases $what]] |
|
} else { |
|
set a [tcl::namespace::eval $where [list ::punk::ns::aliases $what]] |
|
} |
|
if {$a ne ""} { |
|
return alias |
|
} |
|
|
|
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} { |
|
#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 |
|
} |
|
#puts stderr "---->get_ns_dicts '$fq_glob $args' update_definitions $report_namespaces" |
|
punk::args::update_definitions $report_namespaces |
|
|
|
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 -sort none $ch] ; #only returns 1 level deeper. leave sorting til after filtering |
|
} |
|
|
|
#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" |
|
} |
|
|
|
|
|
# CCC |
|
set location $ch |
|
set locationparts [nsparts_cached $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 namespace (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 ::punk::ns::aliases $glob]] ;#'aliases $glob' must be passed as list, not separate args to namespace eval. |
|
} else { |
|
set raw_aliases [tcl::namespace::eval $location [list ::punk::ns::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] |
|
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_cached $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 ::punk::ns::cmdtype $origin_cmd]] |
|
} else { |
|
set mixedtype i-[namespace eval $origin_location [list ::punk::ns::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 { |
|
#punk::ns::cmdtype will return ooobject or ooclass directly |
|
if {[info object isa object ${location}::$cmd]} { |
|
lappend allooobjects $cmd |
|
if {[info object isa class ${location}::$cmd]} { |
|
lappend allooclasses $cmd |
|
} |
|
} |
|
} |
|
i-ooobject - ooobject { |
|
lappend allooobjects $cmd |
|
} |
|
i-ooclass - ooclass { |
|
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]] |
|
# #} |
|
# set locparts [nsparts_cached $location] |
|
# if {[lsearch $locparts :*] >=0 || [string match :* $cmd]} { |
|
# set nsorigin [nseval $location [list 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] |
|
# ccc |
|
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 |
|
# ccc |
|
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} { |
|
set ns_updated [dict create] |
|
foreach c $commands { |
|
set found_documentation 0 |
|
#we first need to check if there is direct documentation for the command at this location, before diverting to examine the target of imports/aliases for docs |
|
if {$has_punkargs} { |
|
set id [nsjoin $location $c] |
|
set id_ns [namespace qualifiers $id] |
|
if {![dict exists $ns_updated $id_ns]} { |
|
punk::args::update_definitions [list $id_ns] |
|
dict set ns_updated $id_ns 1 |
|
} |
|
if {[::punk::args::id_exists $id]} { |
|
lappend usageinfo $c |
|
set found_documentation 1 |
|
} |
|
} |
|
|
|
|
|
if {!$found_documentation && $c in $aliases} { |
|
#could be an alias in $location, or an imported alias |
|
|
|
#TODO - use which_alias ? |
|
if {$c in $imported} { |
|
if {$weird_ns} { |
|
set fq [nseval $location [list namespace origin $c]] |
|
} else { |
|
set fq [namespace origin [nsjoin $location $c]] |
|
} |
|
} else { |
|
set fq [nsjoin $location $c] |
|
} |
|
|
|
set tgt [interp alias "" $fq] |
|
if {$tgt eq ""} { |
|
set tgt [interp alias "" [string trimleft $fq :]] |
|
} |
|
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 id [lindex $tgt end] ;#todo - explicitly get -extension argval in case _cli extended with other options |
|
} else { |
|
#todo - alias may have prefilled some leading args - so usage report should reflect that??? |
|
#(currying) |
|
if {[string match ::* $word1]} { |
|
set id $word1 |
|
} else { |
|
set id ::$word1 |
|
} |
|
} |
|
if {[::punk::args::id_exists $id]} { |
|
lappend usageinfo $c |
|
set found_documentation 1 |
|
} |
|
#todo - alias to an alias |
|
#e.g n/new jjj |
|
# interp alias "" ::jjj::corp2 "" ::corp |
|
#todo -pseudocode |
|
#cmdwhich id |
|
#while origin ne whichtype && origintype eq "alias" { |
|
# if id_exists $origin { |
|
# lappend usageinfo $c; set found_documentation 1 |
|
# break |
|
# } |
|
# cmdwhich id |
|
#} |
|
|
|
# CCC |
|
#or just use punk::ns::cmdinfo |
|
|
|
} else { |
|
#all non-alias |
|
if {!$found_documentation && $has_punkargs && $c in $imported} { |
|
if {$weird_ns} { |
|
set fq [nseval $location [list namespace origin $c]] |
|
} else { |
|
set fq [namespace origin [nsjoin $location $c]] |
|
} |
|
|
|
#set id [string trimleft $fq :] |
|
set id $fq |
|
set id_ns [namespace qualifiers $id] |
|
if {![dict exists $ns_updated $id_ns]} { |
|
#puts "===>get_ns_dicts: '$fq_glob $args' punk::args::update_definitions [list $id_ns]" |
|
punk::args::update_definitions [list $id_ns] |
|
dict set ns_updated $id_ns 1 |
|
} |
|
if {[::punk::args::id_exists $id]} { |
|
lappend usageinfo $c |
|
set found_documentation 1 |
|
} |
|
} |
|
} |
|
if {!$found_documentation && $has_tepam} { |
|
set fq [namespace origin [nsjoin $location $c]] |
|
if {$fq in $::tepam::ProcedureList} { |
|
lappend usageinfo $c |
|
} |
|
} |
|
|
|
} |
|
} |
|
#catch {package require natsort} |
|
#if {[package provide natsort] ne ""} { |
|
# set childtailmatches [natsort::sort $childtailmatches] |
|
#} else { |
|
# set childtailmatches [lsort $childtailmatches] |
|
#} |
|
set childtailmatches [lsort -dictionary $childtailmatches] |
|
|
|
set nsdict [dict create\ |
|
location $location\ |
|
children $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| |
|
|
|
|
|
|
|
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::define { |
|
@id -id ::punk::ns::ensemble_subcommands |
|
@cmd -name punk::ns::ensemble_subcommands -help\ |
|
"Returns a dictionary keyed on subcommand with each value pointing |
|
to the implementation command. |
|
|
|
This is not guaranteed to be complete - e.g for ensembles which use |
|
the namespace ensemble 'unknown' mechanism to implement subcommands. |
|
|
|
The subcommand information is gathered from entries in the '-map' as |
|
well as those exported from the namespace in '-namespace' if the |
|
'-subcommands' list has been configured for the ensemble. |
|
" |
|
-return -default dict -choices {show dict} -choicelabels { |
|
show "display the result in 'showdict' format" |
|
} |
|
@values -min 1 -max 1 |
|
origin -help\ |
|
"Name of ensemble command for which subcommand info is gathered." |
|
} |
|
proc ensemble_subcommands {args} { |
|
#puts stderr "---> punk::ns::ensemble_subcommands $args" |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::ns::ensemble_subcommands] |
|
set opts [dict get $argd opts] |
|
set origin [dict get $argd values origin] |
|
|
|
set ensembleinfo [uplevel 1 [list ::tcl::namespace::ensemble configure $origin]] |
|
set prefixes [dict get $ensembleinfo -prefixes] |
|
set map [dict get $ensembleinfo -map] |
|
set ns [dict get $ensembleinfo -namespace] |
|
set unkhandler [dict get $ensembleinfo -unknown] |
|
|
|
#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 ns_commands [list] |
|
if {[llength [dict get $ensembleinfo -subcommands]]} { |
|
#set exportspecs [namespace eval $ns {namespace export}] |
|
#foreach pat $exportspecs { |
|
# lappend ns_commands {*}[info commands ${ns}::$pat] |
|
#} |
|
#when using -subcommands, even unexported commands are available |
|
set ns_commands [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 $ns_commands} { |
|
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 ns_commands {*}[info commands ${ns}::$pat] |
|
} |
|
foreach fqc $ns_commands { |
|
dict set subcommand_dict [namespace tail $fqc] $fqc |
|
} |
|
} |
|
} |
|
if {[dict get $opts -return] eq "dict"} { |
|
return $subcommand_dict |
|
} else { |
|
return [punk::lib::showdict $subcommand_dict] |
|
} |
|
} |
|
|
|
proc nscommands {args} { |
|
set commandns [uplevel 1 [list ::tcl::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 ::tcl::info::commands]] |
|
set _matches [list] |
|
foreach _a $_all { |
|
set _c [uplevel 1 [list ::tcl::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 |
|
proc nscommandlist {{ns *}} { |
|
set nsparts [nsparts_cached $ns] |
|
set tail [lindex $nsparts end] |
|
if {[string match ::* $ns]} { |
|
if {[regexp {\*} $tail]} { |
|
set targetns [nsprefix $ns] |
|
set search $tail |
|
} else { |
|
set targetns $ns |
|
set search * |
|
} |
|
} else { |
|
set nscaller [uplevel 1 [list ::tcl::namespace::current]] |
|
if {[regexp {\*} $tail]} { |
|
if {[nsprefix $ns] ne ""} { |
|
set targetns [nsjoin $nscaller [nsprefix $ns]] |
|
} else { |
|
set targetns $nscaller |
|
} |
|
set search $tail |
|
} else { |
|
set targetns [nsjoin $nscaller $ns] |
|
set search * |
|
} |
|
} |
|
|
|
if {![string match "*:::*" $targetns]} { |
|
#ordinary namespace path - can use standard info commands with glob |
|
set all_cmds [info commands [::punk::ns::nsjoin $targetns $search]] |
|
set all_cmds [lmap v $all_cmds {namespace tail $v}] |
|
return [lsort $all_cmds] |
|
} else { |
|
# 'unwisely' named ns: cannot rely on 'info commands <nspattern>' |
|
# running 'info commands' from within the namespace will return all commands resolvable from the space - not just those that are defined there. |
|
# this includes global commands and those supplied by namespaces configured in 'namespace path' |
|
# we can't just use a 'diff' of what commands are visible compared to those that are available from global or 'namespace path' |
|
# because there may be overrides/duplicates that are present in the namespace bing searched. |
|
# we rely on the *apparent* (undocumented?) fact that in the list of commands resolved by 'info commands', |
|
# the commands that are actually in the namespace are listed first. |
|
# This means we can stop processing on the first command for which 'namespace which' shows another namespace. |
|
set remaining [nseval_ifexists $targetns [list apply {{loc} { |
|
::set _visiblecommands [::uplevel 1 [::list ::tcl::info::commands]] |
|
::set _matches [::list] |
|
::foreach _v $_visiblecommands { |
|
::set _commandns [::uplevel 1 [::list ::tcl::namespace::which $_v]] |
|
::if {[::string match ${loc}::* $_commandns]} { |
|
::lappend _matches $_v |
|
} else { |
|
#abort at first in list that resolves from some other namespace |
|
break |
|
} |
|
} |
|
::return $_matches |
|
}} $targetns]] |
|
if {$search ne "*"} { |
|
set remaining [lsearch -all -inline -glob $remaining $search] |
|
} |
|
return [lsort $remaining] |
|
} |
|
|
|
} |
|
interp alias {} nscommandlist {} punk::ns::nscommandlist |
|
|
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::cmdwhich |
|
@cmd -name punk::ns::cmdwhich\ |
|
-summary\ |
|
"Return a dict with keys origin, origintype, which, whichtype."\ |
|
-help\ |
|
"Return a dict with keys origin, origintype, which, whichtype. |
|
'which' represents the full namespace path of the resolved command. |
|
The command is first resolved by Tcl by looking for it in the namespace |
|
in which whichcmd was run, then at each of any entries configured with |
|
'namespace path' for that namespace, and finally in the global namespace. |
|
'origin' represents the full namespace path of where the command represented |
|
by 'which' points to, or the target of the alias if 'whichtype' is 'alias'. |
|
This differs from the Tcl 'namespace origin' result. |
|
In the usual case of a simple proc in a namespace, |
|
'which' and 'origin' will be the same, but for an imported command or an |
|
alias - 'origin' could be a different location, or a different name, or in |
|
the case of an alias, have additional curried-in arguments. |
|
|
|
Note that 'origin' is not necessarily the earliest point in the chain. |
|
For example an alias in one namespace could be imported into another. |
|
This may give a result with origintype alias and whichtype import. |
|
cmdwhich would have to be called on the origin value to inspect further. |
|
An alias pointing to a target with curried-in arguments will show an |
|
origintype of 'script' - whereas an alias to a single word will show the |
|
origintype of the target command. |
|
|
|
An alias that has been renamed into another namespace does not have full |
|
ability to be introspected easily by Tcl. In such a case 'which' and 'origin' |
|
may show the same target, both with type 'alias'. Another mechanism such as |
|
pattern::which_alias may need to be used to inspect the origin alias further. |
|
Such mechanisms may involve actually running the command - which can be risky |
|
to do on arbitrary commands, and so is not automated. |
|
|
|
An alias may point to a command that is runnable, but not available for |
|
introspection by the current interp (e.g in safe interps). |
|
Such an alias may return an origintype of 'notfound', just as a nonexistant |
|
command or alias target would." |
|
|
|
@values -min 1 -max 1 |
|
cmd -multiple 0 -optional 0 |
|
} |
|
#REVIEW! todo - change 'origin' in resultdict to 'next'? |
|
#(origin too similar to 'namespace origin' - but we are using it for that as well as alias target) |
|
#TODO - handle interp alias eg interp0 alias ::thread::id ::thread::id without infinite loop |
|
proc cmdwhich {querycommand} { |
|
set nscaller [uplevel 1 [list ::tcl::namespace::current]] |
|
#puts "cmdwhich nscaller: $nscaller" |
|
if {[string match ::* $querycommand]} { |
|
#absolute |
|
set cmdparts [nsparts_cached $querycommand] |
|
set name [lindex $cmdparts end] |
|
set targetparts [lrange $cmdparts 0 end-1] |
|
set targetns [join $targetparts ::] |
|
#set targetns [nsprefix $querycommand] |
|
#set name [nstail $querycommand] |
|
#set targetparts [nsparts_cached $targetns] |
|
if {[lsearch $targetparts :*] >=0} { |
|
# |
|
#for an *unwisely* named ns - info commands ${targetns}::* will not work |
|
set ns_commands [nscommandlist $targetns] ;#results are tails only |
|
set ns_commands_fq [lmap v $ns_commands {string cat $targetns ::$v}] |
|
if {[lsearch -exact $ns_commands_fq $querycommand] >= 0} { |
|
#use nseval_ifexists to avoid creating intermediate namespaces for bogus paths |
|
if {[punk::ns::nsexists $targetns]} { |
|
set origin [nseval_ifexists $targetns [list ::namespace origin $name]] |
|
set resolved [nseval_ifexists $targetns [list ::namespace which $name]] |
|
} else { |
|
puts stderr "ns $targetns does'nt seem to exist" |
|
set origin $querycommand |
|
set resolved $querycommand |
|
} |
|
} else { |
|
#fully qualified command specified but doesn't exist |
|
set origin $querycommand |
|
set resolved $querycommand |
|
} |
|
|
|
} else { |
|
set ns_commands_fq [info commands ${targetns}::*] ;#results remain fully qualified |
|
if {[lsearch -exact $ns_commands_fq $querycommand] >= 0} { |
|
if {[namespace exists $targetns]} { |
|
set origin [namespace eval $targetns [list ::namespace origin $name]] |
|
set resolved [namespace eval $targetns [list ::namespace which $name]] |
|
} else { |
|
#puts stderr "ns $targetns doesn't seem to exist" |
|
set origin $querycommand |
|
set resolved $querycommand |
|
} |
|
} else { |
|
#fully qualified command specified but doesn't exist |
|
set origin $querycommand |
|
set resolved $querycommand |
|
} |
|
} |
|
} else { |
|
#relative commandpath |
|
if {[string match (autodef)* $querycommand]} { |
|
#pass through - should be found with id lookup |
|
set origin $querycommand |
|
set resolved $querycommand |
|
} else { |
|
#set thispath [uplevel 1 [list ::nsthis $querycommand]] |
|
set thispath [uplevel 1 [list ::punk::ns::nspath_here_absolute $querycommand]] |
|
set targetns [nsprefix $thispath] |
|
set name [nstail $thispath] |
|
set targetparts [nsparts_cached $targetns] |
|
if {[lsearch $targetparts :*] >=0} { |
|
#weird ns |
|
if {[nsexists $targetns]} { |
|
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 querycommand 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 as relative to current doesn't seem to exist |
|
#Tcl would also attempt to resolve as global |
|
if {$nscaller ne "::"} { |
|
return [namespace eval :: [list punk::ns::cmdwhich $querycommand]] |
|
} |
|
|
|
set origin $querycommand |
|
set resolved $querycommand |
|
} |
|
} else { |
|
if {[namespace exists $targetns]} { |
|
if {[catch { |
|
set origin [namespace eval $targetns [list ::namespace origin $name]] |
|
set resolved [namespace eval $targetns [list ::namespace which $name]] |
|
}]} { |
|
set thiscmd [nsjoin $targetns $name] |
|
#relative querycommand 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 as relative to current doesn't seem to exist |
|
#Tcl would also attempt to resolve as global |
|
if {$nscaller ne "::"} { |
|
return [namespace eval :: [list punk::ns::cmdwhich $querycommand]] |
|
} |
|
|
|
set origin $querycommand |
|
set resolved $querycommand |
|
} |
|
} |
|
} |
|
} |
|
set origintype [punk::ns::cmdtype $origin] |
|
set whichtype [punk::ns::cmdtype $resolved] |
|
|
|
if {$resolved eq $origin && $origintype in {na alias} && $whichtype in {na alias}} { |
|
#REVIEW - alias entry doesn't necessarily match command! |
|
#consider using which_alias (wiki) |
|
set tgt [interp alias "" $origin] |
|
if {$tgt eq ""} { |
|
set tgt [interp alias "" [string trimleft $origin :]] |
|
} |
|
#first word of tgt may be namespace relative or absolute |
|
if {$tgt ne ""} { |
|
#even if it was marked as na (8.6?) - it's an alias |
|
set whichtype alias |
|
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 targetword [lindex $tgt end] |
|
set origin $targetword |
|
#retest cmdtype on modified origin |
|
set origintype [punk::ns::cmdtype $origin] |
|
} else { |
|
#alias may have some curried-in arguments |
|
if {[llength $tgt] == 1} { |
|
#in child interps - we may legitimately get an *apparent* alias to self |
|
#eg because parent interp called something like: interp0 alias ::thread::id ::thread::id |
|
#make sure we don't perform an infinite loop |
|
if {$tgt ne $resolved} { |
|
set whichinfo [uplevel 1 [list ::punk::ns::cmdwhich $tgt]] |
|
set origin [dict get $whichinfo origin] |
|
set origintype [dict get $whichinfo origintype] |
|
} |
|
} else { |
|
set origin $tgt ;#multiword origin |
|
set origintype script |
|
} |
|
} |
|
} else { |
|
#not an alias |
|
if {$whichtype eq "na"} { |
|
#tcl 8.6 |
|
if {[info object isa object $origin]} { |
|
if {[info object isa class $origin]} { |
|
set origintype "ooclass" |
|
set whichtype "ooclass" |
|
} else { |
|
set origintype "ooobject" |
|
set whichtype "ooobject" |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
return [dict create origin $origin origintype $origintype which $resolved whichtype $whichtype] |
|
} |
|
|
|
#review - should be in punk::args? |
|
proc generate_autodef {args} { |
|
set cmd [lindex $args 0] |
|
if {[string match (autodef)* $cmd]} { |
|
set cmd [string range $cmd 9 end] |
|
} |
|
set queryargs [lrange $args 1 end] |
|
set cinfo [punk::ns::cmdwhich $cmd] |
|
set origin [dict get $cinfo origin] |
|
set cmdtype [dict get $cinfo origintype] |
|
switch -- $cmdtype { |
|
script - alias { |
|
#don't generate (autodef) on plain alias or curried alias (script) - let them resolve |
|
} |
|
object - ooobject - ooclass { |
|
#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 $queryargs]} { |
|
set c1 [lindex $queryargs 0] |
|
if {$c1 in $public_methods} { |
|
switch -- $c1 { |
|
new { |
|
set constructorinfo [info class constructor $origin] |
|
set arglist [lindex $constructorinfo 0] |
|
set argdef [punk::lib::tstr -return string { |
|
@id -id "(autodef)${$origin} new" |
|
@cmd -name "${$origin} new"\ |
|
-summary\ |
|
"Create new object instance."\ |
|
-help\ |
|
"create object with autogenerated 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 argdef \n "args -optional 1 -multiple 1" |
|
} else { |
|
append argdef \n "$a" |
|
} |
|
} else { |
|
append argdef \n "[lindex $a 0] -default [lindex $a 1]" |
|
} |
|
incr i |
|
} |
|
punk::args::define $argdef |
|
set queryargs_remaining [lrange $queryargs 1 end] |
|
} |
|
create { |
|
if {![catch { |
|
set constructorinfo [info class constructor $origin] |
|
}]} { |
|
set arglist [lindex $constructorinfo 0] |
|
} else { |
|
set arglist [list] |
|
} |
|
|
|
set argdef [punk::lib::tstr -return string { |
|
@id -id "(autodef)${$origin} create" |
|
@cmd -name "${$origin} create"\ |
|
-summary\ |
|
"Create new object instance with specified command name."\ |
|
-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 argdef \n "args -optional 1 -multiple 1" |
|
} else { |
|
append argdef \n "$a" |
|
} |
|
} else { |
|
append argdef \n "[lindex $a 0] -default [lindex $a 1]" |
|
} |
|
incr i |
|
} |
|
punk::args::define $argdef |
|
set queryargs_remaining [lrange $queryargs 1 end] |
|
} |
|
destroy { |
|
#review - generally no doc |
|
# but we may want notes about a specific destructor |
|
set argdef [punk::lib::tstr -return string { |
|
@id -id "(autodef)${$origin} destroy" |
|
@cmd -name "destroy"\ |
|
-summary\ |
|
"delete object instance."\ |
|
-help\ |
|
"delete object, calling destructor if any. |
|
destroy accepts no arguments." |
|
@values -min 0 -max 0 |
|
}] |
|
punk::args::define $argdef |
|
set queryargs_remaining [lrange $queryargs 1 end] |
|
} |
|
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 oodef "" |
|
foreach impl $implementations { |
|
lassign $impl generaltype mname location methodtype |
|
switch -- $generaltype { |
|
method - private { |
|
#objects being dynamic systems - we should always reinspect. |
|
#Don't use the cached (autodef) def |
|
#If there is a custom def override - use it (should really be -dynamic - but we don't check) |
|
if {$location eq "object"} { |
|
set idcustom "$origin $c1" |
|
#set id "[string trimleft $origin :] $c1" ;# "<object> <method>" |
|
if {[punk::args::id_exists $idcustom]} { |
|
return |
|
} |
|
set oodef [::info object definition $origin $c1] |
|
} else { |
|
#set id "[string trimleft $location :] $c1" ;# "<class> <method>" |
|
set idcustom "$location $c1" |
|
if {[punk::args::id_exists $idcustom]} { |
|
return |
|
} |
|
set oodef [::info class definition $location $c1] |
|
} |
|
break |
|
} |
|
filter { |
|
} |
|
unknown { |
|
} |
|
} |
|
} |
|
if {$oodef ne ""} { |
|
set autoid "(autodef)$location $c1" |
|
set arglist [lindex $oodef 0] |
|
set argdef [punk::lib::tstr -return string { |
|
@id -id "${$autoid}" |
|
@cmd -name "${$location} ${$c1}" -help\ |
|
"(autogenerated by generate_autodef) |
|
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 argdef \n "args -optional 1 -multiple 1" |
|
} else { |
|
append argdef \n "$a" |
|
} |
|
} |
|
2 { |
|
append argdef \n "[lindex $a 0] -default {[lindex $a 1]} -optional 1" |
|
} |
|
default { |
|
puts stderr "generate_autodef unexpected oo argument signature '$arglist'\noodef:$oodef\nimplementations:$implementations" |
|
} |
|
} |
|
incr i |
|
} |
|
punk::args::define $argdef |
|
return ok |
|
} else { |
|
return "unable to resolve $origin method $c1" |
|
} |
|
|
|
} |
|
} |
|
} |
|
} |
|
set choicelabeldict [dict create] |
|
set choiceinfodict [dict create] |
|
foreach cmd $public_methods { |
|
switch -- $cmd { |
|
default { |
|
set implementations [::info object call $origin $cmd] |
|
set def "" |
|
foreach impl $implementations { |
|
lassign $impl generaltype mname location methodtype |
|
# |
|
switch -- $generaltype { |
|
method - private { |
|
#private? todo? |
|
if {$location eq "object" || $location eq $origin} { |
|
#set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" |
|
set id "$origin $cmd" |
|
#dict set choiceinfodict $cmd {{doctype ooo}} |
|
dict set choiceinfodict $cmd {{doctype objectmethod}} |
|
} elseif {$location eq $class} { |
|
#set id "[string trimleft $location :] $cmd" ;# "<class> <method>" |
|
set id "$location $cmd" |
|
#dict set choiceinfodict $cmd {{doctype ooc}} |
|
dict set choiceinfodict $cmd {{doctype classmethod}} |
|
} else { |
|
#e.g impl: {method destroy ::oo::object {core method: "destroy"}} |
|
set id "$location $cmd" |
|
if {[string match "core method:*" $methodtype]} { |
|
dict lappend choiceinfodict $cmd {doctype coremethod} |
|
} else { |
|
dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] |
|
} |
|
} |
|
if {[punk::args::id_exists $id]} { |
|
#dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" |
|
dict lappend choiceinfodict $cmd {doctype punkargs} |
|
dict lappend choiceinfodict $cmd [list subhelp {*}$id] |
|
} |
|
break |
|
} |
|
filter { |
|
#todo? flag if filter is on object vs class? |
|
dict set choiceinfodict $cmd {{doctype filter}} |
|
dict set choiceinfodict $cmd {{doctype TODO}} |
|
#filter chain? |
|
} |
|
unknown { |
|
dict set choiceinfodict $cmd {{doctype unknown}} |
|
} |
|
default { |
|
error "generate_autodef unhandled generaltype:'$generaltype' for info object call $origin $cmd" |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
|
|
set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review |
|
#puts stderr "--->$vline" |
|
set autoid "(autodef)$origin" |
|
if {[info object isa class $origin]} { |
|
set objtype Class |
|
} else { |
|
set objtype Object |
|
} |
|
#An object command name can contain spaces - so we must quote the -id value |
|
set argdef [punk::lib::tstr -return string { |
|
@id -id "${$autoid}" |
|
@cmd -name "${$objtype}: ${$origin}" -help\ |
|
"Instance of class: ${$class} (info autogenerated by generate_autodef) |
|
(see 'i punk::ns::Cmark' for symbols)" |
|
@leaders -min 1 -max 1 |
|
}] |
|
append argdef \n $vline |
|
append argdef \n "@values -unnamed true" |
|
append argdef \n "@instance -help {instance info derived from id (instance)$origin ?}" |
|
punk::args::define $argdef |
|
|
|
} |
|
privateObject { |
|
return "Command is a privateObject - no info currently available" |
|
} |
|
privateClass { |
|
return "Command is a privateClass - no info currently available" |
|
} |
|
interp { |
|
#todo |
|
puts stderr "generate_autodef - interp" |
|
} |
|
script { |
|
#todo |
|
puts stderr "generate_autodef - script" |
|
} |
|
ensemble { |
|
#review |
|
#todo - check -unknown |
|
|
|
|
|
set ensembleinfo [namespace ensemble configure $origin] |
|
set parameters [dict get $ensembleinfo -parameters] |
|
set prefixes [dict get $ensembleinfo -prefixes] |
|
set map [dict get $ensembleinfo -map] |
|
set ns [dict get $ensembleinfo -namespace] |
|
set unkhandler [dict get $ensembleinfo -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?? |
|
#however - the unknown handler might not add any new subcommands, it may just be for custom error presentation |
|
#see also punk::lib::ensemble::extend - which is based on the wiki 'ensemble extend' command. |
|
#This extension via -unknown mechanism might be common in the wild. |
|
|
|
|
|
|
|
#review - we can have a combination of commands from -map as well as those exported from -namespace |
|
# if and only if -subcommands is specified |
|
#---------------------- |
|
#Documentation for namespace states that "when non-empty, this option lists exactly what subcommands are in the ensemble" |
|
#(When there is an -unknown handler that provides additional subcommands, this isn't effectively true) |
|
#---------------------- |
|
#note that an explicit -subcommands list |
|
|
|
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 $queryargs]} { |
|
set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand |
|
if {$posn_subcommand > 0} { |
|
set params [lrange $queryargs 0 $posn_subcommand-1] |
|
set remaining_queryargs [lrange $queryargs $posn_subcommand end] |
|
} else { |
|
set params [list] |
|
set remaining_queryargs $queryargs |
|
} |
|
if {[llength $remaining_queryargs]} { |
|
if {$prefixes} { |
|
set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] |
|
} else { |
|
set match [lindex $remaining_queryargs 0] |
|
} |
|
if {$match in $subcommands} { |
|
set subcmd [dict get $subcommand_dict $match] |
|
#return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") |
|
#return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] |
|
#tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] |
|
#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") |
|
tailcall generate_autodef {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] |
|
} |
|
} |
|
} |
|
|
|
#todo - synopsis? |
|
set choicelabeldict [dict create] |
|
|
|
set choiceinfodict [dict create] |
|
|
|
dict for {sub subwhat} $subcommand_dict { |
|
if {[llength $subwhat] > 1} { |
|
#TODO - resolve using cmdinfo? |
|
puts stderr "generate_autodef warning: subcommand $sub points to multiword target $subwhat - TODO" |
|
} |
|
set targetfirstword [lindex $subwhat 0] |
|
set targetinfo [cmdwhich $targetfirstword] |
|
set targetorigin [dict get $targetinfo origin] |
|
set targetcmdtype [dict get $targetinfo origintype] |
|
set nstarget [nsprefix $targetorigin] |
|
# -resolved- |
|
dict set choiceinfodict $sub [list [list ensemblesubtarget {*}$subwhat]] |
|
dict lappend choiceinfodict $sub [list doctype $targetcmdtype] |
|
|
|
if {[punk::args::id_exists [list $origin $sub]]} { |
|
dict lappend choiceinfodict $sub {doctype punkargs} |
|
dict lappend choiceinfodict $sub [list subhelp {*}$origin $sub] |
|
} elseif {[punk::args::id_exists $targetorigin]} { |
|
dict lappend choiceinfodict $sub {doctype punkargs} |
|
dict lappend choiceinfodict $sub [list subhelp {*}$targetorigin] |
|
} elseif {[punk::args::id_exists ${origin}::$sub]} { |
|
dict lappend choiceinfodict $sub {doctype punkargs} |
|
dict lappend choiceinfodict $sub [list subhelp {*}${origin}::$sub] |
|
} else { |
|
#puts stderr "arginfo ensemble--- NO doc for [list $origin $sub] or $origin" |
|
} |
|
|
|
} |
|
set restrict "" |
|
set help "" |
|
if {$unkhandler ne ""} { |
|
set restrict [list -choicerestricted 0] |
|
set help [list -help "[punk::ansi::a+ bold]Warning: -unknown handler exists. Not all subcommands may be displayed.[punk::ansi::a]"] |
|
} |
|
|
|
#set vline [list subcommand {*}$restrict {*}$help -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] |
|
#arg to force synopsis -return summary ? |
|
set vline [punk::args::ensemble_subcommands_definition -columns 2 $origin] |
|
|
|
set autoid "(autodef)$origin" |
|
puts "ENSEMBLE auto def $autoid (generate_autodef)" |
|
#A namespace can contain spaces, so an ensemble command can contain spaces. We must quote the -id value in the autodef |
|
set argdef [punk::lib::tstr -return string { |
|
@id -id "${$autoid}" |
|
@cmd -help\ |
|
"(autogenerated by generate_autodef) |
|
ensemble: ${$origin}" |
|
}] |
|
#we must put a max on @leaders so that any subsequent arguments are not parsed as leaders for an ensemble root docid |
|
if {[llength $parameters] == 0} { |
|
append argdef \n "@leaders -min 1 -max 1" |
|
} else { |
|
append argdef \n "@leaders -min [expr {[llength $parameters]+1}] -max [expr {[llength $parameters]+1}]" |
|
foreach p $parameters { |
|
append argdef \n "$p -type string -ensembleparameter 1 -help { (leading ensemble parameter)}" |
|
} |
|
} |
|
append argdef \n $vline |
|
append argdef \n "@values -unnamed true" |
|
punk::args::define $argdef |
|
} |
|
proc { |
|
#JJJ |
|
set tepamhelp "" |
|
if {[info exists ::tepam::ProcedureList]} { |
|
if {$origin in $::tepam::ProcedureList} { |
|
set tepamhelp [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]} { |
|
set tepamhelp [set ::tepam::${func}Help] |
|
} else { |
|
set f2 [string totitle $func] |
|
if {[info exists ::tepam::${f2}Help]} { |
|
set tepamhelp [set ::tepam::${f2}Help] |
|
} else { |
|
#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}]} { |
|
set tepamhelp [set ::tepam::${f3}] |
|
} |
|
} |
|
} |
|
} |
|
} |
|
} |
|
set autoid "(autodef)$origin" |
|
#note it's possible for a proc name to have a space - so we need to quote the -id value |
|
if {$tepamhelp ne ""} { |
|
puts "TEPAM PROC auto def $autoid (generate_autodef)" |
|
set argdef [punk::lib::tstr -return string { |
|
@id -id "${$autoid}" |
|
@cmd -help\ |
|
"(autogenerated by generate_autodef) |
|
proc: ${$origin}" |
|
}] |
|
append argdef \n "@formdisplay -body {$tepamhelp}" |
|
punk::args::define $argdef |
|
} else { |
|
puts "PROC auto def $autoid (generate_autodef)" |
|
#to handle procs like ":" (eg used by colin's bytecode based expr replacement) or other names of the form ":xyz" |
|
#we can't use 'info args :::' - tcl won't find it |
|
set ns [nsprefix $origin] |
|
set nscmd [nstail $origin] |
|
set infoargs [namespace eval $ns [list ::tcl::info::args $nscmd]] |
|
set argdef [punk::lib::tstr -return string { |
|
@id -id "${$autoid}" |
|
@cmd -help\ |
|
"(autogenerated by generate_autodef) |
|
proc: ${$origin}" |
|
@leaders |
|
}] |
|
set i -1 |
|
#rather than type 'any' - we should use 'unknown' |
|
foreach a $infoargs { |
|
incr i |
|
#we need a varname for ::tcl::info::default - but as we need to run it in the ns we have to be careful, |
|
#or we risk variable collisions/pollution of the target ns. |
|
set default_info [apply [list {procname argname} { |
|
if {[::tcl::info::default $procname $argname defaultval]} { |
|
return [dict create exists 1 default $defaultval] |
|
} else { |
|
return [dict create exists 0 default ""] |
|
} |
|
} $ns] $nscmd $a] |
|
if {[dict get $default_info exists]} { |
|
append argdef \n "$a -type unknown -default \"[dict get $default_info default]\"" |
|
} else { |
|
if {$i == [llength $infoargs]-1 && $a eq "args"} { |
|
#we need to use a name that doesn't collide with any previous arguments |
|
#The common way of expressing args in a synopsis is ?arg...? but this won't work if a proc is defined such as: |
|
#proc something {arg args} {...} |
|
#This is a bit unfortunate, but not that unusual. |
|
#If we use 'args' - we get a synopsis of ?args...? which isn't great |
|
#if someone uses both arg and args - we'll choose next available arg<int> for <int> starting at 1 |
|
if {"arg" in $infoargs} { |
|
#It's also possible someone defined a proc such as: |
|
#proc something {args args} {...} |
|
#This would make $args available in the proc as a single value, whilst making the remaining args inaccessble. |
|
#Most likely that would be done in error? |
|
set n 1 |
|
while {[lsearch $infoargs arg$n] >=0} { |
|
incr n |
|
} |
|
set args_element "arg$n" |
|
} else { |
|
set args_element "arg" |
|
} |
|
append argdef \n "$args_element -type unknown -multiple 1 -optional 1" |
|
} else { |
|
append argdef \n "$a -type unknown" |
|
} |
|
} |
|
} |
|
punk::args::define $argdef |
|
} |
|
} |
|
} |
|
|
|
} |
|
|
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::cmdinfo |
|
@cmd -name punk::ns::cmdinfo\ |
|
-summary\ |
|
"Subcommand resolution of ensemble-like tree of commands."\ |
|
-help\ |
|
"Return a dict with command resolution info for ensemble-like tree of commands with subcommands" |
|
@leaders -min 0 -max 0 |
|
@opts |
|
-form -default * -help\ |
|
"Ordinal index or name of command form" |
|
@values -min 1 -max -1 |
|
cmditem -multiple 1 -optional 0 |
|
} |
|
variable cmdinfo_reducerid 0 |
|
proc cmdinfo {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::ns::cmdinfo] |
|
lassign [dict values $argd] leaders opts values received |
|
|
|
set cmdlist [dict get $values cmditem] |
|
if {[llength $cmdlist] == 0} { |
|
return ;#review - shouldn't get here anyway |
|
} |
|
set fid [dict get $opts -form] ;#todo |
|
|
|
variable cmdinfo_reducerid |
|
set reduce ::punk::ns::reducer[incr cmdinfo_reducerid] |
|
set nscaller [uplevel 1 [list ::tcl::namespace::current]] |
|
|
|
set init [coroutine $reduce cmd_traverse $nscaller $fid {*}$cmdlist] |
|
#puts stderr "init: $init" |
|
set final 0 |
|
set origin "" |
|
set stack [list] |
|
set commands [list] |
|
set consumed_args [list] |
|
set docid "" |
|
while {$final == 0} { |
|
lassign [$reduce $origin] final origin consumed remainingargs docid |
|
#if {$final != 1} { |
|
if {[string match (autodef)* $origin]} { |
|
set origin [string range $origin 9 end] |
|
} |
|
#puts "->$final neworigin: $origin consumed:$consumed remaining:$remainingargs docid:$docid" |
|
lappend stack [list $origin {*}$consumed] |
|
lappend commands $origin |
|
lappend consumed_args {*}$consumed |
|
#} |
|
} |
|
set finalcommand [lindex $commands end] |
|
set cinfo [cmdwhich $finalcommand] |
|
set origin [dict get $cinfo origin] |
|
set cmdtype [dict get $cinfo origintype] |
|
if {$cmdtype eq "notfound" && [llength $finalcommand] > 1} { |
|
#e.g see curried command produced by 'punk::netbox::man <apicontextid> new' |
|
set next [list {*}$finalcommand {*}$remainingargs] |
|
if {$next ne $args} { |
|
return [cmdinfo {*}$next] |
|
} |
|
} |
|
return [list origin $origin cmdtype $cmdtype args_resolved [list [lindex $commands 0] {*}$consumed_args] args_remaining $remainingargs docid $docid stack $stack] |
|
} |
|
proc cmd_traverse {ns formid args} { |
|
set autodefined [dict create] |
|
#puts "cmd_traverse args: $args yielding: [info coroutine]" |
|
yield [info coroutine] |
|
if {![llength $args]} { |
|
return |
|
} |
|
set cmd "" |
|
|
|
#use a for loop over args - as sometimes we may consume more than one in our reduction (e.g when there are ensemble parameters) |
|
set argc [llength $args] |
|
set cmd [lindex $args 0] |
|
set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $cmd]] |
|
set origin [dict get $whichinfo origin] |
|
set which [dict get $whichinfo which] |
|
set whichtype [dict get $whichinfo whichtype] |
|
|
|
set docid "" |
|
|
|
#An imported or aliased command could be deliberately documented in the target namespace to override the origin |
|
if {$argc == 1 && $origin ne $which} { |
|
punk::args::update_definitions [list [namespace qualifiers $which]] |
|
#we don't call generate_auto_def on the 'which' version of the command |
|
#but we do want to lookup and use any explicit punk::args id that may exist for it |
|
if {[punk::args::id_exists $which]} { |
|
set docid $which |
|
set origin $which ;#Flip our traversal to be on the documented 'which' rather than the actual origin |
|
if {$whichtype eq "alias"} { |
|
#*documented* alias |
|
return [list 1 $origin {} [lrange $args 1 end] $docid] |
|
} |
|
} |
|
} |
|
|
|
if {$docid eq ""} { |
|
#there was no explicit documentation for the command at it's actual 'which' location. |
|
punk::args::update_definitions [list [namespace qualifiers $origin]] |
|
if {![punk::args::id_exists $origin] && ![dict exists $autodefined $origin]} { |
|
namespace eval $ns [list punk::ns::generate_autodef $origin] |
|
dict set autodefined $origin 1 |
|
} |
|
if {[punk::args::id_exists $origin]} { |
|
set docid $origin |
|
} elseif {[punk::args::id_exists "(autodef)$origin"]} { |
|
set docid (autodef)$origin |
|
} else { |
|
set docid "" |
|
} |
|
} |
|
|
|
set resolvedargs {} |
|
#if {$argc == 1} { |
|
# return [list 1 $origin {} [lrange $args 1 end] $docid] |
|
#} else { |
|
|
|
if {$docid ne "" && ![llength [lrange $args 1 end]]} { |
|
return [list 0a $origin {} {} $docid] |
|
} |
|
|
|
set origin [yield [list 0 $origin {} [lrange $args 1 end] $docid]] |
|
set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $cmd]] |
|
set origin [dict get $whichinfo origin] |
|
set origintype [dict get $whichinfo origintype] |
|
set which [dict get $whichinfo origin] |
|
#an alias may have direct documentation |
|
#if so - use it before resolving via origin |
|
punk::args::update_definitions [list [namespace qualifiers $which]] |
|
if {[punk::args::id_exists $which]} { |
|
set docid $which |
|
set origin $which |
|
} else { |
|
set docid "" |
|
} |
|
if {$docid eq ""} { |
|
#review - orgintype classmethod, objectmethod? |
|
switch -- $origintype { |
|
script { |
|
#a 'script' is essentially an alias-target to a command with curried args |
|
#There will not be documentation or a 'command' matching the entire script, but there may be for the target command (first word of script) |
|
set scriptcmdraw [lindex $origin 0] |
|
set scriptinfo [namespace eval $ns [list punk::ns::cmdwhich $scriptcmdraw]] |
|
set scriptcmd [dict get $scriptinfo which] |
|
set scriptargs [lrange $origin 1 end] |
|
#ledit args -1 -1 {*}$scriptargs ;#prepend |
|
set args [linsert $args 1 {*}$scriptargs] |
|
#JJJ review |
|
#set resolvedargs $scriptargs |
|
punk::args::update_definitions [list [namespace qualifiers $scriptcmd]] |
|
if {![punk::args::id_exists $scriptcmd] && ![dict exists $autodefined $scriptcmd]} { |
|
namespace eval $ns [list punk::ns::generate_autodef $scriptcmd] |
|
dict set autodefined $origin 1 |
|
#if the scriptcmd is itself an alias - no autodef will be generated for it |
|
} |
|
if {[punk::args::id_exists $scriptcmd]} { |
|
set docid $scriptcmd |
|
} elseif {[punk::args::id_exists "(autodef)$scriptcmd"]} { |
|
set docid (autodef)$scriptcmd |
|
} else { |
|
|
|
set docid "" |
|
} |
|
set origin $scriptcmd |
|
} |
|
alias { |
|
#JJJ2 |
|
#puts "==> examining alias $origin" |
|
if {[string match >* [nstail $origin]] && [package provide pattern] ne ""} { |
|
if {![catch {pattern::which_alias $origin} alias_target]} { |
|
#review - todo? |
|
set patternorigin [lindex $alias_target 0] |
|
#set queryargs [list {*}[lrange $alias_target 1 end] {*}$queryargs] |
|
set args [linsert $args 1 {*}[lrange $alias_target 1 end]] |
|
#set resolvedargs [lrange $alias_target 1 end] |
|
punk::args::update_definitions [list [namespace qualifiers $patternorigin]] |
|
if {![punk::args::id_exists $patternorigin] && ![dict exists $autodefined $patternorigin]} { |
|
namespace eval $ns [list punk::ns::generate_autodef $patternorigin] |
|
dict set autodefined $origin 1 |
|
#if the patternorigin is itself an alias - no autodef will be generated for it |
|
} |
|
if {[punk::args::id_exists $patternorigin]} { |
|
set docid $patternorigin |
|
} elseif {[punk::args::id_exists "(autodef)$patternorigin"]} { |
|
set docid (autodef)$patternorigin |
|
} else { |
|
|
|
set docid "" |
|
} |
|
set origin $patternorigin |
|
} |
|
} |
|
} |
|
default { |
|
punk::args::update_definitions [list [namespace qualifiers $origin]] |
|
if {![punk::args::id_exists $origin] && ![dict exists $autodefined $origin]} { |
|
namespace eval $ns [list punk::ns::generate_autodef $origin] |
|
dict set autodefined $origin 1 |
|
} |
|
if {[punk::args::id_exists $origin]} { |
|
set docid $origin |
|
} elseif {[punk::args::id_exists "(autodef)$origin"]} { |
|
set docid (autodef)$origin |
|
} else { |
|
set docid "" |
|
} |
|
} |
|
} |
|
} |
|
#} |
|
if {[llength $args] == 1} { |
|
return [list 2 $origin $resolvedargs {} $docid] |
|
} |
|
set terminate 0 |
|
for {set i 1} {$i < [llength $args]} {incr i} { |
|
#set a [lindex $args $i] |
|
#puts "i:$i a:$a origin:$origin" |
|
#xxx |
|
#puts "==> origin:'$origin' a:'$a'" |
|
|
|
#this docid may be an (autodef) for a level that had no specific documentation. |
|
#If the command at this level is a proc - such an autodef will not have automatically determined any deeper subcommands. |
|
#If however there exists a definition for a space delimited deeper level - then that docid should ideally be found |
|
#e.g punk::args::id_exists "$origin $a" |
|
#we could/should look deeper going backwards? |
|
#ie examining each docid from start will not work to find deeper documented items if there are gaps in manual docs and autodefs based on intermediate procs |
|
#The idea is to support packages for which documentation is incomplete - and to avoid unnecessary lookups of intermediaries. |
|
#e.g starting at: punk::args::id_exists "$origin {*}[lrange $args $i end]" and shortening? |
|
#for example the fictitious ensemble-like nest "::a b c d" |
|
#c may be an undoc'ed proc but the id "::a b c d" may exist |
|
#or ::a b might resolve somewhere unrelated e.g ::foo::bar and "::foo::bar c d" might exist |
|
#starting at the end may involve testing for many ids based on non subcommand args (args to the deepest subcommand itself) |
|
# while id_exists checks don't seem to be hugely expensive - this may not be the best approach on a very large documented system. |
|
#we could at least check for the next level down - allowing a single level of progression beyond undoc'ed subcommand-accepting procs. |
|
#(would not support shor-form prefix of subcommand - even if the proc implementation did) |
|
set docid_exists 0 |
|
set eparams [list] |
|
if {[punk::args::id_exists "$origin [lindex $args $i]"]} { |
|
set a [lindex $args $i] |
|
#review - tests? |
|
puts stderr "cmd_traverse - skipping to documented subcommand '$origin $a'" |
|
#we can only seek beyond an undocumented subcommand level via a space delimited path, as we can make no assumption about the actual location of a subcommand relative to its parent |
|
#There could be a different command at for example "${origin}::$a" which is unrelated to the actual resolution path. |
|
set docid_exists 1 |
|
set docid "$origin $a" |
|
set origin [list $origin $a] |
|
incr i |
|
set queryargs [lrange $args $i end] |
|
set resolvedargs [list $a] ;# |
|
set queryargs_untested $queryargs |
|
} elseif {[punk::args::id_exists $docid]} { |
|
set docid_exists 1 |
|
set queryargs [lrange $args $i end] |
|
set resolvedargs [list] |
|
set queryargs_untested $queryargs |
|
} else { |
|
#we cannot generate autodoc for any deeper (e.g ensemble/proc after undocumented parent) |
|
#There is nothing to indicate the locations of subcommands - they could be anywhere. |
|
#e.g (dispatched by custom code in a proc) |
|
#'guessing' that they follow a namespace hierarchy would be error-prone and a bad idea even if it sometimes worked. |
|
} |
|
|
|
if {$docid_exists} { |
|
|
|
#review - get_spec needs to resolve if @dynamic |
|
#we don't really need the spec if we have no queryargs |
|
if {![llength $queryargs]} { |
|
return [list X $origin $resolvedargs $queryargs_untested $docid] |
|
} |
|
|
|
|
|
set spec [punk::args::get_spec $docid] |
|
#--------------------------------------------------------------------------- |
|
set form_names [dict get $spec form_names] |
|
set fid [lindex $form_names 0] |
|
|
|
#set fid "" |
|
#if {$formid eq "*"} { |
|
# if {[llength $form_names] == 1} { |
|
# set fid [lindex $form_names 0] |
|
# } else { |
|
# error "cmd_traverse command has [llength $form_names] forms but no specific -form selected. multiform discrimination not yet supported" |
|
# } |
|
#} elseif {[string is integer -strict $formid]} { |
|
# set fid [lindex $form_names $formid] |
|
#} else { |
|
# set fid [tcl::prefix::match -error "" $form_names $formid] |
|
#} |
|
#if {$fid eq ""} { |
|
# error "cmd_traverse unable to match form $formid. form names: $form_names" |
|
#} |
|
|
|
set leadernames [dict get $spec FORMS $fid LEADER_NAMES] |
|
set optnames [dict get $spec FORMS $fid OPT_NAMES] |
|
set valnames [dict get $spec FORMS $fid VAL_NAMES] |
|
|
|
#review - see 'string is word' vs 'string is wordchar' behaviour due to documented common opts/vals in the parent ensemble-like command '::tcl::string::is' |
|
#we should be preferring the most specific documentation |
|
#Alternatively - we could adjust the 'string is' documentation to have @values -unnamed true |
|
#and put the common info in the help for <unnamed> - but that would give us an inferior synopsis for 'string is' |
|
|
|
if {![llength $optnames] && ![llength $valnames]} { |
|
|
|
#set queryargs [lrange $args $i end] |
|
#set resolvedargs [list] |
|
#set queryargs_untested $queryargs |
|
|
|
set leadernames_matched [lrange $leadernames 0 [llength $queryargs]-1] |
|
foreach q $queryargs lname $leadernames_matched { |
|
#puts "===> queryargs:$queryargs lnames:$leadernames_matched" |
|
#usually we expect only one entry in leadernames (except for -ensembleparameter cases) |
|
if {$lname eq ""} { |
|
#todo - return? |
|
break |
|
} |
|
set arginfo [dict get $spec FORMS $fid ARG_INFO $lname] |
|
set allchoices [list] |
|
set choices [punk::args::system::Dict_getdef $arginfo -choices {}] |
|
set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] |
|
set choiceinfo [punk::args::system::Dict_getdef $arginfo -choiceinfo {}] |
|
set is_ensembleparam [punk::args::system::Dict_getdef $arginfo -ensembleparameter 0] |
|
if {[dict exists $choicegroups ""]} { |
|
dict lappend choicegroups "" {*}$choices |
|
} else { |
|
set choicegroups [dict merge [dict create "" $choices] $choicegroups] |
|
} |
|
dict for {groupname clist} $choicegroups { |
|
lappend allchoices {*}$clist |
|
} |
|
if {$is_ensembleparam} { |
|
lappend resolvedargs $q |
|
lpop queryargs_untested 0 |
|
lappend eparams $q |
|
puts stderr "---> cmd_traverse ensembleparam $q ($lname)" |
|
puts stderr "arginfo: $arginfo" |
|
puts stderr "---> eparams: $eparams" |
|
puts stderr "---> existing args: $args" |
|
#ledit queryargs_untested 0 0 |
|
#review - add tests |
|
|
|
#todo - put param in untested (multiple ensembleparams??) |
|
#ledit queryargs_untested 1 0 $q ;#(linsert) |
|
|
|
#set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand |
|
#if {$posn_subcommand > 0} { |
|
# set params [lrange $queryargs 0 $posn_subcommand-1] |
|
# set remaining_queryargs [lrange $queryargs $posn_subcommand end] |
|
#} else { |
|
# set params [list] |
|
# set remaining_queryargs $queryargs |
|
#} |
|
incr i |
|
continue |
|
} |
|
if {![llength $allchoices]} { |
|
#review - only leaders with a defined set of choices are eligible for consideration as a subcommand |
|
#lappend resolvedargs $q |
|
#lpop queryargs_untested 0 |
|
#ledit queryargs_untested 0 0 |
|
#jjj |
|
#continue |
|
return [list 3 $origin $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid] |
|
break |
|
} |
|
set resolved_q [tcl::prefix::match -error "" $allchoices $q] |
|
if {$resolved_q eq ""} { |
|
return [list 4 $origin $resolvedargs $queryargs_untested $docid] |
|
break |
|
} |
|
if {![dict get $arginfo -choiceprefix] && $resolved_q ne $q} { |
|
#a unique prefix is not sufficient for this arg |
|
return [list 5 $origin $resolvedargs $queryargs_untested $docid] |
|
break |
|
} |
|
|
|
|
|
#if {$resolved_q ne $q} { |
|
# ##we have our first difference |
|
#} |
|
|
|
set cinfo [punk::args::system::Dict_getdef $choiceinfo $resolved_q {}] |
|
set mapped_subcmd "" |
|
set prevdocid $docid |
|
set docid "" |
|
foreach inf $cinfo { |
|
switch -- [lindex $inf 0] { |
|
"subhelp" { |
|
set mapped_subcmd [lrange $inf 1 end] |
|
#set mapped_subcmd [lindex $inf 1] |
|
if {![punk::args::id_exists $mapped_subcmd]} { |
|
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] |
|
if {![dict exists $autodefined $mapped_subcmd]} { |
|
namespace eval $ns [list punk::ns::generate_autodef $mapped_subcmd] |
|
dict set autodefined $origin 1 |
|
} |
|
} |
|
#if {![punk::args::id_exists $mapped_subcmd] && [punk::args::id_exists "(autodef)$mapped_subcmd"]} { |
|
# set mapped_subcmd "(autodef)$mapped_subcmd" |
|
#} |
|
if {[punk::args::id_exists $mapped_subcmd]} { |
|
set docid $mapped_subcmd |
|
} elseif {[punk::args::id_exists "(autodef)$mapped_subcmd"]} { |
|
set docid (autodef)$mapped_subcmd |
|
} else { |
|
set docid "" |
|
} |
|
#allow subhelp override - todo: review/document rationale/usecases |
|
break |
|
} |
|
"ensemblesubtarget" { |
|
# -resolved- |
|
#punk::args::ensemble_subcommands_definition |
|
#This could be a list representing some other ensemble or command with pre-included arguments |
|
set mapped_subcmd [lrange $inf 1 end] |
|
if {![punk::args::id_exists $mapped_subcmd]} { |
|
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] |
|
if {![dict exists $autodefined $mapped_subcmd]} { |
|
namespace eval $ns [list punk::ns::generate_autodef $mapped_subcmd] |
|
dict set autodefined $origin 1 |
|
} |
|
} |
|
#if {![punk::args::id_exists $mapped_subcmd] && [punk::args::id_exists "(autodef)$mapped_subcmd"]} { |
|
# set mapped_subcmd "(autodef)$mapped_subcmd" |
|
#} |
|
if {[punk::args::id_exists $mapped_subcmd]} { |
|
set docid $mapped_subcmd |
|
} elseif {[punk::args::id_exists "(autodef)$mapped_subcmd"]} { |
|
set docid (autodef)$mapped_subcmd |
|
} else { |
|
set docid "" |
|
} |
|
#puts stderr "cmd_traverse 'resolved' $mapped_subcmd" |
|
} |
|
"doctype" { |
|
set d [lindex $inf 1] |
|
switch -- $d { |
|
"classmethod" { |
|
} |
|
"coremethod" { |
|
} |
|
} |
|
} |
|
} |
|
} |
|
if {$mapped_subcmd eq ""} { |
|
if {[string match (autodef)* $origin]} { |
|
set raw_origin [string range $origin 9 end] |
|
} else { |
|
set raw_origin $origin |
|
} |
|
#puts stderr "cmd_traverse testing punk::args::id_exists \"$raw_origin $resolved_q\"" |
|
if {[punk::args::id_exists "$raw_origin $resolved_q"]} { |
|
set mapped_subcmd "$raw_origin $resolved_q" |
|
set docid $mapped_subcmd |
|
} else { |
|
#NOTE there is no reason to assume a subcommand (even in an ensemble) |
|
#will be located at "${raw_origin}::$resolved_q" |
|
#ensemble -map could point resolved_q somewhere else entirely |
|
} |
|
} |
|
#puts "----------$mapped_subcmd" |
|
if {$mapped_subcmd ne ""} { |
|
lappend resolvedargs $resolved_q |
|
#ledit queryargs_untested 0 0 |
|
lpop queryargs_untested 0 |
|
|
|
#punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] |
|
if {[llength $queryargs_untested] == 0} { |
|
return [list 6 $mapped_subcmd $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid] |
|
} |
|
|
|
set origin [yield [list 0 $mapped_subcmd $resolvedargs [list {*}$eparams {*}$queryargs_untested] $docid]] |
|
|
|
#set resolvedargs [list] |
|
#incr i [expr {-1 * [llength $resolvedargs]+1}] ;#wrong e.g test trace add execution blah enterstep cmd |
|
#JJJ |
|
|
|
#puts stderr "... yield-result $origin i:$i args: $args" |
|
ledit args $i+1 $i {*}$eparams |
|
set eparams [list] |
|
|
|
set whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]] |
|
set origin [dict get $whichinfo origin] |
|
set cmdtype [dict get $whichinfo origintype] |
|
punk::args::update_definitions [list [namespace qualifiers $origin]] ;#update_definitions will treat empty string as global ns :: |
|
if {![punk::args::id_exists $origin] && ![dict exists $autodefined $origin]} { |
|
namespace eval $ns [list punk::ns::generate_autodef $origin] |
|
dict set autodefined $origin 1 |
|
} |
|
if {[punk::args::id_exists $origin]} { |
|
set docid $origin |
|
} elseif {[punk::args::id_exists "(autodef)$origin"]} { |
|
set docid (autodef)$origin |
|
} else { |
|
set docid "" |
|
} |
|
|
|
break ;#out of foreach q $queryargs ... |
|
} else { |
|
#test with: i namespace which -v x |
|
return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid] |
|
} |
|
} ;#end loop foreach q $queryargs lname $leadernames_matched |
|
} else { |
|
#?? |
|
#puts stderr "cmdinfo.cmd_traverse returning 8 origin: $origin resolved: $resolvedargs remaining: [lrange $args $i end] docid: $docid" |
|
return [list 8 $origin $resolvedargs [lrange $args $i end] $docid] |
|
} |
|
} else { |
|
#puts stderr "origin $origin not documented" |
|
return [list 9 $origin {} [lrange $args $i end] ""] |
|
} |
|
} |
|
#REVIEW!!! |
|
puts stderr "cmd_traverse 10 $origin $resolvedargs $queryargs_untested $docid - review" |
|
return [list 10 $origin $resolvedargs $queryargs_untested $docid] |
|
} |
|
|
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::forms |
|
@cmd -name punk::ns::forms\ |
|
-summary\ |
|
"List command forms."\ |
|
-help\ |
|
"Return names for each form of a command. |
|
Most commands are single-form and will only return the name '_default'. |
|
An example of a multiform command is the Tcl builtin '::after'." |
|
@opts |
|
@values -min 1 -max -1 |
|
cmditem -multiple 1 -optional 0 |
|
} |
|
proc forms {args} { |
|
set argd [::punk::args::parse $args -cache 1 withid ::punk::ns::forms] |
|
set cmdwords [dict get $argd values cmditem] |
|
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context |
|
#set id [dict get $resolveinfo origin] |
|
set id [dict get $resolveinfo docid] |
|
::punk::args::forms $id |
|
} |
|
|
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::eg |
|
@cmd -name punk::ns::eg\ |
|
-summary\ |
|
"Return command examples."\ |
|
-help\ |
|
"Return the -help info from the @examples directive |
|
in a command definition." |
|
@values -min 1 -max -1 |
|
cmditem -multiple 1 -optional 0 |
|
} |
|
proc eg {args} { |
|
set argd [::punk::args::parse $args -cache 1 withid ::punk::ns::eg] |
|
set cmdwords [dict get $argd values cmditem] |
|
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context |
|
#set resolved_id [dict get $resolveinfo origin] |
|
#set result [::punk::args::eg $resolved_id] |
|
set docid [dict get $resolveinfo docid] |
|
set result [::punk::args::eg $docid] |
|
} |
|
|
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::synopsis |
|
@cmd -name punk::ns::synopsis\ |
|
-summary\ |
|
"Return command synopsis."\ |
|
-help\ |
|
"Return synopsis for each form of a command |
|
on separate lines. |
|
If -form formname|<int> is given, supply only |
|
the synopsis for that form. |
|
" |
|
@opts |
|
-form -type string -default * -help\ |
|
"Ordinal index or name of command form." |
|
-return -type string -default full -choices {full summary dict} |
|
@values -min 1 -max -1 |
|
cmditem -multiple 1 -optional 0 |
|
} |
|
proc synopsis {args} { |
|
set argd [::punk::args::parse $args -cache 1 withid ::punk::ns::synopsis] |
|
set form [dict get $argd opts -form] |
|
set opt_return [dict get $argd opts -return] |
|
set cmdwords [dict get $argd values cmditem] |
|
|
|
|
|
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context |
|
|
|
set resolved_id [dict get $resolveinfo origin] |
|
set doc_id [dict get $resolveinfo docid] |
|
set unresolved_args [dict get $resolveinfo args_remaining] |
|
set resolved_args [dict get $resolveinfo args_resolved] |
|
|
|
#REVIEW |
|
#set n [llength $unresolved_args] |
|
#set cmdargs [lrange $args 1 end] |
|
#set consumedargs [lrange $cmdargs 0 end-$n] |
|
set synopsis_args [lrange $cmdwords 1 end] |
|
set excess 0 |
|
if {[llength $unresolved_args] > [llength $synopsis_args]} { |
|
#we can get excess args_remaining due to alias currying - REVIEW |
|
#This isn't quite right.. e.g see: s pse |
|
#we need to use something like punk::args::parse against the command with the unresolved_args + synopsis_args ?? |
|
set excess [expr {[llength $unresolved_args] - [llength $synopsis_args]}] |
|
} |
|
|
|
#note we can still get a synopsis for a cmdtype value of 'notfound' if there is a docid for it |
|
|
|
#TODO! better result for subcommand prefix match vs complete mismatch vs undocumented match!!! |
|
|
|
if {$doc_id eq ""} { |
|
set syn [::punk::args::synopsis -return $opt_return -form $form $resolved_id] |
|
} else { |
|
set syn [::punk::args::synopsis -return $opt_return -form $form $doc_id] |
|
} |
|
if {$syn eq ""} { |
|
return |
|
} |
|
|
|
#when we use list operations on $syn - it can get extra braces due to ANSI - use join to bring back to a string without extraneous bracing |
|
switch -- $opt_return { |
|
full - summary { |
|
set resultstr "" |
|
foreach synline [split $syn \n] { |
|
if {[string range $synline 0 1] eq "# "} { |
|
append resultstr $synline \n |
|
} else { |
|
#puts stderr [textblock::frame $syn] |
|
#set replaceuntil [expr {[llength $resolved_id]-1}] |
|
set replaceuntil [expr {[llength $resolved_id]-1+$excess}] |
|
#append resultstr [join [lreplace $synline 0 $replaceuntil {*}$resolved_args] " "] \n ;#don't use join - will destroy braced sets |
|
#e.g see s dict filter |
|
|
|
#treating a somewhat arbitrary string $synline as a list here is a bit risky |
|
#todo - consider always using 'punk::args::synopsis -return dict' and operating on that list to rebuild string - REVIEW |
|
set adjusted_synline [lreplace $synline 0 $replaceuntil {*}$resolved_args] ;#don't use join - will destroy braced sets |
|
#however - we don't want the extra bracing around ansi elements caused by list rep! |
|
#::dict filter {dictionaryValue} script {keyVariable valueVariable} {script} |
|
#vs |
|
#::dict filter dictionaryValue script {keyVariable valueVariable} script |
|
#(due to ansi in dictionaryValue and trailing script) |
|
#manually join based on list length review |
|
|
|
set lineout "" |
|
foreach part $adjusted_synline { |
|
if {[llength $part] == 1} { |
|
append lineout " " $part |
|
} else { |
|
append lineout " " [list $part] |
|
} |
|
} |
|
#must be no leading space for tests in test::punk::args synopsis.test |
|
append resultstr [string trim $lineout] \n |
|
|
|
} |
|
} |
|
set resultstr [string trimright $resultstr \n] |
|
#set resultstr [join [lreplace $syn 0 0 {*}$idparts] " "] |
|
return $resultstr |
|
} |
|
dict { |
|
return $syn |
|
} |
|
} |
|
} |
|
proc synopsis_raw {args} { |
|
set argd [::punk::args::parse $args -cache 1 withid ::punk::ns::synopsis] |
|
set form [dict get $argd opts -form] |
|
set cmdwords [dict get $argd values cmditem] |
|
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context |
|
set id [dict get $resolveinfo origin] |
|
::punk::args::synopsis -form $form $id |
|
} |
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::cmdhelp |
|
@cmd -name punk::ns::cmdhelp\ |
|
-summary\ |
|
"Command usage/help."\ |
|
-help\ |
|
"Show usage info for a command. |
|
It supports the following: |
|
1) Procedures or builtins for which a punk::args definition has |
|
been loaded. |
|
2) tepam procedures (returns string form only) |
|
3) ensemble commands - auto-generated unless documented via punk::args |
|
(subcommands will show with an indicator if they are |
|
explicitly documented or are themselves ensembles) |
|
4) tcl::oo objects - auto-gnerated unless documented via punk::args |
|
5) dereferencing of aliases to find underlying command |
|
(will not work with some renamed aliases) |
|
|
|
Note that native commands commands not explicitly documented will |
|
generally produce no useful info. For example sqlite3 dbcmd objects |
|
could theoretically be documented - but as 'info cmdtype' just shows |
|
'native' they can't (?) be identified as belonging to sqlite3 without |
|
calling them. cmdhelp deliberately avoids calling commands to elicit |
|
usage information as this is inherently risky. (could create a file, |
|
exit the interp etc) |
|
" |
|
-return -type string -default table -choices {string table tableobject} |
|
|
|
|
|
} {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { |
|
-form -default 0 -help\ |
|
"Ordinal index or name of command form" |
|
-grepstr -default "" -type list -typesynopsis regex -help\ |
|
"Case insensitive grep for pattern in the output. |
|
list consisting of regex, optionally followed by ANSI names for highlighting" |
|
-- -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, ensemble, tcl::oo object, tepam proc etc)" |
|
subcommand -optional 1 -multiple 1 -default {} -help\ |
|
"subcommand if commandpath is an ensemble. |
|
Multiple subcommands can be supplied if ensembles are further nested" |
|
} |
|
proc cmdhelp {args} { |
|
set nscaller [uplevel 1 [list ::tcl::namespace::current]] |
|
lassign [dict values [punk::args::parse $args -cache 1 withid ::punk::ns::cmdhelp]] leaders opts values received |
|
if {![dict exists $received -scheme]} { |
|
#dict set opts -scheme info |
|
set scheme_received 0 |
|
} else { |
|
set scheme_received 1; #so we know not to override caller's explicit choice |
|
} |
|
set querycommand [dict get $values commandpath] |
|
set queryargs [dict get $values subcommand] |
|
set opt_grepstr [dict get $opts -grepstr] |
|
set opt_form [dict get $opts -form] |
|
set opt_return [dict get $opts -return] |
|
switch -- $opt_return { |
|
string { |
|
set estyle "basic" |
|
} |
|
tableobject { |
|
set estyle "minimal" |
|
} |
|
default { |
|
set estyle "standard" |
|
} |
|
} |
|
set nextopts [dict remove $opts -grepstr] |
|
#JJJ |
|
set whichinfo [uplevel 1 [list ::punk::ns::cmdwhich $querycommand]] |
|
set rootorigin [dict get $whichinfo origin] |
|
set which [dict get $whichinfo which] |
|
set rootorigintype [dict get $whichinfo origintype] |
|
set whichtype [dict get $whichinfo whichtype] |
|
|
|
|
|
set rootinfo [uplevel 1 [list ::punk::ns::cmdinfo $which]] |
|
set rootdoc [dict get $rootinfo docid] |
|
#NOTE - we can get 'args_remaining' due to cmdinfo resolving to a curried alias target |
|
set args_remaining [dict get $rootinfo args_remaining] |
|
if {$rootdoc ne ""} { |
|
if {$whichtype eq "alias"} { |
|
#test if we could resolve further |
|
set testinfo [punk::ns::cmdinfo $querycommand {*}$queryargs] |
|
set testresolved [dict get $testinfo args_resolved] |
|
if {[llength $testresolved] == 1} { |
|
#only the command itself is in the args_resolved list - so we can't resolve to a deeper subcommand |
|
ledit queryargs -1 -1 {*}$args_remaining ;#prepend |
|
if {[catch {punk::args::parse $queryargs -form $opt_form -errorstyle $estyle withid $rootdoc} parseresult]} { |
|
if {$opt_return eq "tableobject"} { |
|
set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0] |
|
} else { |
|
set result $parseresult |
|
} |
|
} else { |
|
#show usage - with goodargs marked |
|
if {!$scheme_received} { |
|
dict set nextopts -scheme info |
|
} |
|
set result [punk::args::arg_error "" [punk::args::get_spec $rootdoc] {*}$nextopts -aserror 0 -parsedargs $parseresult] |
|
} |
|
if {$opt_grepstr ne ""} { |
|
if {[llength $opt_grepstr] == 1} { |
|
set result [punk::ansi::grepstr --ignore-case -returnlines all [lindex $opt_grepstr 0] $result] |
|
} else { |
|
set result [punk::ansi::grepstr --ignore-case -returnlines all -highlight [lrange $opt_grepstr 1 end] [lindex $opt_grepstr 0] $result] |
|
} |
|
} |
|
return $result |
|
} |
|
} |
|
} |
|
|
|
#----------------------------------------------------------------------------------------------------------------------------- |
|
#review! |
|
#only divert to target script/alias if rootorigin undocumented |
|
#if we were to jump straight to the alias or script target - we preclude the opportunity |
|
#to lookup any user documentation that was specifically supplied for the alias at $which !!! |
|
|
|
switch -- $rootorigintype { |
|
script { |
|
#assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block |
|
set scriptargs [lrange $rootorigin 1 end] ;#arguments that were curried into the alias script |
|
set scriptcmd [lindex $rootorigin 0] |
|
set nextqueryargs [list {*}$scriptargs {*}$queryargs] |
|
#puts stderr "cmdhelp $nextopts $scriptcmd $nextqueryargs" |
|
return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts $scriptcmd {*}$nextqueryargs]] |
|
} |
|
alias { |
|
#e.g alias to an alias |
|
#JJJ2 |
|
#puts "JJJ2 rootorigin:$rootorigin" |
|
if {[string match >* [nstail $rootorigin]] && [package provide pattern] ne ""} { |
|
if {![catch {pattern::which_alias $rootorigin} alias_target]} { |
|
#review - todo? |
|
set targetcmd [lindex $alias_target 0] |
|
set queryargs [list {*}[lrange $alias_target 1 end] {*}$queryargs] |
|
return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts {*}$targetcmd {*}$queryargs]] |
|
} |
|
} |
|
if {$which eq $rootorigin} { |
|
#origin points to self which is an alias - can happen if an alias has been renamed |
|
} else { |
|
return [uplevel 1 [list punk::ns::cmdhelp {*}$nextopts {*}$rootorigin {*}$queryargs]] |
|
} |
|
} |
|
} |
|
#----------------------------------------------------------------------------------------------------------------------------- |
|
|
|
#puts "-----> rootorigin $rootorigin queryargs $queryargs" |
|
set cinfo [uplevel 1 [list ::punk::ns::cmdinfo $rootorigin {*}$queryargs]] |
|
|
|
|
|
set origin [dict get $cinfo origin] |
|
set origindoc [dict get $cinfo docid] |
|
set args_remaining [dict get $cinfo args_remaining] |
|
set origintype [dict get $cinfo cmdtype] |
|
|
|
switch -- $origintype { |
|
script { |
|
#assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block |
|
set scriptargs [lrange $origin 1 end] ;#arguments that were curried into the alias script |
|
set scriptcmd [lindex $origin 0] |
|
set nextqueryargs [list {*}$scriptargs {*}$args_remaining] |
|
#puts stderr "cmdhelp $nextopts $scriptcmd $args_remaining" |
|
return [uplevel 1 [list ::punk::ns::cmdhelp {*}$nextopts $scriptcmd {*}$nextqueryargs]] |
|
} |
|
} |
|
if {$origindoc ne ""} { |
|
#important not to use "-cache 1" for this parse - need to reflect dynamically updated ensembles etc |
|
if {[catch {punk::args::parse $args_remaining -cache 0 -form $opt_form -errorstyle $estyle withid $origindoc} parseresult]} { |
|
if {$opt_return eq "tableobject"} { |
|
set result [punk::args::arg_error "$parseresult" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0] |
|
} else { |
|
set result $parseresult |
|
} |
|
} else { |
|
#show usage - with goodargs marked |
|
if {!$scheme_received} { |
|
dict set nextopts -scheme info |
|
} |
|
set result [punk::args::arg_error "" [punk::args::get_spec $origindoc] {*}$nextopts -aserror 0 -parsedargs $parseresult] |
|
} |
|
if {$opt_grepstr ne ""} { |
|
if {[llength $opt_grepstr] == 1} { |
|
set result [punk::ansi::grepstr --ignore-case -returnlines all [lindex $opt_grepstr 0] $result] |
|
} else { |
|
set result [punk::ansi::grepstr --ignore-case -returnlines all -highlight [lrange $opt_grepstr 1 end] [lindex $opt_grepstr 0] $result] |
|
} |
|
} |
|
return $result |
|
} else { |
|
return "Undocumented command $origin. Type: $origintype" |
|
} |
|
|
|
#return [cmdinfo $origin {*}$queryargs] |
|
} |
|
|
|
|
|
|
|
#todo - -cache or -refresh to configure whether we introspect ensembles/objects each time? |
|
# - as this is interactive generally introspection should be ok at the top level |
|
# but if we need to go down multiple levels of subcommands generating/testing prefixes - could be an issue ?? |
|
#TODO - make obsolete - (replaced by punk::ns::cmdhelp) |
|
#punk::args::define { |
|
# @dynamic |
|
# @id -id ::punk::ns::arginfo |
|
# @cmd -name punk::ns::arginfo\ |
|
# -summary\ |
|
# "Command usage/help."\ |
|
# -help\ |
|
# "Show usage info for a command. |
|
# It supports the following: |
|
# 1) Procedures or builtins for which a punk::args definition has |
|
# been loaded. |
|
# 2) tepam procedures (returns string form only) |
|
# 3) ensemble commands - auto-generated unless documented via punk::args |
|
# (subcommands will show with an indicator if they are |
|
# explicitly documented or are themselves ensembles) |
|
# 4) tcl::oo objects - auto-gnerated unless documented via punk::args |
|
# 5) dereferencing of aliases to find underlying command |
|
# (will not work with some renamed aliases) |
|
|
|
# Note that native commands commands not explicitly documented will |
|
# generally produce no useful info. For example sqlite3 dbcmd objects |
|
# could theoretically be documented - but as 'info cmdtype' just shows |
|
# 'native' they can't (?) be identified as belonging to sqlite3 without |
|
# calling them. arginfo deliberately avoids calling commands to elicit |
|
# usage information as this is inherently risky. (could create a file, |
|
# exit the interp etc) |
|
# " |
|
# -return -type string -default table -choices {string table tableobject} |
|
|
|
|
|
# } {${[punk::args::resolved_def -types opts ::punk::args::arg_error -scheme]}} { |
|
# -form -default 0 -help\ |
|
# "Ordinal index or name of command form" |
|
# -grepstr -default "" -type list -typesynopsis regex -help\ |
|
# "list consisting of regex, optionally followed by ANSI names for highlighting |
|
# (incomplete - todo)" |
|
# -- -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, ensemble, tcl::oo object, tepam proc etc)" |
|
# 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::parse $args withid ::punk::ns::arginfo]] leaders opts values received |
|
# set nscaller [uplevel 1 [list ::namespace current]] |
|
# #review - setting this afterwards is an architecture smell - we should be able to override the default in the dynamic part |
|
# #todo - enable retrieving by id just the record_opts part - so we can treat as a dict directly, as well as easily apply it as a different flag name. |
|
# if {![dict exists $received -scheme]} { |
|
# #dict set opts -scheme info |
|
# set scheme_received 0 |
|
# } else { |
|
# set scheme_received 1; #so we know not to override caller's explicit choice |
|
# } |
|
|
|
# set querycommand [dict get $values commandpath] |
|
# set queryargs [dict get $values subcommand] |
|
# set grepstr [dict get $opts -grepstr] |
|
# set opts [dict remove $opts -grepstr] |
|
# #puts stdout "---------------------arginfo: '$args' querycommand:'$querycommand' queryargs:'$queryargs'" |
|
|
|
# #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 |
|
|
|
# set cinfo [uplevel 1 [list cmdwhich $querycommand]] |
|
# set origin [dict get $cinfo origin] |
|
# set resolved [dict get $cinfo which] |
|
# set cmdtype [dict get $cinfo origintype] |
|
# switch -- $cmdtype { |
|
# script { |
|
# #assumed to be an 'alias' script - ie proper list - not an arbitrary tcl code block |
|
# set scriptargs [lrange $origin 1 end] ;#arguments that were curried into the alias script |
|
# set origin [lindex $origin 0] |
|
# set queryargs [list {*}$scriptargs {*}$queryargs] |
|
# return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] |
|
# } |
|
# alias { |
|
# #alias to an alias |
|
# return [uplevel 1 [list punk::ns::arginfo {*}$opts $origin {*}$queryargs]] |
|
# } |
|
# } |
|
|
|
# #JJJ |
|
# #check for a direct match first |
|
# if {![llength $queryargs]} { |
|
# #puts stderr "---->arginfo '$args' update_definitions [list [namespace qualifiers $origin]]" |
|
# punk::args::update_definitions [list [namespace qualifiers $origin]] ;#update_definitions will treat empty string as global ns :: |
|
# if {![punk::args::id_exists $origin] && ![punk::args::id_exists (autodef)$origin]} { |
|
# uplevel 1 [list punk::ns::generate_autodef $origin] |
|
# } |
|
|
|
# if {[punk::args::id_exists (autodef)$origin]} { |
|
# set origin (autodef)$origin |
|
# } |
|
# if {[punk::args::id_exists $origin]} { |
|
# switch -- [dict get $opts -return] { |
|
# string { |
|
# set estyle "basic" |
|
# } |
|
# tableobject { |
|
# set estyle "minimal" |
|
# } |
|
# default { |
|
# set estyle "standard" |
|
# } |
|
# } |
|
# if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { |
|
# if {[dict get $opts -return] eq "tableobject"} { |
|
# return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] |
|
# } else { |
|
# return $parseresult |
|
# } |
|
# } else { |
|
# if {!$scheme_received} { |
|
# dict set opts -scheme info |
|
# } |
|
# return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] |
|
# } |
|
# } |
|
# } |
|
|
|
|
|
# set id $origin |
|
# #puts stderr "____>arginfo '$args' update_definitions [list [namespace qualifiers $id]]" |
|
# punk::args::update_definitions [list [namespace qualifiers $id]] |
|
|
|
|
|
# #check longest first checking for id matching ::cmd ?subcmd..? |
|
# #REVIEW - this doesn't cater for prefix callable subcommands |
|
# if {[llength $queryargs]} { |
|
# if {[punk::args::id_exists [list $id {*}$queryargs]]} { |
|
# switch -- [dict get $opts -return] { |
|
# string { |
|
# set estyle "basic" |
|
# } |
|
# tableobject { |
|
# set estyle "minimal" |
|
# } |
|
# default { |
|
# set estyle "standard" |
|
# } |
|
# } |
|
# if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid [list $id {*}$queryargs]} parseresult]} { |
|
# if {[dict get $opts -return] eq "tableobject"} { |
|
# return [punk::args::arg_error "$parseresult" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0] |
|
# } else { |
|
# return $parseresult |
|
# } |
|
# } else { |
|
# if {!$scheme_received} { |
|
# dict set opts -scheme info |
|
# } |
|
# return [punk::args::arg_error "" [punk::args::get_spec [list $id {*}$queryargs]] {*}$opts -aserror 0 -parsedargs $parseresult] |
|
# #return [uplevel 1 [list punk::args::usage {*}$opts [list $id {*}$queryargs]]] |
|
# } |
|
# } |
|
# } |
|
|
|
# #didn't find any exact matches |
|
# #traverse from other direction taking prefixes into account |
|
# set specid "" |
|
# if {[punk::args::id_exists $id]} { |
|
# set specid $id |
|
# } elseif {[punk::args::id_exists (autodef)$id]} { |
|
# set specid (autodef)$id |
|
# } |
|
|
|
# if {$specid ne "" && [punk::args::id_exists $specid]} { |
|
# #cycle forward through leading values |
|
# set specargs $queryargs |
|
# if {[llength $queryargs]} { |
|
# #jjj |
|
# set spec [punk::args::get_spec $specid] |
|
# #--------------------------------------------------------------------------- |
|
# set form_names [dict get $spec form_names] |
|
# if {[llength $form_names] == 1} { |
|
# set fid [lindex $form_names 0] |
|
# } else { |
|
# #review - -form only applies to final command? |
|
# # -form must be a list if we have multiple levels of multi-form commands? |
|
# set opt_form [dict get $opts -form] |
|
# if {[string is integer -strict $opt_form]} { |
|
# if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { |
|
# error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" |
|
# } |
|
# set fid [lindex $form_names $opt_form] |
|
# } else { |
|
# if {$opt_form ni $form_names} { |
|
# error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" |
|
# } |
|
# set fid $opt_form |
|
# } |
|
# } |
|
# #--------------------------------------------------------------------------- |
|
# set nextqueryargs [list] ;#build a list of prefix-resolved queryargs |
|
# set queryargs_untested $queryargs |
|
# foreach q $queryargs { |
|
# if {[llength [dict get $spec FORMS $fid LEADER_NAMES]]} { |
|
# #todo: fix |
|
# set subitems [dict get $spec FORMS $fid LEADER_NAMES] |
|
# if {[llength $subitems]} { |
|
# set next [lindex $subitems 0] |
|
# set arginfo [dict get $spec FORMS $fid ARG_INFO $next] |
|
|
|
# set allchoices [list] |
|
# set choices [punk::args::system::Dict_getdef $arginfo -choices {}] |
|
# set choicegroups [punk::args::system::Dict_getdef $arginfo -choicegroups {}] |
|
# #maintenance smell - similar/dup of some punk::args logic - review |
|
# #-choiceprefixdenylist ?? |
|
# set choiceprefixreservelist [punk::args::system::Dict_getdef $arginfo -choiceprefixreservelist {}] |
|
# if {[dict exists $choicegroups ""]} { |
|
# dict lappend choicegroups "" {*}$choices |
|
# } else { |
|
# set choicegroups [dict merge [dict create "" $choices] $choicegroups] |
|
# } |
|
# dict for {groupname clist} $choicegroups { |
|
# lappend allchoices {*}$clist |
|
# } |
|
# set resolved_q [tcl::prefix::match -error "" [list {*}$allchoices {*}$choiceprefixreservelist] $q] |
|
# if {$resolved_q eq "" || $resolved_q in $choiceprefixreservelist} { |
|
# break |
|
# } |
|
# lappend nextqueryargs $resolved_q |
|
# lpop queryargs_untested 0 |
|
# #ledit queryargs_untested 0 0 |
|
# if {$resolved_q ne $q} { |
|
# #we have our first difference - recurse with new query args |
|
# #set numvals [expr {[llength $queryargs]+1}] |
|
# #return [ punk::ns::arginfo {*}[lrange $args 0 end-$numvals] $querycommand {*}$nextqueryargs {*}$queryargs_untested] |
|
# #puts "===> testing arginfo {*}$opts $querycommand {*}$nextqueryargs {*}$queryargs_untested" |
|
# if {!$scheme_received} { |
|
# dict unset opts -scheme |
|
# } |
|
# return [ punk::ns::arginfo {*}$opts {*}$specid {*}$nextqueryargs {*}$queryargs_untested] |
|
|
|
# } |
|
# #check if subcommands so far have a custom args def |
|
# #set currentid [list $querycommand {*}$nextqueryargs] |
|
# set currentid [list {*}$specid {*}$nextqueryargs] |
|
# if {[punk::args::id_exists $currentid]} { |
|
# set spec [punk::args::get_spec $currentid] |
|
# #--------------------------------------------------------------------------- |
|
# set form_names [dict get $spec form_names] |
|
# if {[llength $form_names] == 1} { |
|
# set fid [lindex $form_names 0] |
|
# } else { |
|
# #review - -form only applies to final command? |
|
# # -form must be a list if we have multiple levels of multi-form commands? |
|
# set opt_form [dict get $opts -form] |
|
# if {[string is integer -strict $opt_form]} { |
|
# if {$opt_form < 0 || $opt_form > [llength $form_names]-1} { |
|
# error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" |
|
# } |
|
# set fid [lindex $form_names $opt_form] |
|
# } else { |
|
# if {$opt_form ni $form_names} { |
|
# error "punk::ns::arginfo invalid -form $opt_form expected int 0-[expr {[llength $form_names]-1}] or one of '$form_names'" |
|
# } |
|
# set fid $opt_form |
|
# } |
|
# } |
|
# #--------------------------------------------------------------------------- |
|
# set specid $currentid |
|
# set specargs $queryargs_untested |
|
# set nextqueryargs [list] |
|
# } else { |
|
# #We can get no further with custom defs |
|
# #It is possible we have a documented lower level subcommand but missing the intermediate |
|
# #e.g if ::trace remove command was specified and is documented - it will be found above |
|
# #but if ::trace remove is not documented and the query is "::trace remove com" |
|
# #There is no way to determine com is a prefix as we don't have the intermediate documented -choice info available. |
|
# #that's probably ok. |
|
# break |
|
# } |
|
# } |
|
# } else { |
|
# #review |
|
# break |
|
# } |
|
# } |
|
# } else { |
|
# switch -- [dict get $opts -return] { |
|
# string { |
|
# set estyle "basic" |
|
# } |
|
# tableobject { |
|
# set estyle "minimal" |
|
# } |
|
# default { |
|
# set estyle "standard" |
|
# } |
|
# } |
|
# if {[catch {punk::args::parse {} -form [dict get $opts -form] -errorstyle $estyle withid $id} parseresult]} { |
|
# if {[dict get $opts -return] eq "tableobject"} { |
|
# return [punk::args::arg_error "$parseresult" [punk::args::get_spec $id] {*}$opts -aserror 0] |
|
# } else { |
|
# return $parseresult |
|
# } |
|
# } else { |
|
# if {!$scheme_received} { |
|
# dict set opts -scheme info |
|
# } |
|
# return [punk::args::arg_error "" [punk::args::get_spec $id] {*}$opts -aserror 0 -parsedargs $parseresult] |
|
# #return [uplevel 1 [list punk::args::usage {*}$opts $id]] |
|
# } |
|
# } |
|
# #puts "--->origin $specid queryargs: $specargs" |
|
# set origin $specid |
|
# set queryargs $specargs |
|
# } |
|
|
|
# if {[string match "(autodef)*" $origin]} { |
|
# #wasn't resolved by id - so take this as a request to generate it (probably there is an existing custom def - and this has been manually requested to get the default) |
|
# set origin [string range $origin [string length (autodef)] end] |
|
# set resolved $origin |
|
# } |
|
|
|
# set autoid "" |
|
# 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 $queryargs]} { |
|
# set c1 [lindex $queryargs 0] |
|
# if {$c1 in $public_methods} { |
|
# switch -- $c1 { |
|
# new { |
|
# set constructorinfo [info class constructor $origin] |
|
# set arglist [lindex $constructorinfo 0] |
|
# set argdef [punk::lib::tstr -return string { |
|
# @id -id "(autodef)${$origin} new" |
|
# @cmd -name "${$origin} new"\ |
|
# -summary\ |
|
# "Create new object instance."\ |
|
# -help\ |
|
# "create object with autogenerated 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 argdef \n "args -optional 1 -multiple 1" |
|
# } else { |
|
# append argdef \n "$a" |
|
# } |
|
# } else { |
|
# append argdef \n "[lindex $a 0] -default [lindex $a 1]" |
|
# } |
|
# incr i |
|
# } |
|
# punk::args::define $argdef |
|
# set queryargs_remaining [lrange $queryargs 1 end] |
|
# switch -- [dict get $opts -return] { |
|
# string { |
|
# set estyle "basic" |
|
# } |
|
# tableobject { |
|
# set estyle "minimal" |
|
# } |
|
# default { |
|
# set estyle "standard" |
|
# } |
|
# } |
|
# if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin new"} parseresult]} { |
|
# if {[dict get $opts -return] eq "tableobject"} { |
|
# return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0] |
|
# } else { |
|
# return $parseresult |
|
# } |
|
# } else { |
|
# if {!$scheme_received} { |
|
# dict set opts -scheme info |
|
# } |
|
# return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin new"] {*}$opts -aserror 0 -parsedargs $parseresult] |
|
# #return [punk::args::usage {*}$opts "(autodef)$origin new"] |
|
# } |
|
# } |
|
# create { |
|
# set constructorinfo [info class constructor $origin] |
|
# set arglist [lindex $constructorinfo 0] |
|
# set argdef [punk::lib::tstr -return string { |
|
# @id -id "(autodef)${$origin} create" |
|
# @cmd -name "${$origin} create"\ |
|
# -summary\ |
|
# "Create new object instance with specified command name."\ |
|
# -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 argdef \n "args -optional 1 -multiple 1" |
|
# } else { |
|
# append argdef \n "$a" |
|
# } |
|
# } else { |
|
# append argdef \n "[lindex $a 0] -default [lindex $a 1]" |
|
# } |
|
# incr i |
|
# } |
|
# punk::args::define $argdef |
|
# set queryargs_remaining [lrange $queryargs 1 end] |
|
# switch -- [dict get $opts -return] { |
|
# string { |
|
# set estyle "basic" |
|
# } |
|
# tableobject { |
|
# set estyle "minimal" |
|
# } |
|
# default { |
|
# set estyle "standard" |
|
# } |
|
# } |
|
# if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin create"} parseresult]} { |
|
# if {[dict get $opts -return] eq "tableobject"} { |
|
# return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0] |
|
# } else { |
|
# return $parseresult |
|
# } |
|
# } else { |
|
# if {!$scheme_received} { |
|
# dict set opts -scheme info |
|
# } |
|
# return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin create"] {*}$opts -aserror 0 -parsedargs $parseresult] |
|
# #return [punk::args::usage {*}$opts "(autodef)$origin create"] |
|
# } |
|
# } |
|
# destroy { |
|
# #review - generally no doc |
|
# # but we may want notes about a specific destructor |
|
# set argdef [punk::lib::tstr -return string { |
|
# @id -id "(autodef)${$origin} destroy" |
|
# @cmd -name "destroy"\ |
|
# -summary\ |
|
# "delete object instance."\ |
|
# -help\ |
|
# "delete object, calling destructor if any. |
|
# destroy accepts no arguments." |
|
# @values -min 0 -max 0 |
|
# }] |
|
# punk::args::define $argdef |
|
# set queryargs_remaining [lrange $queryargs 1 end] |
|
# switch -- [dict get $opts -return] { |
|
# string { |
|
# set estyle "basic" |
|
# } |
|
# tableobject { |
|
# set estyle "minimal" |
|
# } |
|
# default { |
|
# set estyle "standard" |
|
# } |
|
# } |
|
# if {[catch {punk::args::parse $queryargs_remaining -form [dict get $opts -form] -errorstyle $estyle withid "(autodef)$origin destroy"} parseresult]} { |
|
# if {[dict get $opts -return] eq "tableobject"} { |
|
# return [punk::args::arg_error "$parseresult" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0] |
|
# } else { |
|
# return $parseresult |
|
# } |
|
# } else { |
|
# if {!$scheme_received} { |
|
# dict set opts -scheme info |
|
# } |
|
# return [punk::args::arg_error "" [punk::args::get_spec "(autodef)$origin destroy"] {*}$opts -aserror 0 -parsedargs $parseresult] |
|
# #return [punk::args::usage {*}$opts "(autodef)$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 oodef "" |
|
# foreach impl $implementations { |
|
# lassign $impl generaltype mname location methodtype |
|
# switch -- $generaltype { |
|
# method - private { |
|
# #objects being dynamic systems - we should always reinspect. |
|
# #Don't use the cached (autodef) def |
|
# #If there is a custom def override - use it (should really be -dynamic - but we don't check) |
|
# if {$location eq "object"} { |
|
# set idcustom "$origin $c1" |
|
# #set id "[string trimleft $origin :] $c1" ;# "<object> <method>" |
|
# if {[info commands ::punk::args::id_exists] ne ""} { |
|
# if {[punk::args::id_exists $idcustom]} { |
|
# return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] |
|
# } |
|
# } |
|
# set oodef [::info object definition $origin $c1] |
|
# } else { |
|
# #set id "[string trimleft $location :] $c1" ;# "<class> <method>" |
|
# set idcustom "$location $c1" |
|
# if {[info commands ::punk::args::id_exists] ne ""} { |
|
# if {[punk::args::id_exists $idcustom]} { |
|
# return [uplevel 1 [list punk::args::usage {*}$opts $idcustom]] |
|
# } |
|
# } |
|
# set oodef [::info class definition $location $c1] |
|
# } |
|
# break |
|
# } |
|
# filter { |
|
# } |
|
# unknown { |
|
# } |
|
# } |
|
# } |
|
# if {$oodef ne ""} { |
|
# set autoid "(autodef)$location $c1" |
|
# set arglist [lindex $oodef 0] |
|
# set argdef [punk::lib::tstr -return string { |
|
# @id -id "${$autoid}" |
|
# @cmd -name "${$location} ${$c1}" -help\ |
|
# "(autogenerated by arginfo) |
|
# arglist:${$arglist}" |
|
# @values |
|
# }] |
|
# set i 0 |
|
# #for 9.1+ can use -integer |
|
# foreach a $arglist { |
|
# switch -- [llength $a] { |
|
# 1 { |
|
# if {$i == [llength $arglist]-1 && $a eq "args"} { |
|
# #'args' is only special if last |
|
# append argdef \n "args -optional 1 -multiple 1" |
|
# } else { |
|
# append argdef \n "$a" |
|
# } |
|
# } |
|
# 2 { |
|
# append argdef \n "[lindex $a 0] -default {[lindex $a 1]} -optional 1" |
|
# } |
|
# default { |
|
# error "punk::ns::arginfo unexpected oo argument signature '$arglist'\noodef:$oodef\nimplementations:$implementations" |
|
# } |
|
# } |
|
# incr i |
|
# } |
|
# punk::args::define $argdef |
|
# return [punk::args::usage {*}$opts $autoid] |
|
# } else { |
|
# return "unable to resolve $origin method $c1" |
|
# } |
|
|
|
# } |
|
# } |
|
# } |
|
# } |
|
# set choicelabeldict [dict create] |
|
# set choiceinfodict [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" || $location eq $origin} { |
|
# #set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" |
|
# set id "$origin $cmd" |
|
# dict set choiceinfodict $cmd {{doctype objectmethod}} |
|
# } elseif {$location eq $class} { |
|
# set id "$class $cmd" |
|
# dict set choiceinfodict $cmd {{doctype classmethod}} |
|
# } else { |
|
# #set id "[string trimleft $location :] $cmd" ;# "<class> <method>" |
|
# set id "$location $cmd" |
|
# if {[string match "core method:*" $methodtype]} { |
|
# dict lappend choiceinfodict $cmd {doctype coremethod} |
|
# } else { |
|
# dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] |
|
# } |
|
# } |
|
# if {[punk::args::id_exists $id]} { |
|
# #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" |
|
# dict lappend choiceinfodict $cmd {doctype punkargs} |
|
# dict lappend choiceinfodict $cmd [list subhelp {*}$id] |
|
# } |
|
# break |
|
# } |
|
# filter { |
|
# } |
|
# unknown { |
|
# dict set choiceinfodict $cmd {{doctype unknown}} |
|
# } |
|
# } |
|
# } |
|
# } |
|
# } |
|
# } |
|
|
|
# set vline [list method -choices $public_methods -choicelabels $choicelabeldict -choiceinfo $choiceinfodict -choiceprefix 0] ;#methods must be specified in full always? - review |
|
# #puts stderr "--->$vline" |
|
# set autoid "(autodef)$origin" |
|
# set argdef [punk::lib::tstr -return string { |
|
# @id -id ${$autoid} |
|
# @cmd -name "Object: ${$origin}" -help\ |
|
# "Instance of class: ${$class} (info autogenerated)" |
|
# @leaders -min 1 |
|
# }] |
|
# append argdef \n $vline |
|
# punk::args::define $argdef |
|
|
|
# } |
|
# privateObject { |
|
# return "Command is a privateObject - no info currently available" |
|
# } |
|
# privateClass { |
|
# return "Command is a privateClass - no info currently available" |
|
# } |
|
# interp { |
|
# #todo |
|
# } |
|
# script { |
|
# #todo |
|
# } |
|
# ensemble { |
|
# #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 parameters [dict get $ensembleinfo -parameters] |
|
# 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 $queryargs]} { |
|
# set posn_subcommand [llength $parameters];#ensemble may have '-parameters' list specified - parameters that come before the subcommand |
|
# if {$posn_subcommand > 0} { |
|
# set params [lrange $queryargs 0 $posn_subcommand-1] |
|
# set remaining_queryargs [lrange $queryargs $posn_subcommand end] |
|
# } else { |
|
# set params [list] |
|
# set remaining_queryargs $queryargs |
|
# } |
|
# if {[llength $remaining_queryargs]} { |
|
# if {$prefixes} { |
|
# set match [tcl::prefix::match -error {} $subcommands [lindex $remaining_queryargs 0]] |
|
# } else { |
|
# set match [lindex $remaining_queryargs 0] |
|
# } |
|
# if {$match in $subcommands} { |
|
# set subcmd [dict get $subcommand_dict $match] |
|
# #return [arginfo {*}$subcmd {*}[lrange $queryargs 1 end]] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") |
|
# if {!$scheme_received} { |
|
# dict unset opts -scheme |
|
# } |
|
# #return [arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end]] |
|
# #use tailcall so %caller% is reported properly in error msg |
|
# tailcall arginfo {*}$opts {*}$subcmd {*}$params {*}[lrange $remaining_queryargs 1 end] ;#subcmd is sometimes multiple words (implemented as a further ensemble subcommand) (e.g huddle string -> "Type_string string") |
|
# } |
|
# } |
|
# } |
|
|
|
# #todo - synopsis? |
|
# set choicelabeldict [dict create] |
|
|
|
# set choiceinfodict [dict create] |
|
|
|
# dict for {sub subwhat} $subcommand_dict { |
|
# if {[llength $subwhat] > 1} { |
|
# #TODO - resolve using cmdinfo? |
|
# puts stderr "arginfo warning: subcommand $sub points to multiword target $subwhat - TODO" |
|
# } |
|
# set targetfirstword [lindex $subwhat 0] |
|
# set targetinfo [cmdwhich $targetfirstword] |
|
# set targetorigin [dict get $targetinfo origin] |
|
# set targetcmdtype [dict get $targetinfo origintype] |
|
# set nstarget [nsprefix $targetorigin] |
|
|
|
# dict lappend choiceinfodict $sub [list doctype $targetcmdtype] |
|
|
|
# if {[punk::args::id_exists [list $origin $sub]]} { |
|
# dict lappend choiceinfodict $sub {doctype punkargs} |
|
# dict lappend choiceinfodict $sub [list subhelp {*}$origin $sub] |
|
# } elseif {[punk::args::id_exists $targetorigin]} { |
|
# dict lappend choiceinfodict $sub {doctype punkargs} |
|
# dict lappend choiceinfodict $sub [list subhelp {*}$targetorigin] |
|
# } else { |
|
# #puts stderr "arginfo ensemble--- NO doc for [list $origin $sub] or $origin" |
|
# } |
|
|
|
# } |
|
|
|
# set vline [list subcommand -choices $subcommands -choiceprefix $prefixes -choicelabels $choicelabeldict -choiceinfo $choiceinfodict] |
|
# set autoid "(autodef)$origin" |
|
# puts "ENSEMBLE auto def $autoid (arginfo)" |
|
# set argdef [punk::lib::tstr -return string { |
|
# @id -id ${$autoid} |
|
# @cmd -help\ |
|
# "(autogenerated by arginfo) |
|
# ensemble: ${$origin}" |
|
# }] |
|
# if {[llength $parameters] == 0} { |
|
# append argdef \n "@leaders -min 1" |
|
# } else { |
|
# append argdef \n "@leaders -min [expr {[llength $parameters]+1}]" |
|
# foreach p $parameters { |
|
# append argdef \n "$p -type string -help { (leading ensemble parameter)}" |
|
# } |
|
# } |
|
# append argdef \n "@values -unnamed true" |
|
# append argdef \n $vline |
|
# punk::args::define $argdef |
|
# } |
|
# } |
|
|
|
# #if {$autoid ne ""} { |
|
# # return [punk::args::usage {*}$opts $autoid] |
|
# #} |
|
|
|
|
|
# #check ensemble before testing punk::arg::id_exists |
|
# #we want to recalculate ensemble usage info in case ensemble has been modified |
|
|
|
# if {$autoid ne ""} { |
|
# switch -- [dict get $opts -return] { |
|
# string { |
|
# set estyle "basic" |
|
# } |
|
# tableobject { |
|
# set estyle "minimal" |
|
# } |
|
# default { |
|
# set estyle "standard" |
|
# } |
|
# } |
|
# if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $autoid} parseresult]} { |
|
# # parsing error e.g Bad number of leading values |
|
# #override -scheme in opts with -scheme error |
|
# if {[dict get $opts -return] eq "tableobject"} { |
|
# return [punk::args::arg_error "$parseresult" [punk::args::get_spec $autoid] {*}$opts -aserror 0] |
|
# } else { |
|
# return $parseresult |
|
# } |
|
# } else { |
|
# #show usage - with goodargs marked |
|
# #return [punk::args::arg_error "" [punk::args::get_spec $autoid] -scheme info -aserror 0 {*}$opts -parsedargs $parseresult] |
|
# if {!$scheme_received} { |
|
# dict set opts -scheme info |
|
# } |
|
# return [punk::args::arg_error "" [punk::args::get_spec $autoid] {*}$opts -aserror 0 -parsedargs $parseresult] |
|
# } |
|
# #return [punk::args::usage {*}$opts $autoid] |
|
# } |
|
|
|
# #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 origin_ns [nsprefix $origin] |
|
# set parts [nsparts_cached $origin_ns] |
|
# set weird_ns 0 |
|
# if {[lsearch $parts :*] >=0} { |
|
# set weird_ns 1 |
|
# } |
|
# if {$weird_ns} { |
|
# set argl {} |
|
# set tail [nstail $origin] |
|
# set cmdtype [nseval_ifexists $origin_ns [list punk::ns::cmdtype $tail]] |
|
# if {$cmdtype eq "proc"} { |
|
# 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 cmdtype [punk::ns::cmdtype $origin] |
|
# if {$cmdtype eq "proc"} { |
|
# set argl {} |
|
# set infoargs [info args $origin] |
|
# foreach a $infoargs { |
|
# if {[info default $origin $a def]} { |
|
# lappend a $def |
|
# } |
|
# lappend argl $a |
|
# } |
|
# } |
|
# } |
|
|
|
# if {[llength $queryargs]} { |
|
# #todo - something better ? |
|
# switch -- [dict get $opts -return] { |
|
# string { |
|
# set estyle "basic" |
|
# } |
|
# tableobject { |
|
# set estyle "minimal" |
|
# } |
|
# default { |
|
# set estyle "standard" |
|
# } |
|
# } |
|
|
|
# if {[punk::args::id_exists $origin]} { |
|
# if {[catch {punk::args::parse $queryargs -form [dict get $opts -form] -errorstyle $estyle withid $origin} parseresult]} { |
|
# if {[dict get $opts -return] eq "tableobject"} { |
|
# return [punk::args::arg_error "$parseresult" [punk::args::get_spec $origin] {*}$opts -aserror 0] |
|
# } else { |
|
# return $parseresult |
|
# } |
|
# } else { |
|
# #show usage - with goodargs marked |
|
# if {!$scheme_received} { |
|
# dict set opts -scheme info |
|
# } |
|
# return [punk::args::arg_error "" [punk::args::get_spec $origin] {*}$opts -aserror 0 -parsedargs $parseresult] |
|
# } |
|
# } |
|
# set msg "Undocumented or nonexistant command $origin $queryargs" |
|
# append msg \n "$origin Type: $cmdtype" |
|
# } else { |
|
# if {$cmdtype eq "proc"} { |
|
# set msg "Undocumented proc $origin" |
|
# append msg \n "No argument processor detected" |
|
# append msg \n "function signature: $resolved $argl" |
|
# } else { |
|
# set msg "Undocumented command $origin. Type: $cmdtype" |
|
# } |
|
# } |
|
# if {[llength $grepstr] != 0} { |
|
# if {[llength $grepstr] == 1} { |
|
# return [punk::ansi::grepstr -no-linenumbers -highlight red [lindex $grepstr 0] $msg] |
|
# } else { |
|
# return [punk::ansi::grepstr -no-linenumbers -highlight [lrange $grepstr 1 end] [lindex $grepstr 0] $msg] |
|
# } |
|
# } |
|
# return $msg |
|
#} |
|
|
|
#todo - package up as navns |
|
namespace eval argdoc { |
|
variable PUNKARGS |
|
lappend PUNKARGS [list { |
|
@id -id ::punk::ns::corp |
|
@cmd -name punk::ns::corp\ |
|
-summary\ |
|
"Show alias info or proc body/args"\ |
|
-help\ |
|
"Show alias or proc information. |
|
'corp' (being the reverse spelling of proc) |
|
will display the Tcl 'proc name args body' statement |
|
for the proc. |
|
Essentially this is a convenient way to display the |
|
proc body including argument info, instead of |
|
separately calling 'info args <proc>' 'info body <proc>' |
|
etc. |
|
The body may display with an additional |
|
comment inserted to display information such as the |
|
namespace origin. Such a comment begins with #corp#. |
|
|
|
Returns a list: proc <procname> <arglist> <body> |
|
(as long as any syntax highlighter is written to |
|
avoid breaking the structure. e.g by avoiding the |
|
insertion of ANSI between an escaping backslash and |
|
its target character) |
|
If the output is to be used as a script to regenerate a |
|
procedure, '-syntax none' should be used to avoid ANSI |
|
colours, or the resulting arglist and body should be |
|
run through 'ansistrip'. |
|
" |
|
@opts |
|
#todo - make definition @dynamic - load highlighters as functions? |
|
-n|--line-number -type none -help\ |
|
"Each body line is preceded by its line number, starting at line 1." |
|
-ranges -type indexset -default "0..end" -help\ |
|
"comma delimited set of line ranges. |
|
" |
|
-syntax -type string -typesynopsis "none|basic" -default basic -choices {none basic}\ |
|
-choicelabels { |
|
none\ |
|
" Plain text output" |
|
basic\ |
|
" Comment and bracket highlights. |
|
This is a basic colourizer - not |
|
a full Tcl syntax highlighter." |
|
}\ |
|
-help\ |
|
"Type of syntax highlighting on result. |
|
Note that -syntax none will always return a proper Tcl |
|
List: proc <name> <arglist> <body> |
|
- but a syntax highlighter may return a string that |
|
is not a Tcl list. |
|
The 'basic' highlighter " |
|
@values -min 1 -max -1 |
|
commandname -type string -typesynopsis ${$I}procname${$NI}|${$I}alias${$NI} -help\ |
|
"May be either the fully qualified path for the command, |
|
or a relative name that is resolvable from the current |
|
namespace." |
|
}] |
|
} |
|
proc corp {args} { |
|
set argd [punk::args::parse $args -cache 1 withid ::punk::ns::corp] |
|
lassign [dict values $argd] leaders opts values received |
|
set path [dict get $values commandname] |
|
set syntax [dict get $opts -syntax] |
|
set ranges [dict get $opts -ranges] |
|
set do_ln [expr {[dict exists $received --line-number]}] |
|
#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 infoheader "\n${indent}#corp# auto_index $::auto_index($path)" |
|
} else { |
|
set infoheader "" |
|
} |
|
|
|
#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] |
|
#} |
|
set cinfo [uplevel 1 [list punk::ns::cmdwhich $path]] |
|
set origin [dict get $cinfo origin] |
|
set resolved [dict get $cinfo which] |
|
|
|
set targetcmd $resolved |
|
set targetns [nsprefix $targetcmd] |
|
set name [nstail $targetcmd] |
|
#review - whether relative or absolute, ns might not exist |
|
#if we 'namespace eval' we could create pollution in the form of a new namespace |
|
if {![punk::ns::nsexists $targetns]} { |
|
#JJJ |
|
error "no such namespace $targetns" |
|
} |
|
|
|
#set origin [nseval $targetns [list ::namespace origin $name]] |
|
#set resolved [nseval $targetns [list ::namespace which $name]] |
|
|
|
#A 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! |
|
#set iproc [info procs $origin] ;#This will find empty-string command as ::ns:: but miss finding proc ":x" as ::ns:::x |
|
set iproc [nsjoin $targetns [nseval $targetns [list ::info procs $name]]] |
|
if {$targetcmd ni $iproc} { |
|
|
|
#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 $targetcmd :]] |
|
set alias_unqualified [interp alias {} $targetcmd] |
|
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 $targetcmd :]' and qualified name: '$targetcmd' - 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 $targetcmd] ne [nsprefix [nsjoin ${targetns} $name]]} { |
|
append infoheader \n "${indent}#corp# namespace origin $origin" |
|
} |
|
|
|
if {$infoheader ne "" && [string index $infoheader end] ne "\n"} { |
|
append infoheader \n |
|
} |
|
set body "" |
|
if {![catch {package require textutil::tabify} errpkg]} { |
|
#set bodytext [info body $origin] |
|
set bodytext [nseval $targetns [list ::info body $name]] |
|
#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] |
|
#relevant test test::punk::ns SUITE ns corp.test corp_leadingcolon_functionname |
|
append body [nseval $targetns [list ::info body $name]] |
|
} |
|
|
|
|
|
set argl {} |
|
set argnames [nseval $targetns [list ::info args $name]] |
|
foreach a $argnames { |
|
#if {[info default $origin $a defvar]} { |
|
# lappend a $defvar |
|
#} |
|
set result [nseval $targetns [string map [list %n% $name %a% $a] { |
|
#qualify all command names when running in arbitrary namespace |
|
::if {[::info default "%n%" "%a%" punk_ns_corp_defvar]} { |
|
::return [::list default $punk_ns_corp_defvar][::unset punk_ns_corp_defvar] ;#keep the targetns tidy |
|
} else { |
|
::return [::list none] |
|
} |
|
}]] |
|
if {[lindex $result 0] eq "default"} { |
|
lappend a [lindex $result 1] |
|
} |
|
lappend argl $a |
|
} |
|
#list proc [nsjoin ${targetns} $name] $argl $body |
|
#todo - load highlighters as functions from somewhere |
|
set is_highlighted 1 ;# default assumption |
|
set lnc [punk::ansi::a+ term-73] |
|
set lnr "\x1b\[m" |
|
switch -- $syntax { |
|
basic { |
|
#rudimentary colourising only |
|
set argl [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $argl] |
|
|
|
set body [punk::ansi::grepstr -return all -highlight green {^\s*#.*} $body] ;#Note, will not highlight comments at end of line - like this one. |
|
set body [punk::ansi::grepstr -return all -highlight green {;\s*(#.*)} $body] ;#treat as tail comment only if preceeded by semicolon |
|
|
|
##set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {\{|\}} $body] |
|
|
|
set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {^(\{)|[^\\](\{+)} $body] |
|
set body [punk::ansi::grepstr -return all -highlight tk-darkcyan {[^\\](\}+)} $body] |
|
set body [punk::ansi::grepstr -return all -highlight tk-orange {\[|\]} $body] |
|
} |
|
default { |
|
set is_highlighted 0 |
|
set lnc "" |
|
set lnr "" |
|
} |
|
} |
|
if {$do_ln} { |
|
set linebody "" |
|
set n 0 |
|
set lines [split $body \n] |
|
set linecount [llength $lines] |
|
set w [string length $linecount] |
|
foreach ln $lines { |
|
incr n |
|
append linebody "$lnc[format %${w}s $n]$lnr $ln" \n |
|
} |
|
set body [string range $linebody 0 end-1] |
|
#set body $linebody |
|
} |
|
|
|
if {$is_highlighted} { |
|
#ansi colourised items in list format may not always have desired string representation (list escaping can occur) |
|
#return as a string - which may not be a proper Tcl list! |
|
return "proc $resolved {$argl} {\n$infoheader$body\n}" |
|
} else { |
|
list proc $resolved $argl $infoheader$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} { |
|
#review - obsolete? |
|
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" |
|
} |
|
|
|
} |
|
|
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::pkguse |
|
@cmd -name punk::ns::pkguse -help\ |
|
"Load package and move to namespace of the same name if run |
|
interactively with only pkg/namespace argument. |
|
if script and args are supplied, the |
|
script runs in the namespace with the args passed to the script. |
|
|
|
todo - further documentation" |
|
@leaders -min 1 -max 1 |
|
pkg_or_existing_ns -type string |
|
@opts |
|
-vars -type none -help\ |
|
"whether to capture namespace vars for use in the supplied script" |
|
-nowarnings -type none |
|
@values -min 0 -max -1 |
|
script -type string -optional 1 |
|
arg -type any -optional 1 -multiple 1 |
|
} |
|
#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 |
|
variable pkguse_package_to_namespace [dict create] |
|
proc pkguse {args} { |
|
variable pkguse_package_to_namespace |
|
set argd [punk::args::parse $args withid ::punk::ns::pkguse] |
|
lassign [dict values $argd] leaders opts values received |
|
#puts stderr "leaders:$leaders opts:$opts values:$values received:$received" |
|
|
|
set pkg_or_existing_ns [dict get $leaders pkg_or_existing_ns] |
|
if {[dict exists $received script]} { |
|
set scriptblock [dict get $values script] |
|
} else { |
|
set scriptblock "" |
|
} |
|
if {[dict exists $received arg]} { |
|
set arglist [dict get $values arg] |
|
} else { |
|
set arglist [list] |
|
} |
|
|
|
set use_vars [dict exists $received "-vars"] |
|
set no_warnings [dict exists $received "-nowarnings"] |
|
|
|
#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 { |
|
#- comparing namespaces_before vs namespaces_after only works if the package was not previously loaded |
|
#we could either go to the somewhat expensive route of steaming up an interp with the same auto_path & tcl::tm::list each time.. |
|
#or cache the result of the namespace we picked for later pkguse calls (pkguse_package_to_namespace dict) |
|
#we are using the cache method - but this also doesn't help for packages previously loaded by normal package require |
|
#our aim is for pkguse <pkgname> to be deterministic in what namespace it finds - even if it doesn't always get the ideal one (e.g cookiejar, see below) |
|
#To determine appropriate namespace for already loaded packages where we have no cache entry - we may still need the helper interp mechanism |
|
#The helper interp could be persistent - but only so long as the auto_path/tcl::tm::list values are in sync |
|
#review. |
|
|
|
#also see img::png img::raw etc |
|
#these don't directly load namespaces or direct commands.. just change behaviour of existing commands? |
|
#but they can load things like tk (ttk namespace) first one creates ::tkimg? |
|
|
|
if {[string match ::* $pkg_or_existing_ns] && [tcl::namespace::exists $pkg_or_existing_ns]} { |
|
#pkguse on an existing full qualified namespace does no package require |
|
set ns $pkg_or_existing_ns |
|
set ver "" |
|
} else { |
|
if {[string match ::* $pkg_or_existing_ns]} { |
|
set pkg_unqualified [string range $pkg_or_existing_ns 2 end] |
|
} else { |
|
set pkg_unqualified $pkg_or_existing_ns |
|
} |
|
|
|
#foreach equiv of while 1 - just to allow early exit with break |
|
foreach code_block single { |
|
if {[dict exists $pkguse_package_to_namespace $pkg_unqualified]} { |
|
set ns [dict get $pkguse_package_to_namespace $pkg_unqualified] |
|
set ver [package provide $pkg_unqualified] |
|
break |
|
} |
|
if {[package provide $pkg_unqualified] ne ""} { |
|
#package has already been loaded |
|
if {[namespace exists ::$pkg_unqualified]} { |
|
set ns ::$pkg_unqualified |
|
set ver [package provide $pkg_unqualified] |
|
dict set pkguse_package_to_namespace $pkg_unqualified $ns |
|
break |
|
} |
|
#existing package but no matching namespace.. |
|
#- load in throwaway interp and see what cmds/namespaces created |
|
interp create nstest |
|
try { |
|
nstest eval {tcl::tm::remove {*}[tcl::tm::list]} |
|
nstest eval [list tcl::tm::add {*}[lreverse [tcl::tm::list]]] |
|
nstest eval [list set ::auto_path $::auto_path] |
|
nstest eval {package require punk::ns} |
|
set ns "" |
|
if {![catch {nstest eval [list punk::ns::pkguse $pkg_unqualified]} errMsg]} { |
|
set script [string map [list %p% $pkg_unqualified] {dict get $::punk::ns::pkguse_package_to_namespace %p%}] |
|
set ns [nstest eval $script] |
|
} else { |
|
puts "couldn't test pkg $pkg_unqualified\n$errMsg" |
|
} |
|
} finally { |
|
interp delete nstest |
|
} |
|
|
|
dict set pkguse_package_to_namespace $pkg_unqualified $ns |
|
set ver [package provide $pkg_unqualified] |
|
break |
|
} |
|
|
|
#pkg not loaded |
|
set namespaces_before [nstree_rawlist ::] ;#approx 1ms for 500 or so namespaces - not cheap but bearable |
|
#some packages don't create their namespace immediately and/or don't populate it with commands and instead put entries in ::auto_index |
|
#gathering prior cmdcount for every ns in system is also a somewhat expensive operation.. review |
|
#we don't know for sure that the namespace for the package require operation actually matches the package name |
|
#e.g tcllib inifile package uses namespace ::ini |
|
#e.g sqlite3 package adds commands to the global namespace |
|
set dict_ns_commandcounts [dict create] |
|
foreach nsb $namespaces_before { |
|
dict set dict_ns_commandcounts $nsb [llength [info commands ${nsb}::*]] |
|
} |
|
|
|
set ver [package require $pkg_unqualified] |
|
set ns ::$pkg_unqualified ;#fallback - tested for existence below |
|
set namespaces_after [nstree_rawlist ::] |
|
|
|
if {[llength $namespaces_after] > [llength $namespaces_before]} { |
|
set namespaces_new [struct::set difference $namespaces_after $namespaces_before] |
|
if {$ns ni $namespaces_new} { |
|
#todo - use shortest result? what if this is a namespace from a required sub package? |
|
#e.g cookiejar loads sqlite3,http,tcl::idna which creates ::sqlite3 etc - but cookiejar just creates an object at ::http::cookiejar |
|
#In this specific case we end up in oo::ObjXXX - but would be better placed in ::http, where the new cookiejar command resides |
|
#review - todo? |
|
set pkgs [package names] |
|
set ns ::$pkg_unqualified ;#fallback - tested for existence below |
|
#find something new - that doesn't match another package name |
|
foreach new $namespaces_new { |
|
if {[lsearch $pkgs [string trimleft $new :]] == -1} { |
|
set ns $new |
|
break |
|
} |
|
} |
|
} |
|
} |
|
if {[tcl::namespace::exists $ns]} { |
|
#review - only cache if exists? |
|
dict set pkguse_package_to_namespace $pkg_unqualified $ns; |
|
} |
|
set previous_command_count 0 |
|
if {[dict exists $dict_ns_commandcounts $ns]} { |
|
set previous_command_count [dict get $dict_ns_commandcounts $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_cached [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_cached [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} { |
|
puts stderr "pkguse sourcing auto_index script $auto_source" |
|
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 |
|
} |
|
|
|
} |
|
|
|
}; # end foreach code_block single - scope for use of 'break' |
|
|
|
} |
|
} |
|
} |
|
if {[tcl::namespace::exists $ns]} { |
|
if {[dict exists $received script]} { |
|
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) (could use 'nsjoin [namespace current] *') |
|
} ] |
|
|
|
|
|
#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 {::tcl::namespace::current}]" |
|
append out \n $ver |
|
return $out |
|
} |
|
} |
|
return $out |
|
} |
|
#interp alias "" use "" punk::ns::pkguse |
|
|
|
punk::args::define { |
|
@id -id ::punk::ns::nsimport_noclobber |
|
@cmd -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's 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 -multiple 1 -help\ |
|
"Glob pattern(s) for exported commands in source namespace(s). |
|
Globbing only active in the tail segment. |
|
e.g ::mynamespace::a* ::mynamespace::j*" |
|
} |
|
proc nsimport_noclobber {args} { |
|
lassign [dict values [punk::args::parse $args withid ::punk::ns::nsimport_noclobber]] leaders opts values received |
|
set sourcepatterns [dict get $values sourcepattern] |
|
|
|
set nscaller [uplevel 1 {::tcl::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::ns::nsjoin $nscaller $target_ns] |
|
} |
|
} |
|
set all_imported [list] |
|
set nstemp ::punk::ns::temp_import |
|
|
|
foreach pat $sourcepatterns { |
|
set source_ns [tcl::namespace::qualifiers $pat] |
|
if {![tcl::namespace::exists $source_ns]} { |
|
error "nsimport_noclobber error namespace $source_ns not found" |
|
} |
|
|
|
set a_export_patterns [tcl::namespace::eval $source_ns {namespace export}] |
|
set a_commands [info commands $pat] |
|
#puts "-->commands:'$a_commands'" |
|
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 { |
|
#we will be using namespace import <pattern> one by one on commands. |
|
#we must protect glob chars that may exist in the actual command names. |
|
#e.g nsimport_noclobber ::punk::ansi::a? |
|
# will import a+ and a? |
|
#but nsimport_noclobber {::punk::ansi::a\?} |
|
# must import only a? |
|
set m [string map {\\ \\\\ ? \\? * \\* \[ \\[ \] \\]} $m] |
|
if {$m ni $a_exported_tails} { |
|
lappend a_exported_tails $m |
|
} |
|
} |
|
} |
|
|
|
|
|
if {[tcl::dict:::exists $received -prefix]} { |
|
#import via temporary/intermediate namespace |
|
set pfx [dict get $opts -prefix] |
|
set import_via_temp 1 |
|
} else { |
|
set pfx "" |
|
set import_via_temp 0 |
|
} |
|
set import_via_temp 1; #import to weirdns only works with tempns |
|
if {$import_via_temp} { |
|
set imported_commands [list] |
|
if {[namespace exists $nstemp]} { |
|
namespace delete $nstemp |
|
} |
|
namespace eval $nstemp {} |
|
foreach e $a_exported_tails { |
|
set imported [apply {{tgtns func srcns pfx tmpns} { |
|
set cmd "" |
|
if {![catch {::tcl::namespace::eval $tmpns [list ::namespace import ${srcns}::$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 {::tcl::namespace::eval $tmpns [list ::rename $func [::punk::ns::nsjoin $tgtns $pfx$func]]}]} { |
|
# set cmd $pfx$func |
|
#} |
|
if {![catch {punk::ns::nseval $tgtns [list ::rename ${tmpns}::$func $pfx$func]}]} { |
|
#renaming into a weirdns only works if run in the target ns. |
|
set cmd $pfx$func |
|
} |
|
} |
|
set cmd |
|
} } $target_ns $e $source_ns $pfx $nstemp] |
|
if {$imported ne ""} { |
|
lappend imported_commands $imported |
|
} |
|
} |
|
namespace delete $nstemp |
|
} else { |
|
#no prefix - direct import |
|
set imported_commands [list] |
|
foreach e $a_exported_tails { |
|
set imported [apply {{tgtns func srcns} { |
|
set cmd "" |
|
#if {![catch {tcl::namespace::eval $tgtns [list namespace import ${srcns}::$func]}]} { |
|
# set cmd $func |
|
#} |
|
#namespace import doesn't seem to import into some weirdly named namespaces |
|
#even if evaluated in that namespace |
|
#e.g ns with leading colon. |
|
#e.g ::jjj:::::aaa (jjj -> : -> aaa) |
|
#will instead create new ns at ::jjj::aaa and import there. |
|
if {![catch {punk::ns::nseval $tgtns [list namespace import ${srcns}::$func]}]} { |
|
set cmd $func |
|
} |
|
set cmd |
|
} } $target_ns $e $source_ns] |
|
if {$imported ne ""} { |
|
lappend imported_commands $imported |
|
} |
|
} |
|
} |
|
lappend all_imported {*}$imported_commands |
|
} |
|
return $all_imported |
|
} |
|
|
|
#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 |
|
|
|
interp alias {} cmdwhich {} punk::ns::cmdwhich |
|
interp alias {} cmdinfo {} punk::ns::cmdinfo |
|
interp alias {} cmdtype {} punk::ns::cmdtype |
|
interp alias {} cmdtrace {} punk::ns::cmdtrace |
|
|
|
#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::cmdhelp |
|
|
|
#An example of using punk::args in a pipeline |
|
punk::args::define { |
|
@id -id ::i+ |
|
@cmd -name "i+" -help\ |
|
"Display command help side by side" |
|
@values |
|
cmd -multiple 1 -help\ |
|
"Command names for which to show help info" |
|
} |
|
interp alias {} i+ {}\ |
|
.=args>1 punk::args::parse withid ::i+ |argd>\ |
|
.=>2 dict get values cmd |cmds>\ |
|
.=cmds>2 lmap c {i -return tableobject {*}$c} |objs>\ |
|
.=objs>2 lmap t {$t configure -show_vseps 0 -show_edge 1} |>\ |
|
.=objs>2 lmap t {$t print} |tables>\ |
|
.=objs>2 lmap t {$t destroy} |>\ |
|
.=tables>* textblock::join -- <args| |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
namespace eval ::punk::args::register { |
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
|
lappend ::punk::args::register::NAMESPACES ::punk::ns ::punk::ns::argdoc |
|
} |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::ns [tcl::namespace::eval punk::ns { |
|
variable version |
|
set version 0.1.0 |
|
}] |
|
return |