@ -491,20 +491,26 @@ tcl::namespace::eval punk::ns {
lassign $cindices cstart cend lassign $cindices cstart cend
append p [string range $nspath $s $cstart-1] append p [string range $nspath $s $cstart-1]
set numcolons [expr {$cend - $cstart + 1}] set numcolons [expr {$cend - $cstart + 1}]
if {$numcolons == 1} { #assert numcolons != 0 due to regexp +
#internal colon switch -exact -- $numcolons {
append p : 2 - 4 {
set s [expr {$cend+1}] #4 is a somewhat common case - could handle with default branch but may as well short circuit here.
continue
} elseif {$numcolons == 2} {
lappend parts $p lappend parts $p
set p "" set p ""
set s [expr {$cend+1}] set s [expr {$cend+1}]
continue #continue
} elseif {($numcolons -1) % 3 == 0} { }
1 {
#internal colon
append p :
set s [expr {$cend+1}]
#continue
}
default {
if {($numcolons -1) %3 == 0} {
set numcolons [expr {$numcolons -2}] set numcolons [expr {$numcolons -2}]
} }
#assert numcolons >=3 and not in 4,7,10,13,16,19,22... sequence #assert numcolons >=4 and not in 7,10,13,16,19,22... sequence
if {$numcolons % 3 == 0} { if {$numcolons % 3 == 0} {
#if numcolons % 3 == 0 we have a leading colon left for next ns #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 #this is the ambiguous case x::::::y -> x: :: : ::y vs x:: : :: :y
@ -517,7 +523,7 @@ tcl::namespace::eval punk::ns {
} }
set p ":" set p ":"
set s [expr {$cend+1}] set s [expr {$cend+1}]
continue # continue
} else { } else {
set singlec_count [expr {(($numcolons +1)/3) -1}] set singlec_count [expr {(($numcolons +1)/3) -1}]
if {$singlec_count > 0} { if {$singlec_count > 0} {
@ -529,6 +535,8 @@ tcl::namespace::eval punk::ns {
set s [expr {$cend+1}] set s [expr {$cend+1}]
} }
} }
}
}
if {$cend < ([string length $nspath]-1)} { if {$cend < ([string length $nspath]-1)} {
lappend parts $p[string range $nspath $cend+1 end] lappend parts $p[string range $nspath $cend+1 end]
} else { } else {
@ -695,6 +703,39 @@ tcl::namespace::eval punk::ns {
} }
proc nsglob_as_re {glob} { 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 #any segment that is not just * must match exactly one segment in the path
set pats [list] set pats [list]
foreach seg [nsparts_cached $glob] { foreach seg [nsparts_cached $glob] {
@ -2984,7 +3025,7 @@ tcl::namespace::eval punk::ns {
switch -- $generaltype { switch -- $generaltype {
method - private { method - private {
#private? todo? #private? todo?
if {$location eq $origin} { if {$location eq "object" || $location eq $origin} {
#set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" #set id "[string trimleft $origin :] $cmd" ;# "<object> <method>"
set id "$origin $cmd" set id "$origin $cmd"
#dict set choiceinfodict $cmd {{doctype ooo}} #dict set choiceinfodict $cmd {{doctype ooo}}
@ -3042,9 +3083,10 @@ tcl::namespace::eval punk::ns {
@cmd -name "${$objtype}: ${$origin}" -help\ @cmd -name "${$objtype}: ${$origin}" -help\
"Instance of class: ${$class} (info autogenerated by generate_autodef) "Instance of class: ${$class} (info autogenerated by generate_autodef)
(see 'i punk::ns::Cmark' for symbols)" (see 'i punk::ns::Cmark' for symbols)"
@leaders -min 1 @leaders -min 1 -max 1
}] }]
append argdef \n $vline append argdef \n $vline
append argdef \n "@values -unnamed true"
punk::args::define $argdef punk::args::define $argdef
} }
@ -3148,15 +3190,15 @@ tcl::namespace::eval punk::ns {
dict for {sub subwhat} $subcommand_dict { dict for {sub subwhat} $subcommand_dict {
if {[llength $subwhat] > 1} { if {[llength $subwhat] > 1} {
#TODO - resolve using cmdinfo? #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 targetfirstword [lindex $subwhat 0]
set targetinfo [cmdwhich $targetfirstword] set targetinfo [cmdwhich $targetfirstword]
set targetorigin [dict get $targetinfo origin] set targetorigin [dict get $targetinfo origin]
set targetcmdtype [dict get $targetinfo origintype] set targetcmdtype [dict get $targetinfo origintype]
set nstarget [nsprefix $targetorigin] set nstarget [nsprefix $targetorigin]
# -resolved-
dict set choiceinfodict $sub [list [list resolved $subwhat]] dict set choiceinfodict $sub [list [list ensemblesubtarget {*} $subwhat]]
dict lappend choiceinfodict $sub [list doctype $targetcmdtype] dict lappend choiceinfodict $sub [list doctype $targetcmdtype]
if {[punk::args::id_exists [list $origin $sub]]} { if {[punk::args::id_exists [list $origin $sub]]} {
@ -3183,17 +3225,18 @@ tcl::namespace::eval punk::ns {
@cmd -help\ @cmd -help\
"(autogenerated by generate_autodef) "(autogenerated by generate_autodef)
ensemble: ${$origin}" 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} { if {[llength $parameters] == 0} {
append argdef \n "@leaders -min 1" append argdef \n "@leaders -min 1 -max 1 "
} else { } 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 { 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 $vline
append argdef \n "@values -unnamed true"
punk::args::define $argdef punk::args::define $argdef
} }
proc { proc {
@ -3325,6 +3368,13 @@ tcl::namespace::eval punk::ns {
set cinfo [cmdwhich $finalcommand] set cinfo [cmdwhich $finalcommand]
set origin [dict get $cinfo origin] set origin [dict get $cinfo origin]
set cmdtype [dict get $cinfo origintype] 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] 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} { 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. #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) #(would not support shor-form prefix of subcommand - even if the proc implementation did)
set docid_exists 0 set docid_exists 0
set eparams [list]
if {[punk::args::id_exists "$origin [lindex $args $i]"]} { if {[punk::args::id_exists "$origin [lindex $args $i]"]} {
set a [lindex $args $i] set a [lindex $args $i]
#review - tests? #review - tests?
@ -3504,7 +3555,7 @@ tcl::namespace::eval punk::ns {
set origin [list $origin $a] set origin [list $origin $a]
incr i incr i
set queryargs [lrange $args $i end] set queryargs [lrange $args $i end]
set resolvedargs [list $a] ;#even though the set resolvedargs [list $a] ;#
set queryargs_untested $queryargs set queryargs_untested $queryargs
} elseif {[punk::args::id_exists $docid]} { } elseif {[punk::args::id_exists $docid]} {
set docid_exists 1 set docid_exists 1
@ -3543,6 +3594,12 @@ tcl::namespace::eval punk::ns {
set leadernames [dict get $spec FORMS $fid LEADER_NAMES] set leadernames [dict get $spec FORMS $fid LEADER_NAMES]
set optnames [dict get $spec FORMS $fid OPT_NAMES] set optnames [dict get $spec FORMS $fid OPT_NAMES]
set valnames [dict get $spec FORMS $fid VAL_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]} { if {![llength $optnames] && ![llength $valnames]} {
#set queryargs [lrange $args $i end] #set queryargs [lrange $args $i end]
@ -3574,8 +3631,26 @@ tcl::namespace::eval punk::ns {
if {$is_ensembleparam} { if {$is_ensembleparam} {
lappend resolvedargs $q lappend resolvedargs $q
lpop queryargs_untested 0 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 #ledit queryargs_untested 0 0
#review - add tests #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 continue
} }
if {![llength $allchoices]} { if {![llength $allchoices]} {
@ -3585,7 +3660,7 @@ tcl::namespace::eval punk::ns {
#ledit queryargs_untested 0 0 #ledit queryargs_untested 0 0
#jjj #jjj
#continue #continue
return [list 3 $origin $resolvedargs $queryargs_untested $docid] return [list 3 $origin $resolvedargs [list {*}$eparams {*} $queryargs_untested] $docid]
break break
} }
set resolved_q [tcl::prefix::match -error "" $allchoices $q] set resolved_q [tcl::prefix::match -error "" $allchoices $q]
@ -3610,9 +3685,9 @@ tcl::namespace::eval punk::ns {
set docid "" set docid ""
foreach inf $cinfo { foreach inf $cinfo {
switch -- [lindex $inf 0] { switch -- [lindex $inf 0] {
"resolved" { "subhelp" {
#punk::args::ensemble_subcommands_definition
set mapped_subcmd [lrange $inf 1 end] set mapped_subcmd [lrange $inf 1 end]
#set mapped_subcmd [lindex $inf 1]
if {![punk::args::id_exists $mapped_subcmd]} { if {![punk::args::id_exists $mapped_subcmd]} {
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {![dict exists $autodefined $mapped_subcmd]} { if {![dict exists $autodefined $mapped_subcmd]} {
@ -3630,11 +3705,14 @@ tcl::namespace::eval punk::ns {
} else { } else {
set docid "" 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 [lrange $inf 1 end]
#set mapped_subcmd [lindex $inf 1]
if {![punk::args::id_exists $mapped_subcmd]} { if {![punk::args::id_exists $mapped_subcmd]} {
punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {![dict exists $autodefined $mapped_subcmd]} { if {![dict exists $autodefined $mapped_subcmd]} {
@ -3652,8 +3730,16 @@ tcl::namespace::eval punk::ns {
} else { } else {
set docid "" set docid ""
} }
#allow subhelp override - todo: review/document rationale/usecases #puts stderr "cmd_traverse 'resolved' $mapped_subcmd"
break }
"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 mapped_subcmd "$raw_origin $resolved_q"
set docid $mapped_subcmd set docid $mapped_subcmd
} else { } 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" #will be located at "${raw_origin}::$resolved_q"
#ensemble -map could point resolved_q somewhere else entirely #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" #puts "----------$mapped_subcmd"
@ -3695,13 +3767,18 @@ tcl::namespace::eval punk::ns {
#punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]] #punk::args::update_definitions [list [namespace qualifiers $mapped_subcmd]]
if {[llength $queryargs_untested] == 0} { 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] #set resolvedargs [list]
incr i [expr {-1 * [llength $resolvedargs]+1}] #incr i [expr {-1 * [llength $resolvedargs]+1}] ;#wrong e.g test trace add execution blah enterstep cmd
#puts stderr "... yield-result $origin i:$i" #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 whichinfo [namespace eval $ns [list punk::ns::cmdwhich $origin]]
set origin [dict get $whichinfo origin] set origin [dict get $whichinfo origin]
@ -3719,15 +3796,15 @@ tcl::namespace::eval punk::ns {
set docid "" set docid ""
} }
break break ;#out of foreach q $queryargs ...
} else { } else {
#test with: i namespace which -v x #test with: i namespace which -v x
return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid] return [list 7 $origin $resolvedargs $queryargs_untested $prevdocid]
} }
} } ;#end loop foreach q $queryargs lname $leadernames_matched
} else { } 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] return [list 8 $origin $resolvedargs [lrange $args $i end] $docid]
} }
} else { } else {
@ -3758,7 +3835,8 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args withid ::punk::ns::forms] set argd [::punk::args::parse $args withid ::punk::ns::forms]
set cmdwords [dict get $argd values cmditem] set cmdwords [dict get $argd values cmditem]
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context 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 ::punk::args::forms $id
} }
@ -3778,8 +3856,10 @@ tcl::namespace::eval punk::ns {
set argd [::punk::args::parse $args withid ::punk::ns::eg] set argd [::punk::args::parse $args withid ::punk::ns::eg]
set cmdwords [dict get $argd values cmditem] set cmdwords [dict get $argd values cmditem]
set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context set resolveinfo [uplevel 1 [list ::punk::ns::cmdinfo {*}$cmdwords]] ;#resolve from calling context
set resolved_id [dict get $resolveinfo origin] #set resolved_id [dict get $resolveinfo origin]
set result [::punk::args::eg $resolved_id] #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] #puts stderr [textblock::frame $syn]
#set replaceuntil [expr {[llength $resolved_id]-1}] #set replaceuntil [expr {[llength $resolved_id]-1}]
set replaceuntil [expr {[llength $resolved_id]-1+$excess}] 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] set resultstr [string trimright $resultstr \n]
@ -4620,6 +4723,7 @@ tcl::namespace::eval punk::ns {
@values @values
}] }]
set i 0 set i 0
#for 9.1+ can use -integer
foreach a $arglist { foreach a $arglist {
switch -- [llength $a] { switch -- [llength $a] {
1 { 1 {
@ -4663,7 +4767,7 @@ tcl::namespace::eval punk::ns {
lassign $impl generaltype mname location methodtype lassign $impl generaltype mname location methodtype
switch -- $generaltype { switch -- $generaltype {
method - private { method - private {
if {$location eq $origin} { if {$location eq "object" || $location eq $origin} {
#set id "[string trimleft $origin :] $cmd" ;# "<object> <method>" #set id "[string trimleft $origin :] $cmd" ;# "<object> <method>"
set id "$origin $cmd" set id "$origin $cmd"
dict set choiceinfodict $cmd {{doctype objectmethod}} dict set choiceinfodict $cmd {{doctype objectmethod}}
@ -4679,13 +4783,11 @@ tcl::namespace::eval punk::ns {
dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]] dict lappend choiceinfodict $cmd [list doctype [list $location $methodtype]]
} }
} }
if {[info commands ::punk::args::id_exists] ne ""} {
if {[punk::args::id_exists $id]} { if {[punk::args::id_exists $id]} {
#dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]" #dict set choicelabeldict $cmd " [Usageinfo_mark brightgreen]"
dict lappend choiceinfodict $cmd {doctype punkargs} dict lappend choiceinfodict $cmd {doctype punkargs}
dict lappend choiceinfodict $cmd [list subhelp {*}$id] dict lappend choiceinfodict $cmd [list subhelp {*}$id]
} }
}
break break
} }
filter { filter {
@ -4842,7 +4944,6 @@ tcl::namespace::eval punk::ns {
@cmd -help\ @cmd -help\
"(autogenerated by arginfo) "(autogenerated by arginfo)
ensemble: ${$origin}" ensemble: ${$origin}"
@leaders -min 1
}] }]
if {[llength $parameters] == 0} { if {[llength $parameters] == 0} {
append argdef \n "@leaders -min 1" 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 "$p -type string -help { (leading ensemble parameter)}"
} }
} }
append argdef \n "@values -unnamed true"
append argdef \n $vline append argdef \n $vline
punk::args::define $argdef punk::args::define $argdef
} }
