# -*- tcl -*- # # ## ### ##### ######## ############# ##################### if 0 {tcltest::customMatch exact Seq ; proc Seq {a b} { if {$a ne $b} { puts A|[string map [list "\[" "<" " " "\S" "\n" "\\N" "\t" "\\T"] $a]| puts B|[string map [list "\[" "<" " " "\S" "\n" "\\N" "\t" "\\T"] $b]| } string equal $a $b }} # # ## ### ##### ######## ############# ##################### ## Standard help structures proc HelpLarge {format {n 50}} { Help { description TEST officer bar { private aloha { description hawaii option lulu loop {} input yoyo height input jump gate { optional } input run lane { list } } ::hula } default alias snafu officer tool { officer pliers {} officer hammer { private nail { description workbench option driver force { validate adouble ; default 0 ; list ; alias force } state context orientation input supply magazine { list ; optional } } ::wall } default hammer } alias hammer = tool hammer private hidden { undocumented } ::missing officer stealth { undocumented private cloak {} ::dagger } } $format $n } proc HelpSmall {format {n 50}} { Help { description TEST private nail { description workbench option no-driver force { list ; alias force } } ::wall } $format $n } proc Help {def format n} { try { cmdr create x foo $def string trimright [cmdr help format $format x $n [x help]] \n } finally { x destroy } } # # ## ### ##### ######## ############# ##################### ## Supporting procedures for cmdr.test et. al. proc StartNotes {} { set ::result {} ; return } proc Note {args} { lappend ::result $args ; return } proc StopNotes {} { unset ::result ; return } proc Notes {} { Wrap $::result } proc NiceParamSpec {kind spec {name A}} { try { cmdr create x foo [list private bar [list $kind $name - $spec] {}] ShowPrivate [x lookup bar] } finally { x destroy } } proc BadParamSpec {kind spec} { try { cmdr create x foo [list private bar [list $kind A A $spec] {}] [x lookup bar] keys } finally { x destroy } } proc Parse {spec args} { upvar 1 ons ons try { cmdr create x foo \ [list private bar $spec \ {::apply {{config} {}}}] # Eval the spec first. [x lookup bar] keys if {[info exists ons]} { # x = officer, bar = private, ons = parameter set ons [info object namespace [[x lookup bar] lookup $ons]] } # Now the runtime args processing. [x lookup bar] do {*}$args ShowParsed [x lookup bar] } finally { x destroy } } proc ParseFailParse {spec args} { upvar 1 ons ons try { cmdr create x foo \ [list private bar $spec \ {::apply {{config} {}}}] # Eval the spec first. [x lookup bar] keys if {[info exists ons]} { # x = officer, bar = private, ons = parameter set ons [info object namespace [[x lookup bar] lookup $ons]] } # Now the runtime args processing. [x lookup bar] do {*}$args } finally { x destroy } } # # ## ### ##### ######## ############# ##################### proc ShowOfficer {o} { Wrap [DumpOfficer $o] } proc ShowPrivate {o} { Wrap [DumpPrivate $o] } proc ShowParsed {o} { Wrap [DumpParsed $o] } # Indent a list of lines, generate text block. proc Wrap {list} { set p "\n " return ${p}[join $list $p]\n } # Dumping the state of an officer and its subordinates. # Assumes that the children are all oficers too, and not privates. # This may be fixable. proc DumpOfficer {o} { set name [$o fullname] set result {} # Description lappend result "$name = \{" lappend result " description: '[$o description]'" # Default action, if any. if {[$o hasdefault]} { lappend result " default: [$o default]" } else { lappend result " no default" } # Data store. Note how it shows the entire inherited store, not # just the local settings. foreach k [lsort -dict [$o keys]] { lappend result " store ($k): '[$o get $k]'" } # Delegates - Action mapping foreach a [lsort -dict [$o known]] { set c [$o lookup $a] lappend result " $a --> [$c name]" } lappend result "\}" # Delegates II. Full dump of the subordinates. set tmp {} foreach c [$o children] { lappend tmp [list $c [$c name]] } foreach item [lsort -dict -index 1 $tmp] { lassign $item c _ if {[info object class $c] eq "::cmdr::private"} continue lappend result {*}[DumpOfficer $c] } return $result } # Dumping the state of a private and its parameters. proc DumpPrivate {o} { set name [$o fullname] set result {} # Description lappend result "$name = \{" lappend result " description: '[$o description]'" # Data store. Inherited. Note how it shows the entire inherited # store, not just the local settings. Which a private usually has # none of. foreach k [lsort -dict [$o keys]] { lappend result " store ($k): '[$o get $k]'" } # List the argument and option parameters. foreach name [lsort -dict [$o arguments]] { lappend result " argument ($name)" } foreach name [lsort -dict [$o options]] { lappend result " option ($name) = [[$o lookup-option $name] name]" } # List the mapping from option prefixes to the list of full options. foreach {opt v} [kt dictsort [$o eoptions]] { lappend result " map $opt --> ($v)" } # Lastly, show the full state of all parameters. foreach name [lsort -dict [$o names]] { set c [$o lookup $name] lappend result " para ($name) \{" lappend result " description: '[$c description]'" set state {} if {[$c ordered]} { lappend state ordered } else { lappend state unordered } if {[$c cmdline]} { lappend state cmdline } else { lappend state hidden } if {[$c list]} { lappend state splat } else { lappend state single } if {[$c required]} { lappend state required } else { lappend state optional } if {[$c interactive]} { lappend state interact } else { lappend state silent } if {[$c defered]} { lappend state defered } else { lappend state immediate } lappend result " [join $state {, }]" if {[$c hasdefault]} { lappend result " default: '[$c default]'" } else { lappend result " no default" } if {[$c interactive]} { lappend result " prompt: '[$c prompt]'" } if {[$c cmdline] && [$c ordered] && ![$c required]} { if {[$c threshold] >= 0} { lappend result " mode=threshold [$c threshold]" } else { lappend result " mode=peek+test" } } lappend result " flags \[[$c options]\]" foreach oname [$c options] { lappend result " $oname = [$c flag-type $oname]" } lappend result " ge ([$c generator])" lappend result " va ([$c validator])" lappend result " wd ([$c when-complete])" lappend result " \}" } lappend result "\}" return $result } # Dumping the parsed parameters of a private proc DumpParsed {o} { set name [$o fullname] set result {} set names [lsort -dict [$o names]] # Retrieve data foreach name $names { set c [$o lookup $name] if {[$c set?]} { set s '[$c string]' } else { set s } lappend strings $s lappend values v'[$c value]' } # Table formatted output. foreach name [Padr $names] s [Padr $strings] v $values { lappend result "$name = $s $v" } return $result } proc Padr {list} { set maxl 0 foreach str $list { set l [string length $str] if {$l <= $maxl} continue set maxl $l } set res {} foreach str $list { lappend res [format "%-*s" $maxl $str] } return $res } proc Padl {list} { set maxl 0 foreach str $list { set l [string length $str] if {$l <= $maxl} continue set maxl $l } set res {} foreach str $list { lappend res [format "%*s" $maxl $str] } return $res }