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.
216 lines
8.1 KiB
216 lines
8.1 KiB
package provide punk::mix::base [namespace eval punk::mix::base { |
|
variable version |
|
set version 0.1 |
|
}] |
|
|
|
|
|
#base internal plumbing functions |
|
namespace eval punk::mix::base { |
|
proc set_alias {cmdname args} { |
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
|
uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] |
|
} |
|
proc _cli {args} { |
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
|
if {![string length $extension]} { |
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
|
} |
|
puts stderr ">>> extension:$extension" |
|
if {![llength $args]} { |
|
if {[info exists ${extension}::default_command]} { |
|
tailcall $extension [set ${extension}::default_command] |
|
} |
|
tailcall $extension |
|
} else { |
|
tailcall $extension {*}$args |
|
} |
|
} |
|
proc _unknown {ns args} { |
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
|
if {![string length $extension]} { |
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
|
} |
|
puts stderr "arglen:[llength $args]" |
|
puts stdout "_unknown '$ns' '$args'" |
|
|
|
set d_commands [get_commands -extension $extension] |
|
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
|
error "Unknown subcommand \"[lindex $args 0]\": must be one of: $all_commands" "punk::mix::base _unknown $ns $args" [list unknown_ensemble_subcommand ensemble punk::mix::base] |
|
} |
|
proc _redirected {from_ns subcommand args} { |
|
puts stderr "_redirected from_ns: $from_ns subcommand:$subcommand args:$args" |
|
set pname [namespace current]::$subcommand |
|
if {$pname in [info procs $pname]} { |
|
set argnames [info args $pname] |
|
puts stderr "$subcommand argnames: $argnames" |
|
if {[lindex $argnames end] eq "args"} { |
|
set pos_argnames [lrange $argnames 0 end-1] |
|
} else { |
|
set pos_argnames $argnames |
|
} |
|
set argvals [list] |
|
set numargs [llength $pos_argnames] |
|
if {$numargs > 0} { |
|
set argvals [lrange $args 0 $numargs-1] |
|
set args [lrange $args $numargs end] |
|
} |
|
if {[llength $argvals] < $numargs} { |
|
error "wrong # args: $from_ns $subcommand requires args: $pos_argnames" |
|
} |
|
tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns |
|
} else { |
|
tailcall [namespace current] $subcommand {*}$args -extension $from_ns |
|
} |
|
} |
|
proc _split_args {arglist} { |
|
#don't assume arglist is fully paired. |
|
set posn [lsearch $arglist -extension] |
|
set opts [list] |
|
if {$posn >= 0} { |
|
if {$posn+2 <= [llength $arglist]} { |
|
set opts [list -extension [lindex $arglist $posn+1]] |
|
set argsremaining [lreplace $arglist $posn $posn+1] |
|
} else { |
|
#no value supplied to -extension |
|
error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." |
|
} |
|
} else { |
|
set argsremaining $arglist |
|
} |
|
|
|
return [list opts $opts args $argsremaining] |
|
} |
|
} |
|
|
|
|
|
#base API (potentially overridden functions - may also be called from overriding namespace) |
|
#commands should either handle or silently ignore -extension <namespace/ensemble> |
|
namespace eval punk::mix::base { |
|
namespace ensemble create |
|
namespace export help dostuff get_commands set_alias |
|
namespace ensemble configure [namespace current] -unknown punk::mix::base::_unknown |
|
proc get_commands {args} { |
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
|
if {![string length $extension]} { |
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
|
} |
|
|
|
set maincommands [list] |
|
#extension may still be blank e.g if punk::mix::base::get_commands called directly |
|
if {[string length $extension]} { |
|
set nsmain $extension |
|
puts stdout "get_commands nsmain: $nsmain" |
|
set parentpatterns [namespace eval $nsmain [list namespace export]] |
|
set nscommands [list] |
|
foreach p $parentpatterns { |
|
lappend nscommands {*}[info commands ${nsmain}::$p] |
|
} |
|
foreach c $nscommands { |
|
set cmd [namespace tail $c] |
|
lappend maincommands $cmd |
|
} |
|
set maincommands [lsort $maincommands] |
|
} |
|
|
|
|
|
|
|
|
|
set nsbase [namespace current] |
|
set basepatterns [namespace export] |
|
puts stdout "basepatterns:$basepatterns" |
|
set nscommands [list] |
|
foreach p $basepatterns { |
|
lappend nscommands {*}[info commands ${nsbase}::$p] |
|
} |
|
|
|
set basecommands [list] |
|
foreach c $nscommands { |
|
set cmd [namespace tail $c] |
|
if {$cmd ni $maincommands} { |
|
lappend basecommands $cmd |
|
} |
|
} |
|
set basecommands [lsort $basecommands] |
|
|
|
|
|
return [list main $maincommands base $basecommands] |
|
} |
|
proc help {args} { |
|
#' **%ensemblecommand% help** *args* |
|
#' |
|
#' Help for ensemble commands in the command line interface |
|
#' |
|
#' |
|
#' Arguments: |
|
#' |
|
#' * args - first word of args is the helptopic requested - usually a command name |
|
#' - calling help with no arguments will list available commands |
|
#' |
|
#' Returns: help text (text) |
|
#' |
|
#' Examples: |
|
#' |
|
#' ``` |
|
#' %ensemblecommand% help <commandname> |
|
#' ``` |
|
#' |
|
#' |
|
|
|
|
|
#extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| |
|
# >} inspect -label a {| |
|
# >} .=e>end,data>end pipeswitch { |
|
# pipecase ,0/1/#= $switchargs {| |
|
# e/0 |
|
# >} .=>. {set e} |
|
# pipecase /1,1/1/#= $switchargs |
|
#} |@@ok/result> <e/0| [namespace qualifiers [lindex [info level -1] 0]] |
|
|
|
|
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
|
if {![string length $extension]} { |
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
|
} |
|
#puts stderr "-1:[info level -1]" |
|
|
|
set command_info [punk::mix::base::get_commands -extension $extension] |
|
set subhelp1 [lindex $args 0] |
|
if {[string length $subhelp1]} { |
|
if {$subhelp1 in [dict get $command_info main]} { |
|
set procname ${extension}::$subhelp1 |
|
if {$procname in [info procs $procname]} { |
|
set argnames [info args $procname] |
|
} else { |
|
set argnames "(No info available)" |
|
} |
|
return "$subhelp1 $argnames" |
|
} elseif {$subhelp1 in [dict get $command_info base]} { |
|
set procname [namespace current]::$subhelp1 |
|
if {$procname in [info procs $procname]} { |
|
set argnames [info args $procname] |
|
} else { |
|
set argnames "(No info available)" |
|
} |
|
return "$subhelp1 $argnames" |
|
} |
|
|
|
} |
|
|
|
set helpstr "" |
|
append helpstr "commands:\n" |
|
|
|
foreach {source cmdlist} $command_info { |
|
append helpstr \n " $source" |
|
foreach cmd $cmdlist { |
|
append helpstr \n " - $cmd" |
|
} |
|
} |
|
return $helpstr |
|
} |
|
proc dostuff {args} { |
|
extension@@opts/@?@-extension,args@@args= [_split_args $args] |
|
|
|
puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'" |
|
} |
|
|
|
}
|
|
|