Index: config.tcl ================================================================== --- config.tcl +++ config.tcl @@ -27,10 +27,13 @@ # @@ Meta End ## - The config manages the argument values, and can parse ## a command line against the definition, filling values, ## issuing errors on mismatches, etc. + +## TODO: Replace the direct ansi color references in state dumps with +## "cmdr::color" and its symbolic names. # # ## ### ##### ######## ############# ##################### ## Requisites package require Tcl 8.5 @@ -83,12 +86,12 @@ forward context context # Make self accessible. method self {} { self } - constructor {context spec} { - debug.cmdr/config {} + constructor {context spec {super {}}} { + debug.cmdr/config {owner=([$context fullname])} classvariable ourinteractive if {![info exists ourinteractive]} { set ourinteractive 0 } classvariable ourdisplay @@ -111,10 +114,19 @@ set myoption {} ;# option -> object set myfullopt {} ;# option prefix -> list of full options having that prefix. set myargs {} ;# List of argument names. set mysections {} set myinforce no + + # Updated in Import and DefineParameter, called from the $spec + set splat no + + # Import from the 'super', if specified. This is done before + # the specification is run, as these have priority. + if {$super ne {}} { + my Import $super + } # Import the DSL commands. link \ {undocumented Undocumented} \ {description Description} \ @@ -123,34 +135,41 @@ {interactive Interactive} \ {option Option} \ {state State} \ {section Section} - # Updated in my DefineParameter, called from the $spec - set splat no - - # Auto inherit common options, state, arguments. - # May not be defined. Pass any other issues. - try { - use *all* - } trap {CMDR STORE UNKNOWN} {e o} { - # Swallow possibility of a missing *all*. - } - eval $spec + if {$spec ne {}} { + debug.cmdr/config {==== eval spec begin ====} + # Auto inherit common options, state, arguments. + # May not be defined. Only done if the context + # has a specification (=> i.e. is private). For officers we start out empty. + try { + use *all* + } trap {CMDR STORE UNKNOWN} {e o} { + # Swallow possibility of a misisng *all*. + } + eval $spec + debug.cmdr/config {==== eval spec done =====} + } # Postprocessing - - my SetThresholds - my UniquePrefixes - my CompletionGraph + my complete-definitions set mypq [struct::queue P] ;# actual parameters if {[llength $myargs]} { set myaq [struct::queue A] ;# formal argument parameters } return } + + method complete-definitions {} { + debug.cmdr/config {} + my SetThresholds + my UniquePrefixes + my CompletionGraph + return + } method help {{mode public}} { debug.cmdr/config {} # command = dict ('desc' -> description # 'options' -> options @@ -171,10 +190,15 @@ set options {} set optpara {} dict for {o para} $myoption { + + # Ignore options imported from the parent. + # These are documented where defined. + if {[$para config] ne [self]} continue + # in interactive mode undocumented options can be shown in # the help if they already have a value defined for them. if {![$para documented] && (($mode ne "interact") || ![$para set?])} continue @@ -200,10 +224,15 @@ set states {} set parameters {} foreach p [lsort -dict $mynames] { set para [dict get $mymap $p] + + # Ignore all parameters imported from the parent. + # These are documented where defined. + if {[$para config] ne [self]} continue + dict set parameters $p [$para help] if {![$para is state]} continue lappend states $p } @@ -508,10 +537,23 @@ method Section {args} { # Remember the help section this private is a part of. lappend mysections $args return } + + # Externally visible variant of the 'Option' specification command. + method make-option {args} { + # Splat is a dummy for this. + set splat no + my DefineParameter 0 1 0 0 {*}$args + } + # Externally visible variant of the 'State' specification command. + method make-state {args} { + # Splat is a dummy for this. + set splat no + my DefineParameter 0 0 1 1 {*}$args + } # Parameter definition itself. # order, cmdline, required, defered (O C R D) name ?spec? forward Input my DefineParameter 1 1 1 0 forward Option my DefineParameter 0 1 0 0 @@ -535,10 +577,21 @@ # Create and initialize handler. set para [cmdr::parameter create param_$name [self] \ $order $cmdline $required $defered \ $name $desc $spec] + my LinkPara $para + return + } + + method LinkPara {para} { + debug.cmdr/config {} + upvar 1 splat splat + + set name [$para name] + set order [$para ordered] + # Map parameter name to handler object. dict set mymap $name $para # And a second map, user-visible parameters only, # i.e. available on the cmdline, and documented. @@ -558,16 +611,40 @@ } # And the list of all parameters in declaration order, for use # in 'force'. lappend mynames $name + + debug.cmdr/config {/done $name} + return + } + + method Import {other} { + debug.cmdr/config {from [$other context fullname]} + + upvar 1 splat splat + # Import the parameters from another config instance + # into ourselves. + + # This is similar to DefineParameter, except that the + # parameter instances are not created. They already exist and + # simply have to be linked into the local data structures. + + foreach name [$other names] { + debug.cmdr/config {importing $name} + my LinkPara [$other lookup $name] + } + + debug.cmdr/config {/done} return } method ValidateAsUnknown {name} { debug.cmdr/config {} if {![dict exists $mymap $name]} return + + debug.cmdr/config {DUP} return -code error -errorcode {CMDR CONFIG KNOWN} \ "Duplicate parameter \"[context fullname]: $name\", already specified." } # # ## ### ##### ######## ############# @@ -811,10 +888,44 @@ P put {*}$arguments debug.cmdr/config {done} return } + + method parse-head-options {args} { + debug.cmdr/config {} + + # - Reset the state values (we might be in an interactive shell, multiple commands). + # - Stash the parameters into a queue for processing. + # - Stash the (ordered) arguments into a second queue. + # - Operate on parameter and arg queues until empty, + # dispatching the words to handlers as needed. + + if {![llength $args]} { return {} } + + my reset + P clear + P put {*}$args + + debug.cmdr/config {options only} + while {[P size]} { + set word [P peek] + debug.cmdr/config {[P size] ? $word} + if {![string match -* $word]} break + my ProcessOption + } + # Non-option found, or end of words reached. + # Return the remainder. + set n [P size] + if {!$n} { + return {} + } elseif {$n == 1} { + return [list [P get]] + } else { + return [P get $n] + } + } method parse {args} { debug.cmdr/config {} # - Reset the state values (we might be in an interactive shell, multiple commands). @@ -944,19 +1055,22 @@ debug.cmdr/config {} # Get option. Do special handling. # Non special option gets dispatched to handler (cmdr::parameter instance). # The handler is responsible for retrieved the option's value. set option [P get] + debug.cmdr/config {taking ($option)} # Handle general special forms: # # --foo=bar ==> --foo bar # -f=bar ==> -f bar if {[regexp {^(-[^=]+)=(.*)$} $option --> option value]} { P unget $value } + + debug.cmdr/config {having ($option)} # Validate existence of the option if {![dict exists $myfullopt $option]} { my raise "Unknown option $option" \ CMDR CONFIG BAD OPTION @@ -1371,6 +1485,6 @@ # # ## ### ##### ######## ############# } # # ## ### ##### ######## ############# ##################### ## Ready -package provide cmdr::config 1.1.1 +package provide cmdr::config 1.2 Index: help.tcl ================================================================== --- help.tcl +++ help.tcl @@ -325,16 +325,16 @@ # # ## ### ##### ######## ############# ##################### ## Show help by category/ies proc ::cmdr::help::format::by-category {root width help} { - debug.cmdr/help {} + debug.cmdr/help {name ([$root name])} # I. Extract the category information from the help structure and # generate the tree of categories with their commands. - lassign [SectionTree $help] subc cmds + lassign [SectionTree $help [$root name]] subc cmds # II. Order the main categories. Allow for user influences. set categories [SectionOrder $root $subc] # III. Take the category tree and do the final formatting. @@ -449,12 +449,13 @@ } else { return {} } } -proc ::cmdr::help::format::SectionTree {help {fmtname 1}} { +proc ::cmdr::help::format::SectionTree {help root {fmtname 1}} { + array set opts {} ;# cmd -> option -> odesc array set subc {} ;# category path -> list (child category path) array set cmds {} ;# category path -> list (cmd) # cmd = tuple (label description) dict for {name def} $help { @@ -462,29 +463,58 @@ # Do not show the auto-generated commands in the categorized help. if {"*AutoGenerated*" in $sections} { continue } + + # Exclude officers from the categorized help. They can only be + # a source of shared options. Shared options are collected in + # a separate structure. + if {![info exists action] && [dict size $options]} { + set opts($name) $options + continue + } + if {![llength $sections]} { lappend sections Miscellaneous } if {$fmtname} { append name " " [Arguments $arguments $parameters] } set desc [lindex [split $desc .] 0] - set cmd [::list $name $desc] + set cmd [::list [string trim $name] $desc] foreach category $sections { lappend cmds($category) $cmd LinkParent $category } } - #parray subc - #parray cmds + # Options for the root => global options, put into the section tree. + # We are ignoring deeper shared options. + + if {[info exists opts($root)]} { + set options $opts($root) + + set category {Global Options} + lappend sections $category + set category [::list $category] + foreach {o d} $options { + lappend cmds($category) [::list $o [string trim $d]] + LinkParent $category + } + + unset opts($root) + } + + # puts ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # parray subc + # parray cmds + # parray opts + # puts ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ::list [array get subc] [array get cmds] } proc ::cmdr::help::format::LinkParent {category} { @@ -497,25 +527,33 @@ } proc ::cmdr::help::format::SectionOrder {root subc} { # IIa. Natural order first. set categories [lsort -dict -unique [dict get $subc {}]] + + set generated { + Miscellaneous + {Global Options} + } # IIb. Look for and apply user overrides. if {[$root exists *category-order*]} { # Record natural order set n 0 foreach c $categories { dict set map $c $n incr n -10 } - # Special treatment of generated category, move to end. - if {"Miscellaneous" in $categories} { - dict set map Miscellaneous -10000 + # Special treatment of generated categories, move to end. + set end -10000 + foreach $c generated { + if {$c ni $categories} continue + dict set map $c $end + incr end -10000 } # Overwrite natural with custom ordering. - dict for {c n} [$root get *category-order*] { + dict for {c n} [$root get *category-order*] { if {$c ni $categories} continue dict set map $c $n } # Rewrite into tuples. foreach {c n} $map { @@ -529,19 +567,20 @@ set categories {} foreach item [lsort -decreasing -integer -index 0 $tmp] { lappend categories [lindex $item 1] } } else { - # Without bespoke ordering only the generated category gets + # Without a bespoke ordering only the generated categories are # treated specially. - set pos [lsearch -exact $categories Miscellaneous] - if {$pos >= 0} { - set categories [linsert [lreplace $categories $pos $pos] end Miscellaneous] + foreach c $generated { + set pos [lsearch -exact $categories $c] + if {$pos < 0} continue + set categories [linsert [lreplace $categories $pos $pos] end $c] } } return $categories } # # ## ### ##### ######## ############# ##################### ## Ready package provide cmdr::help 1.3 Index: help_json.tcl ================================================================== --- help_json.tcl +++ help_json.tcl @@ -64,11 +64,11 @@ # Step 2. Section Tree. This is very similar to # cmdr::help::format::by-category, and re-uses its frontend helper # commands. - lassign [SectionTree $help 0] subc cmds + lassign [SectionTree $help \000 0] subc cmds foreach c [SectionOrder $root $subc] { lappend sections [JSON::acategory [::list $c] $cmds $subc] } return [json::write object \ @@ -112,11 +112,14 @@ dict with command {} # -> action, desc, options, arguments, parameters, states, sections lappend dict description [JSON::astring $desc] - lappend dict action [JSON::alist $action] + if {[info exists action]} { + # Missing for officers. + lappend dict action [JSON::alist $action] + } lappend dict arguments [JSON::alist $arguments] lappend dict options [JSON::adict $options] lappend dict opt2para [JSON::adict $opt2para] lappend dict states [JSON::alist $states] lappend dict parameters [JSON::parameters $parameters] @@ -201,6 +204,6 @@ return [json::write string [string trim $string]] } # # ## ### ##### ######## ############# ##################### ## Ready -package provide cmdr::help::json 1.0.1 +package provide cmdr::help::json 1.1 Index: help_sql.tcl ================================================================== --- help_sql.tcl +++ help_sql.tcl @@ -99,12 +99,19 @@ # --- dict with command {} ; # -> action, desc, options, arguments, parameters, states - set cid [SQL::++ commands cno [SQL::astring $name] \ - [SQL::astring $desc] [SQL::astring $action]] + if {[info exists action]} { + set action [SQL::astring $action] + } { + set action NULL + } + set cid [SQL::++ commands cno \ + [SQL::astring $name] \ + [SQL::astring $desc] \ + $action] set sequence 0 foreach {pname param} $parameters { set pid [SQL::++ parameters pno [SQL::astring $pname] \ $cid $sequence \ @@ -291,6 +298,6 @@ CREATE INDEX fname on flags ( name ); } } # # ## ### ##### ######## ############# ##################### ## Ready -package provide cmdr::help::sql 1.0 +package provide cmdr::help::sql 1.1 Index: help_tcl.tcl ================================================================== --- help_tcl.tcl +++ help_tcl.tcl @@ -60,11 +60,11 @@ # Step 2. Section Tree. This is very similar to # cmdr::help::format::by-category, and re-uses its frontend helper # commands. - lassign [SectionTree $help 0] subc cmds + lassign [SectionTree $help \000 0] subc cmds foreach c [SectionOrder $root $subc] { lappend sections [TCL::acategory [::list $c] $cmds $subc] } return [dict create \ @@ -106,11 +106,14 @@ # Data structure: see private.tcl, method 'help'. dict with command {} # -> action, desc, options, arguments, parameters, states, sections - lappend dict action $action + if {[info exists action]} { + # Missing for officers. + lappend dict action $action + } lappend dict arguments $arguments lappend dict description [TCL::astring $desc] lappend dict opt2para [::cmdr util dictsort $opt2para] lappend dict options [::cmdr util dictsort $options] lappend dict parameters [TCL::parameters $parameters] @@ -180,6 +183,6 @@ return [string trim $string] } # # ## ### ##### ######## ############# ##################### ## Ready -package provide cmdr::help::tcl 1.0.1 +package provide cmdr::help::tcl 1.1 Index: officer.tcl ================================================================== --- officer.tcl +++ officer.tcl @@ -24,27 +24,28 @@ # Meta require debug::caller # Meta require linenoise::facade # Meta require try # Meta require {Tcl 8.5-} # Meta require {oo::util 1.2} -# Meta require {string::token::shell 1.1} +# Meta require {string::token::shell 1.2} # @@ Meta End # # ## ### ##### ######## ############# ##################### ## Requisites package require Tcl 8.5 package require debug package require debug::caller package require linenoise::facade -package require string::token::shell 1.1 +package require string::token::shell 1.2 package require try package require TclOO package require oo::util 1.2 ;# link helper. package require cmdr::actor package require cmdr::private package require cmdr::help +package require cmdr::config # # ## ### ##### ######## ############# ##################### debug define cmdr/officer debug level cmdr/officer @@ -85,10 +86,11 @@ set myccommands {} ; # Ditto, derived cache, see method CCommands. set mychildren {} ; # List of created subordinates. set myhandler {} ; # Handler around cmd parsing and execution. set myshandler {} ; # Setup handler, run after regular object # # initialization from its definition. + set myconfig {} return } # # ## ### ##### ######## ############# @@ -185,10 +187,16 @@ method children {} { debug.cmdr/officer {} my Setup return $mychildren } + + # Make the parameter container accessible. + method config {} { + debug.cmdr/officer {} + return $myconfig + } # # ## ### ##### ######## ############# ## Internal. Dispatcher setup. Defered until required. ## Core setup code runs only once. @@ -196,11 +204,18 @@ # Process the action specification only once. if {$myinit} return set myinit 1 debug.cmdr/officer {} + set super [my super] + if {$super ne {}} { + set super [$super config] + } + + set myconfig [cmdr::config create config [self] {} $super] my learn $myactions + $myconfig complete-definitions # Auto-create a 'help' command when possible, i.e not in # conflict with a user-specified command. if {![my has help]} { cmdr help auto [self] @@ -240,11 +255,13 @@ {officer Officer} \ {default Default} \ {alias Alias} \ {description description:} \ undocumented \ - {common set} + {common set} \ + {option Option} \ + {state State} eval $script # Postprocessing. set mycommands [lsort -dict $mycommands] return @@ -272,10 +289,13 @@ [my lookup $cmd] extend $path $arguments $action } # # ## ### ##### ######## ############# ## Implementation of the action specification language. + + forward Option config make-option + forward State config make-state # common => set (super cmdr::actor) # description => description: (super cmdr::actor) forward Private my DefineAction private @@ -435,10 +455,14 @@ # Prevent handling of application-specific options here. my set *command* -- $args set reset 1 } try { + # Process any options we may find. The first non-option + # will be the command to dispatch on. + set arg [config parse-head-options {*}$args] + # Empty command. Delegate to the default, if we have any. # Otherwise fail. if {![llength $args]} { if {[my hasdefault]} { return [[my lookup [my default]] do] @@ -516,11 +540,11 @@ # See method 'shell-exit' as well, and 'Setup' for # the auto-creation of an 'exit' command when possible, # i.e not in conflict with a user-specified command. set myreplexit 1 ; return } - my Do {*}[string token shell $cmd] + my Do {*}[string token shell -- $cmd] } method report {what data} { debug.cmdr/officer {} switch -exact -- $what { @@ -712,19 +736,23 @@ set cname [list {*}$prefix $c] set actor [my lookup $c] if {![$actor documented]} continue set help [dict merge $help [$actor help $cname]] } + + # Add the officer itself, to provide its shared options. + dict set help $prefix [config help] + return $help } # # ## ### ##### ######## ############# variable myinit myactions mymap mycommands myccommands mychildren \ - myreplexit myhandler mypmap myshandler + myreplexit myhandler mypmap myshandler myconfig # # ## ### ##### ######## ############# } # # ## ### ##### ######## ############# ##################### ## Ready -package provide cmdr::officer 1.3 +package provide cmdr::officer 1.4 Index: private.tcl ================================================================== --- private.tcl +++ private.tcl @@ -114,12 +114,14 @@ # Process myarguments only once. if {$myinit} return debug.cmdr/private {} set myinit 1 - # Create and fill the parameter collection - set myconfig [cmdr::config create config [self] $myarguments] + # Create and fill the parameter collection. + set myconfig [cmdr::config create config [self] \ + $myarguments \ + [[my super] config]] return } # # ## ### ##### ######## ############# @@ -210,6 +212,6 @@ # # ## ### ##### ######## ############# } # # ## ### ##### ######## ############# ##################### ## Ready -package provide cmdr::private 1.2 +package provide cmdr::private 1.3