cmdr
Check-in [fc97d9c23b]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Make handling of shared options official.
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:fc97d9c23b7264b8ab8492c6cf590360f597fcfe
User & Date: andreask 2014-08-26 19:45:53
Context
2014-08-26
19:58
Fix oops. check-in: febbd538cd user: andreask tags: trunk
19:45
Make handling of shared options official. check-in: fc97d9c23b user: andreask tags: trunk
19:45
Updated help generation to show global options in categorized help. General update to handle officers now appearing in the help structures. Bumped version numbers. All parts done. Notes removed. Closed-Leaf check-in: f853a46223 user: andreask tags: global-options
2014-08-21
01:49
Fix handling of *all*. Ignoring a missing definition is ok. Ignoring all other specification errors it may generate is not. check-in: 9159f68bc3 user: andreask tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to config.tcl.

25
26
27
28
29
30
31



32
33
34
35
36
37
38
..
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
...
109
110
111
112
113
114
115









116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132

133
134
135
136
137
138

139
140
141
142
143
144
145
146
147
148
149
150
151








152
153
154
155
156
157
158
...
169
170
171
172
173
174
175





176
177
178
179
180
181
182
...
198
199
200
201
202
203
204





205
206
207
208
209
210
211
...
506
507
508
509
510
511
512













513
514
515
516
517
518
519
...
533
534
535
536
537
538
539











540
541
542
543
544
545
546
...
556
557
558
559
560
561
562






















563
564
565
566
567
568


569
570
571
572
573
574
575
...
809
810
811
812
813
814
815


































816
817
818
819
820
821
822
...
942
943
944
945
946
947
948

949
950
951
952
953
954
955
956
957


958
959
960
961
962
963
964
....
1369
1370
1371
1372
1373
1374
1375
1376
# Meta require {struct::queue 1}

# @@ Meta End

## - The config manages the argument values, and can parse
##   a command line against the definition, filling values,
##   issuing errors on mismatches, etc.




# # ## ### ##### ######## ############# #####################
## Requisites

package require Tcl 8.5
package require debug
package require debug::caller
................................................................................
    ## Lifecycle.

    forward context context

    # Make self accessible.
    method self {} { self }

    constructor {context spec} {
	debug.cmdr/config {}

	classvariable ourinteractive
	if {![info exists ourinteractive]} { set ourinteractive 0 }

	classvariable ourdisplay
	if {[info exists ourdisplay]} {
	    set mydisplay $ourdisplay
................................................................................
	set mymap      {} ;# parameter name -> object
	set mypub      {} ;# parameter name -> object, non-state only, i.e. user visible
	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










	# Import the DSL commands.
	link \
	    {undocumented Undocumented} \
	    {description  Description} \
	    {use          Use} \
	    {input        Input} \
	    {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


	# Postprocessing

	my SetThresholds
	my UniquePrefixes
	my CompletionGraph

	set mypq [struct::queue P] ;# actual parameters
	if {[llength $myargs]} {
	    set myaq [struct::queue A] ;# formal argument parameters
	}
	return
    }









    method help {{mode public}} {
	debug.cmdr/config {}
	# command   = dict ('desc'       -> description
	#                   'options'    -> options
	#                   'arguments'  -> arguments
	#                   'parameters' -> parameters)
................................................................................
	#
	# Option aliases are listed in options, but not in parameters.

	set options {}
	set optpara {}

	dict for {o para} $myoption {





	    # 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

	    # in interactive mode we skip all the aliases.
................................................................................
	# not just bits and pieces.

	set states     {}
	set parameters {}

	foreach p [lsort -dict $mynames] {
	    set para [dict get $mymap $p]





	    dict set parameters $p [$para help]

	    if {![$para is state]} continue
	    lappend states $p
	}

	return [dict create \
................................................................................
    }

    method Section {args} {
	# Remember the help section this private is a part of.
	lappend mysections $args
	return
    }














    # 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
    forward State     my DefineParameter 0 0 1 1
    # O+C+R specify the parameter type. D may vary.
................................................................................
	my ValidateAsUnknown $name

	# Create and initialize handler.
	set para [cmdr::parameter create param_$name [self] \
		      $order $cmdline $required $defered \
		      $name $desc $spec]












	# 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.
	if {[$para cmdline] && [$para documented]} {
	    dict set mypub $name $para
................................................................................
		dict set myoption $option $para
	    }
	}

	# And the list of all parameters in declaration order, for use
	# in 'force'.
	lappend mynames $name






















	return
    }

    method ValidateAsUnknown {name} {
	debug.cmdr/config {}
	if {![dict exists $mymap $name]} return


	return -code error -errorcode {CMDR CONFIG KNOWN} \
	    "Duplicate parameter \"[context fullname]: $name\", already specified."
    }

    # # ## ### ##### ######## #############
    ## Command completion. This is the entry point for recursion from
    ## the higher level officers, delegated to config from cmdr::private
................................................................................
	    return
	}
	P put {*}$arguments

	debug.cmdr/config {done}
	return
    }



































    method parse {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.
................................................................................

    method ProcessOption {} {
	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]


	# Handle general special forms:
	#
	# --foo=bar ==> --foo bar
	# -f=bar    ==> -f bar

	if {[regexp {^(-[^=]+)=(.*)$} $option --> option value]} {
	    P unget $value
	}



	# Validate existence of the option
	if {![dict exists $myfullopt $option]} {
	    my raise "Unknown option $option" \
		CMDR CONFIG BAD OPTION
	}

................................................................................
    }

    # # ## ### ##### ######## #############
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::config 1.1.1







>
>
>







 







|
|







 







>
>
>
>
>
>
>
>
>












|
|
<
|
|
>
|
|
|
|
|
|
>
|
<

|
|
<







>
>
>
>
>
>
>
>







 







>
>
>
>
>







 







>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>









>
>







 







|
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
..
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
...
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141

142
143
144
145
146
147
148
149
150
151
152

153
154
155

156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
...
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
...
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
...
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
...
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
...
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
...
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
....
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
....
1483
1484
1485
1486
1487
1488
1489
1490
# Meta require {struct::queue 1}

# @@ 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
package require debug
package require debug::caller
................................................................................
    ## Lifecycle.

    forward context context

    # Make self accessible.
    method self {} { self }

    constructor {context spec {super {}}} {
	debug.cmdr/config {owner=([$context fullname])}

	classvariable ourinteractive
	if {![info exists ourinteractive]} { set ourinteractive 0 }

	classvariable ourdisplay
	if {[info exists ourdisplay]} {
	    set mydisplay $ourdisplay
................................................................................
	set mymap      {} ;# parameter name -> object
	set mypub      {} ;# parameter name -> object, non-state only, i.e. user visible
	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} \
	    {use          Use} \
	    {input        Input} \
	    {interactive  Interactive} \
	    {option       Option} \
	    {state        State} \
	    {section      Section}

	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 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
	#                   'arguments'  -> arguments
	#                   'parameters' -> parameters)
................................................................................
	#
	# Option aliases are listed in options, but not in parameters.

	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

	    # in interactive mode we skip all the aliases.
................................................................................
	# not just bits and pieces.

	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
	}

	return [dict create \
................................................................................
    }

    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
    forward State     my DefineParameter 0 0 1 1
    # O+C+R specify the parameter type. D may vary.
................................................................................
	my ValidateAsUnknown $name

	# 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.
	if {[$para cmdline] && [$para documented]} {
	    dict set mypub $name $para
................................................................................
		dict set myoption $option $para
	    }
	}

	# 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."
    }

    # # ## ### ##### ######## #############
    ## Command completion. This is the entry point for recursion from
    ## the higher level officers, delegated to config from cmdr::private
................................................................................
	    return
	}
	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).
	# - Stash the parameters into a queue for processing.
	# - Stash the (ordered) arguments into a second queue.
................................................................................

    method ProcessOption {} {
	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
	}

................................................................................
    }

    # # ## ### ##### ######## #############
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::config 1.2

Changes to help.tcl.

323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
...
447
448
449
450
451
452
453
454
455

456
457
458
459
460
461
462
463
464
465
466









467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483


















484
485


486
487
488
489
490
491
492
...
495
496
497
498
499
500
501





502
503
504
505
506
507
508
509
510
511
512


513

514
515
516
517
518
519
520
521
522
523
...
527
528
529
530
531
532
533
534
535

536
537
538
539
540
541
542
543
544
545
546
547
    return [join $lines \n]
}

# # ## ### ##### ######## ############# #####################
## Show help by category/ies

proc ::cmdr::help::format::by-category {root width help} {
    debug.cmdr/help {}

    # I. Extract the category information from the help structure and
    #    generate the tree of categories with their commands.

    lassign [SectionTree $help] 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.
    set lines {}
    foreach c $categories {
................................................................................
    if {[dict size $options]} {
	return "\[OPTIONS\] "
    } else {
	return {}
    }
}

proc ::cmdr::help::format::SectionTree {help {fmtname 1}} {


    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 {
	dict with def {} ; # -> desc, arguments, parameters, sections

	# Do not show the auto-generated commands in the categorized help.
	if {"*AutoGenerated*" in $sections} {
	    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]

	foreach category $sections {
	    lappend cmds($category) $cmd
	    LinkParent $category
	}
    }



















    #parray subc
    #parray cmds



    ::list [array get subc] [array get cmds]
}

proc ::cmdr::help::format::LinkParent {category} {
    if {![llength $category]} return
    upvar 1 subc subc
................................................................................
    LinkParent $parent
    return
}

proc ::cmdr::help::format::SectionOrder {root subc} {
    # IIa. Natural order first.
    set categories [lsort -dict -unique [dict get $subc {}]]






    # 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

	}
	# Overwrite natural with custom ordering.
	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 {
	    lappend tmp [::list $n $c]
	}
................................................................................
	# Sort tuples into chosen order, and rewrite back to list of
	# plain categories.
	set categories {}
	foreach item [lsort -decreasing -integer -index 0 $tmp] {
	    lappend categories [lindex $item 1]
	}
    } else {
	# Without bespoke ordering only the generated category gets
	# treated specially.

	set pos [lsearch -exact $categories Miscellaneous]
	if {$pos >= 0} {
	    set categories [linsert [lreplace $categories $pos $pos] end Miscellaneous]
	}
    }

    return $categories
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::help 1.3







|




|







 







|

>











>
>
>
>
>
>
>
>
>









|







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
>
>







 







>
>
>
>
>









|
|
>
>
|
>


|







 







|

>
|
|
|









323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
...
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
...
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
...
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
    return [join $lines \n]
}

# # ## ### ##### ######## ############# #####################
## Show help by category/ies

proc ::cmdr::help::format::by-category {root width 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 [$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.
    set lines {}
    foreach c $categories {
................................................................................
    if {[dict size $options]} {
	return "\[OPTIONS\] "
    } else {
	return {}
    }
}

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 {
	dict with def {} ; # -> desc, arguments, parameters, sections

	# 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 [string trim $name] $desc]

	foreach category $sections {
	    lappend cmds($category) $cmd
	    LinkParent $category
	}
    }

    # 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} {
    if {![llength $category]} return
    upvar 1 subc subc
................................................................................
    LinkParent $parent
    return
}

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 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*] {
	    if {$c ni $categories} continue
	    dict set map $c $n
	}
	# Rewrite into tuples.
	foreach {c n} $map {
	    lappend tmp [::list $n $c]
	}
................................................................................
	# Sort tuples into chosen order, and rewrite back to list of
	# plain categories.
	set categories {}
	foreach item [lsort -decreasing -integer -index 0 $tmp] {
	    lappend categories [lindex $item 1]
	}
    } else {
	# Without a bespoke ordering only the generated categories are
	# treated specially.
	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

Changes to help_json.tcl.

62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
...
110
111
112
113
114
115
116


117

118
119
120
121
122
123
124
...
199
200
201
202
203
204
205
206
    set commands [json::write object {*}$dict]


    # 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
    foreach c [SectionOrder $root $subc] {
	lappend sections [JSON::acategory [::list $c] $cmds $subc]
    }

    return [json::write object \
		sections [json::write array {*}$sections] \
		commands $commands]
................................................................................
    # Data structure: see config.tcl,  method 'help'.
    # Data structure: see private.tcl, method 'help'.

    dict with command {}
    # -> action, desc, options, arguments, parameters, states, sections

    lappend dict description [JSON::astring    $desc]


    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]
    lappend dict sections    [JSON::alist      $sections]
    
................................................................................
proc ::cmdr::help::format::JSON::astring {string} {
    regsub -all -- {[ \n\t]+} $string { } string
    return [json::write string [string trim $string]]
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::help::json 1.0.1







|







 







>
>
|
>







 







|
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
...
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
...
202
203
204
205
206
207
208
209
    set commands [json::write object {*}$dict]


    # Step 2. Section Tree. This is very similar to
    # cmdr::help::format::by-category, and re-uses its frontend helper
    # commands.

    lassign [SectionTree $help \000 0] subc cmds
    foreach c [SectionOrder $root $subc] {
	lappend sections [JSON::acategory [::list $c] $cmds $subc]
    }

    return [json::write object \
		sections [json::write array {*}$sections] \
		commands $commands]
................................................................................
    # Data structure: see config.tcl,  method 'help'.
    # Data structure: see private.tcl, method 'help'.

    dict with command {}
    # -> action, desc, options, arguments, parameters, states, sections

    lappend dict description [JSON::astring    $desc]
    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]
    lappend dict sections    [JSON::alist      $sections]
    
................................................................................
proc ::cmdr::help::format::JSON::astring {string} {
    regsub -all -- {[ \n\t]+} $string { } string
    return [json::write string [string trim $string]]
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::help::json 1.1

Changes to help_sql.tcl.

97
98
99
100
101
102
103





104

105

106
107
108
109
110
111
112
...
289
290
291
292
293
294
295
296
    upvar 1 states     xstates
    upvar 1 flags      xflags

    # ---

    dict with command {} ; # -> action, desc, options, arguments, parameters, states






    set cid [SQL::++ commands cno [SQL::astring $name] \

		 [SQL::astring $desc] [SQL::astring $action]]


    set sequence 0
    foreach {pname param} $parameters {
	set pid [SQL::++ parameters pno [SQL::astring $pname] \
		     $cid $sequence \
		     {*}[SQL::para $param]]

................................................................................
	       pid  INTEGER REFERENCES parameters
       );
	CREATE INDEX fname on flags ( name );
    }
}
# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::help::sql 1.0







>
>
>
>
>
|
>
|
>







 







|
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
...
296
297
298
299
300
301
302
303
    upvar 1 states     xstates
    upvar 1 flags      xflags

    # ---

    dict with command {} ; # -> action, desc, options, arguments, parameters, states

    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 \
		     {*}[SQL::para $param]]

................................................................................
	       pid  INTEGER REFERENCES parameters
       );
	CREATE INDEX fname on flags ( name );
    }
}
# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::help::sql 1.1

Changes to help_tcl.tcl.

58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
...
104
105
106
107
108
109
110


111

112
113
114
115
116
117
118
...
178
179
180
181
182
183
184
185
	lappend commands $cmd [TCL $desc]
    }

    # 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
    foreach c [SectionOrder $root $subc] {
	lappend sections [TCL::acategory [::list $c] $cmds $subc]
    }

    return [dict create \
		commands $commands \
		sections $sections]
................................................................................
proc ::cmdr::help::format::TCL {command} {
    # Data structure: see config.tcl,  method 'help'.
    # Data structure: see private.tcl, method 'help'.

    dict with command {}
    # -> action, desc, options, arguments, parameters, states, sections



    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]
    lappend dict sections    $sections
    lappend dict states      $states
................................................................................
proc ::cmdr::help::format::TCL::astring {string} {
    regsub -all -- {[ \n\t]+} $string { } string
    return [string trim $string]
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::help::tcl 1.0.1







|







 







>
>
|
>







 







|
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
...
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
...
181
182
183
184
185
186
187
188
	lappend commands $cmd [TCL $desc]
    }

    # Step 2. Section Tree. This is very similar to
    # cmdr::help::format::by-category, and re-uses its frontend helper
    # commands.

    lassign [SectionTree $help \000 0] subc cmds
    foreach c [SectionOrder $root $subc] {
	lappend sections [TCL::acategory [::list $c] $cmds $subc]
    }

    return [dict create \
		commands $commands \
		sections $sections]
................................................................................
proc ::cmdr::help::format::TCL {command} {
    # Data structure: see config.tcl,  method 'help'.
    # Data structure: see private.tcl, method 'help'.

    dict with command {}
    # -> action, desc, options, arguments, parameters, states, sections

    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]
    lappend dict sections    $sections
    lappend dict states      $states
................................................................................
proc ::cmdr::help::format::TCL::astring {string} {
    regsub -all -- {[ \n\t]+} $string { } string
    return [string trim $string]
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::help::tcl 1.1

Changes to officer.tcl.

22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

46
47
48
49
50
51
52
..
83
84
85
86
87
88
89

90
91
92
93
94
95
96
...
183
184
185
186
187
188
189






190
191
192
193
194
195
196
197
198
199
200






201

202
203
204
205
206
207
208
...
238
239
240
241
242
243
244
245


246
247
248
249
250
251
252
...
270
271
272
273
274
275
276



277
278
279
280
281
282
283
...
433
434
435
436
437
438
439




440
441
442
443
444
445
446
...
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
...
710
711
712
713
714
715
716




717
718
719
720
721
722
723
724
725
726
727
728
729
730
# Meta require cmdr::private
# Meta require debug
# 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 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 try
package require TclOO
package require oo::util 1.2 ;# link helper.
package require cmdr::actor
package require cmdr::private
package require cmdr::help


# # ## ### ##### ######## ############# #####################

debug define cmdr/officer
debug level  cmdr/officer
debug prefix cmdr/officer {[debug caller] | }

................................................................................
	set mypmap      {}       ; # Ditto for the map of action abbreviations.
	set mycommands  {}       ; # Ditto
	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.

	return
    }

    # # ## ### ##### ######## #############

    method ehandler {cmd} {
	debug.cmdr/officer {}
................................................................................
    }

    method children {} {
	debug.cmdr/officer {}
	my Setup
	return $mychildren
    }







    # # ## ### ##### ######## #############
    ## Internal. Dispatcher setup. Defered until required.
    ## Core setup code runs only once.

    method Setup {} {
	# Process the action specification only once.
	if {$myinit} return
	set myinit 1
	debug.cmdr/officer {}







	my learn $myactions


	# 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]
	}

................................................................................
	    {shandler    shandler} \
	    {private     Private} \
	    {officer     Officer} \
	    {default     Default} \
	    {alias       Alias} \
	    {description description:} \
	    undocumented \
	    {common      set}


	eval $script

	# Postprocessing.
	set mycommands [lsort -dict $mycommands]
	return
    }

................................................................................
	}

	[my lookup $cmd] extend $path $arguments $action
    }

    # # ## ### ##### ######## #############
    ## Implementation of the action specification language.




    # common      => set          (super cmdr::actor)
    # description => description: (super cmdr::actor)

    forward Private my DefineAction private
    forward Officer my DefineAction officer

................................................................................
	set reset 0
	if {![my exists *command*]} {
	    # Prevent handling of application-specific options here.
	    my set *command* -- $args
	    set reset 1
	}
	try {




	    # Empty command. Delegate to the default, if we have any.
	    # Otherwise fail.
	    if {![llength $args]} {
		if {[my hasdefault]} {
		    return [[my lookup [my default]] do]
		}
		return -code error -errorcode {CMDR DO EMPTY} \
................................................................................

	if {$cmd eq ".exit"} {
	    # 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]
    }

    method report {what data} {
	debug.cmdr/officer {}
	switch -exact -- $what {
	    ok {
		if {$data eq {}} return
................................................................................
	set help {}
	foreach c [my known] {
	    set cname [list {*}$prefix $c]
	    set actor [my lookup $c]
	    if {![$actor documented]} continue
	    set help [dict merge $help [$actor help $cname]]
	}




	return $help
    }

    # # ## ### ##### ######## #############

    variable myinit myactions mymap mycommands myccommands mychildren \
	myreplexit myhandler mypmap myshandler

    # # ## ### ##### ######## #############
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::officer 1.3







|









|






>







 







>







 







>
>
>
>
>
>











>
>
>
>
>
>

>







 







|
>
>







 







>
>
>







 







>
>
>
>







 







|







 







>
>
>
>






|






|
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
..
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
...
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
...
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
...
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
...
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
...
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
...
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
# Meta require cmdr::private
# Meta require debug
# 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.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.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
debug prefix cmdr/officer {[debug caller] | }

................................................................................
	set mypmap      {}       ; # Ditto for the map of action abbreviations.
	set mycommands  {}       ; # Ditto
	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
    }

    # # ## ### ##### ######## #############

    method ehandler {cmd} {
	debug.cmdr/officer {}
................................................................................
    }

    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.

    method Setup {} {
	# 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]
	}

................................................................................
	    {shandler    shandler} \
	    {private     Private} \
	    {officer     Officer} \
	    {default     Default} \
	    {alias       Alias} \
	    {description description:} \
	    undocumented \
	    {common      set} \
	    {option      Option} \
	    {state       State}
	eval $script

	# Postprocessing.
	set mycommands [lsort -dict $mycommands]
	return
    }

................................................................................
	}

	[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
    forward Officer my DefineAction officer

................................................................................
	set reset 0
	if {![my exists *command*]} {
	    # 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]
		}
		return -code error -errorcode {CMDR DO EMPTY} \
................................................................................

	if {$cmd eq ".exit"} {
	    # 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]
    }

    method report {what data} {
	debug.cmdr/officer {}
	switch -exact -- $what {
	    ok {
		if {$data eq {}} return
................................................................................
	set help {}
	foreach c [my known] {
	    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 myconfig

    # # ## ### ##### ######## #############
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::officer 1.4

Changes to private.tcl.

112
113
114
115
116
117
118
119
120


121
122
123
124
125
126
127
...
208
209
210
211
212
213
214
215

    method Setup {} {
	# 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]


	return
    }

    # # ## ### ##### ######## #############

    method FullCmd {cmd} {
	# See also officer::Do
................................................................................
    variable myarguments mycmd myinit myconfig myhandler

    # # ## ### ##### ######## #############
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::private 1.2







|
|
>
>







 







|
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
...
210
211
212
213
214
215
216
217

    method Setup {} {
	# 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 \
			  [[my super] config]]
	return
    }

    # # ## ### ##### ######## #############

    method FullCmd {cmd} {
	# See also officer::Do
................................................................................
    variable myarguments mycmd myinit myconfig myhandler

    # # ## ### ##### ######## #############
}

# # ## ### ##### ######## ############# #####################
## Ready
package provide cmdr::private 1.3