@ -491,42 +491,50 @@ tcl::namespace::eval punk::ns {
lassign $cindices cstart cend
append p [string range $nspath $s $cstart-1]
set numcolons [expr {$cend - $cstart + 1}]
if {$numcolons == 1} {
#internal colon
append p :
set s [expr {$cend+1}]
continue
} elseif {$numcolons == 2} {
lappend parts $p
set p ""
set s [expr {$cend+1}]
continue
} elseif {($numcolons -1) % 3 == 0} {
set numcolons [expr {$numcolons -2}]
}
#assert numcolons >=3 and not in 4,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 {
#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
}
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
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}]
}
}
set p ""
set s [expr {$cend+1}]
}
}
if {$cend < ([string length $nspath]-1)} {
@ -695,6 +703,39 @@ tcl::namespace::eval punk::ns {
}
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] {
@ -2984,7 +3025,7 @@ tcl::namespace::eval punk::ns {
switch -- $generaltype {
method - private {
#private? todo?
if {$location eq $origin} {
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}}
@ -3042,9 +3083,10 @@ tcl::namespace::eval punk::ns {
@cmd -name "${$objtype}: ${$origin}" -help\
"Instance of class: ${$class} (info autogenerated by generate_autodef)
(see 'i punk::ns::Cmark' for symbols)"
@leaders -min 1
@leaders -min 1 -max 1
}]
append argdef \n $vline
append argdef \n "@values -unnamed true"
punk::args::define $argdef
}
@ -3148,15 +3190,15 @@ tcl::namespace::eval punk::ns {
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"
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]
dict set choiceinfodict $sub [list [list resolved $subwhat]]
# -resolved-
dict set choiceinfodict $sub [list [list ensemblesubtarget {*} $subwhat]]
dict lappend choiceinfodict $sub [list doctype $targetcmdtype]
if {[punk::args::id_exists [list $origin $sub]]} {
@ -3183,17 +3225,18 @@ tcl::namespace::eval punk::ns {
@cmd -help\
"(autogenerated by generate_autodef)
ensemble: ${$origin}"
@leaders -min 1
}]
#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"
append argdef \n "@leaders -min 1 -max 1 "
} else {
append argdef \n "@leaders -min [expr {[llength $parameters]+1}]"
append argdef \n "@leaders -min [expr {[llength $parameters]+1}] -max [expr {[llength $parameters]+1}] "
foreach p $parameters {
append argdef \n "$p -type string -help { (leading ensemble parameter)}"
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 {
@ -3325,6 +3368,13 @@ tcl::namespace::eval punk::ns {
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} {
@ -3493,6 +3543,7 @@ tcl::namespace::eval punk::ns {
#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?
@ -3504,7 +3555,7 @@ tcl::namespace::eval punk::ns {
set origin [list $origin $a]
incr i
set queryargs [lrange $args $i end]
set resolvedargs [list $a] ;#even though the
set resolvedargs [list $a] ;#
set queryargs_untested $queryargs
} elseif {[punk::args::id_exists $docid]} {
set docid_exists 1
@ -3543,6 +3594,12 @@ tcl::namespace::eval punk::ns {
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]
@ -3574,8 +3631,26 @@ tcl::namespace::eval punk::ns {
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]} {
@ -3585,7 +3660,7 @@ tcl::namespace::eval punk::ns {
#ledit queryargs_untested 0 0
#jjj
#continue
return [list 3 $origin $resolvedargs $queryargs_untested $docid]
return [list 3 $origin $resolvedargs [list {*}$eparams {*} $queryargs_untested] $docid]
break
}
set resolved_q [tcl::prefix::match -error "" $allchoices $q]
@ -3610,9 +3685,9 @@ tcl::namespace::eval punk::ns {
set docid ""
foreach inf $cinfo {
switch -- [lindex $inf 0] {
"resolved" {
#punk::args::ensemble_subcommands_definition
"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]} {
@ -3630,11 +3705,14 @@ tcl::namespace::eval punk::ns {
} else {
set docid ""
}
#puts stderr "cmd_traverse 'resolved' $mapped_subcmd"
#allow subhelp override - todo: review/document rationale/usecases
break
}
"subhelp" {
"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]
#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]} {
@ -3652,8 +3730,16 @@ tcl::namespace::eval punk::ns {
} else {
set docid ""
}
#allow subhelp override - todo: review/document rationale/usecases
break
#puts stderr "cmd_traverse 'resolved' $mapped_subcmd"
}
"doctype" {
set d [lindex $inf 1]
switch -- $d {
"classmethod" {
}
"coremethod" {
}
}
}
}
}
@ -3668,23 +3754,9 @@ tcl::namespace::eval punk::ns {
set mapped_subcmd "$raw_origin $resolved_q"
set docid $mapped_subcmd
} else {
#REVIEW - there is no reason to assume a subcommand (even in an ensemble)
#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
#punk::args::update_definitions [list $raw_origin]
#if {[punk::args::id_exists "${raw_origin}::$resolved_q"]} {
# set mapped_subcmd "${raw_origin}::$resolved_q"
# set docid $mapped_subcmd
#} else {
# if {![punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} {
# namespace eval $ns [list punk::ns::generate_autodef "${raw_origin}::$resolved_q"]
# }
# if {[punk::args::id_exists "(autodef)${raw_origin}::$resolved_q"]} {
# set mapped_subcmd ${raw_origin}::$resolved_q
# set docid (autodef)${raw_origin}::$resolved_q
# }
#}
}
}
#puts "----------$mapped_subcmd"
@ -3695,13 +3767,18 @@ tcl::namespace::eval punk::ns {
#punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {[llength $queryargs_untested] == 0} {
return [list 6 $mapped_subcmd $resolvedargs $queryargs_untested $docid]
return [list 6 $mapped_subcmd $resolvedargs [list {*}$eparams {*} $queryargs_untested] $docid]
}
set origin [yield [list 0 $mapped_subcmd $resolvedargs $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}]
#puts stderr "... yield-result $origin i:$i"
#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]
@ -3719,15 +3796,15 @@ tcl::namespace::eval punk::ns {
set docid ""
}
break
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 $resolvedargs [lrange $args $i end] $docid"
# 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 {
@ -3758,7 +3835,8 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args 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 origin]
set id [dict get $resolveinfo docid]
::punk::args::forms $id
}
@ -3778,8 +3856,10 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args 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 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]
}
@ -3849,7 +3929,30 @@ tcl::namespace::eval punk::ns {
#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
#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]
@ -4620,6 +4723,7 @@ tcl::namespace::eval punk::ns {
@values
}]
set i 0
#for 9.1+ can use -integer
foreach a $arglist {
switch -- [llength $a] {
1 {
@ -4663,7 +4767,7 @@ tcl::namespace::eval punk::ns {
lassign $impl generaltype mname location methodtype
switch -- $generaltype {
method - private {
if {$location eq $origin} {
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}}
@ -4679,12 +4783,10 @@ tcl::namespace::eval punk::ns {
dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]]
}
}
if {[info commands ::punk::args::id_exists] ne ""} {
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]
}
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
}
@ -4842,7 +4944,6 @@ tcl::namespace::eval punk::ns {
@cmd -help\
"(autogenerated by arginfo)
ensemble: ${$origin}"
@leaders -min 1
}]
if {[llength $parameters] == 0} {
append argdef \n "@leaders -min 1"
@ -4852,6 +4953,7 @@ tcl::namespace::eval punk::ns {
append argdef \n "$p -type string -help { (leading ensemble parameter)}"
}
}
append argdef \n "@values -unnamed true"
append argdef \n $vline
punk::args::define $argdef
}
