package provide opt 0.3
namespace eval ::tcl {
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
OptProc OptProcArgGiven OptParse \
Lassign Lvarpop Lvarset Lvarincr Lfirst \
SetMax SetMin
proc OptCreateTestProc {} {
OptProc OptParseTest {
{subcommand -choice {save print} "sub command"}
{arg1 3 "some number"}
{-aflag}
{-intflag 7}
{-weirdflag "help string"}
{-noStatics "Not ok to load static packages"}
{-nestedloading1 true "OK to load into nested slaves"}
{-nestedloading2 -boolean true "OK to load into nested slaves"}
{-libsOK -choice {Tk SybTcl}
"List of packages that can be loaded"}
{-precision -int 12 "Number of digits of precision"}
{-intval 7 "An integer"}
{-scale -float 1.0 "Scale factor"}
{-zoom 1.0 "Zoom factor"}
{-arbitrary foobar "Arbitrary string"}
{-random -string 12 "Random string"}
{-listval -list {} "List value"}
{-blahflag -blah abc "Funny type"}
{arg2 -boolean "a boolean"}
{arg3 -choice "ch1 ch2"}
{?optarg? -list {} "optional argument"}
} {
foreach v [info locals] {
puts stderr [format "%14s : %s" $v [set $v]]
}
}
}
variable OptDesc;
array set OptDesc {};
variable OptDescN 0;
proc ::tcl::OptKeyRegister {desc {key ""}} {
variable OptDesc;
variable OptDescN;
if {[string compare $key ""] == 0} {
while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
set key $OptDescN;
incr OptDescN;
}
set program [list [list "P" 1]];
set inflags 0;
set state {};
set empty 1;
foreach item $desc {
if {$state == "args"} {
return -code error "'args' special argument must be the last one";
}
set res [OptNormalizeOne $item];
set state [Lfirst $res];
if {$inflags} {
if {$state == "flags"} {
lappend flagsprg $res;
} else {
lappend program $flagsprg;
lappend program $res;
set inflags 0;
set empty 0;
}
} else {
if {$state == "flags"} {
set inflags 1;
set flagsprg [list [list "P" 1] $res];
} else {
lappend program $res;
set empty 0;
}
}
}
if {$inflags} {
if {$empty} {
set program $flagsprg;
} else {
lappend program $flagsprg;
}
}
set OptDesc($key) $program;
return $key;
}
proc ::tcl::OptKeyDelete {key} {
variable OptDesc;
unset OptDesc($key);
}
proc OptKeyGetDesc {descKey} {
variable OptDesc;
if {![info exists OptDesc($descKey)]} {
return -code error "Unknown option description key \"$descKey\"";
}
set OptDesc($descKey);
}
proc ::tcl::OptParse {desc arglist} {
set tempkey [OptKeyRegister $desc];
set ret [catch {uplevel [list ::tcl::OptKeyParse $tempkey $arglist]} res];
OptKeyDelete $tempkey;
return -code $ret $res;
}
proc ::tcl::OptProc {name desc body} {
set namespace [uplevel namespace current];
if { ([string match $name "::*"])
|| ([string compare $namespace "::"]==0)} {
set key $name;
} else {
set key "${namespace}::${name}";
}
OptKeyRegister $desc $key;
uplevel [list proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"];
return $key;
}
proc ::tcl::OptProcArgGiven {argname} {
upvar Args alist;
expr {[lsearch $alist $argname] >=0}
}
proc OptInstr {lst} {
Lfirst $lst;
}
proc OptIsPrg {lst} {
expr {[llength [OptInstr $lst]]>=2}
}
proc OptIsCounter {item} {
expr {[Lfirst $item]=="P"}
}
proc OptGetPrgCounter {lst} {
Lget $lst {0 1}
}
proc OptSetPrgCounter {lstName newValue} {
upvar $lstName lst;
set lst [lreplace $lst 0 0 [concat "P" $newValue]];
}
proc OptSelection {lst} {
set res {};
foreach idx [lrange [Lfirst $lst] 1 end] {
lappend res [Lget $lst $idx];
}
return $res;
}
proc OptNextDesc {descName} {
uplevel [list Lvarincr $descName {0 1}];
}
proc OptCurDesc {descriptions} {
lindex $descriptions [OptGetPrgCounter $descriptions];
}
proc OptCurDescFinal {descriptions} {
set item [OptCurDesc $descriptions];
while {[OptIsPrg $item]} {
set item [OptCurDesc $item];
}
return $item;
}
proc OptCurAddr {descriptions {start {}}} {
set adress [OptGetPrgCounter $descriptions];
lappend start $adress;
set item [lindex $descriptions $adress];
if {[OptIsPrg $item]} {
return [OptCurAddr $item $start];
} else {
return $start;
}
}
proc OptCurSetValue {descriptionsName value} {
upvar $descriptionsName descriptions
set adress [OptCurAddr $descriptions];
lappend adress 2
Lvarset descriptions $adress [list 1 $value];
}
proc OptState {item} {
Lfirst $item
}
proc OptCurState {descriptions} {
OptState [OptCurDesc $descriptions];
}
proc OptCurrentArg {lst} {
Lfirst $lst;
}
proc OptNextArg {argsName} {
uplevel [list Lvarpop $argsName];
}
proc OptDoAll {descriptionsName argumentsName} {
upvar $descriptionsName descriptions
upvar $argumentsName arguments;
set state [OptCurState $descriptions];
while 1 {
set curitem [OptCurDesc $descriptions];
while {[OptIsPrg $curitem]} {
OptDoAll curitem arguments
Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
$curitem;
OptNextDesc descriptions;
set curitem [OptCurDesc $descriptions];
set state [OptCurState $descriptions];
}
if {[Lempty $state]} {
break;
}
OptDoOne descriptions state arguments;
OptNextDesc descriptions;
set state [OptCurState $descriptions];
}
}
proc OptDoOne {descriptionsName stateName argumentsName} {
upvar $argumentsName arguments;
upvar $descriptionsName descriptions;
upvar $stateName state;
if {($state == "args")} {
if {![Lempty $arguments]} {
OptCurSetValue descriptions $arguments;
set arguments {};
}
return -code break;
}
if {[Lempty $arguments]} {
if {$state == "flags"} {
return -code return;
} elseif {$state == "optValue"} {
set state next; return ;
} else {
return -code error [OptMissingValue $descriptions];
}
} else {
set arg [OptCurrentArg $arguments];
}
switch $state {
flags {
if {![OptIsFlag $arg]} {
return -code return;
}
OptNextArg arguments;
if {[string compare "--" $arg] == 0} {
return -code return;
}
set hits [OptHits descriptions $arg];
if {$hits > 1} {
return -code error [OptAmbigous $descriptions $arg]
} elseif {$hits == 0} {
return -code error [OptFlagUsage $descriptions $arg]
}
set item [OptCurDesc $descriptions];
if {[OptNeedValue $item]} {
set state flagValue;
} else {
OptCurSetValue descriptions 1;
}
return -code continue;
}
flagValue -
value {
set item [OptCurDesc $descriptions];
if {[catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
return -code error [OptBadValue $item $arg $val]
}
OptNextArg arguments;
OptCurSetValue descriptions $val;
if {$state == "flagValue"} {
set state flags
return -code continue;
} else {
set state next; return ; }
}
optValue {
set item [OptCurDesc $descriptions];
if {![catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
OptNextArg arguments;
OptCurSetValue descriptions $val;
}
set state next; return ; }
}
return -code error "Bug! unknown state in DoOne \"$state\"\
(prg counter [OptGetPrgCounter $descriptions]:\
[OptCurDesc $descriptions])";
}
proc ::tcl::OptKeyParse {descKey arglist} {
set desc [OptKeyGetDesc $descKey];
if {[string compare "-help" [string tolower $arglist]] == 0} {
return -code error [OptError "Usage information:" $desc 1];
}
OptDoAll desc arglist;
if {![Lempty $arglist]} {
return -code error [OptTooManyArgs $desc $arglist];
}
OptTreeVars $desc "#[expr {[info level]-1}]" ;
}
proc OptTreeVars {desc level {vnamesLst {}}} {
foreach item $desc {
if {[OptIsCounter $item]} continue;
if {[OptIsPrg $item]} {
set vnamesLst [OptTreeVars $item $level $vnamesLst];
} else {
set vname [OptVarName $item];
upvar $level $vname var
if {[OptHasBeenSet $item]} {
lappend vnamesLst [OptName $item];
set var [OptValue $item];
} else {
set var [OptDefaultValue $item];
}
}
}
return $vnamesLst
}
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
switch -exact -- $type {
int {
if {![regexp {^(-+)?[0-9]+$} $arg]} {
error "not an integer"
}
return $arg;
}
float {
return [expr {double($arg)}]
}
script -
list {
if {[llength $arg]==0} {
if {[OptIsFlag $arg]} {
error "no values with leading -"
}
}
return $arg;
}
boolean {
if {![regexp -nocase {^(true|false|0|1)$} $arg]} {
error "non canonic boolean"
}
if {$arg} {
return 1
} else {
return 0
}
}
choice {
if {[lsearch -exact $typeArgs $arg] < 0} {
error "invalid choice"
}
return $arg;
}
any {
return $arg;
}
string -
default {
if {[OptIsFlag $arg]} {
error "no values with leading -"
}
return $arg
}
}
return neverReached;
}
proc OptHits {descName arg} {
upvar $descName desc;
set hits 0
set hitems {}
set i 1;
set larg [string tolower $arg];
set len [string length $larg];
set last [expr {$len-1}];
foreach item [lrange $desc 1 end] {
set flag [OptName $item]
set lflag [string tolower $flag];
if {$len == [string length $lflag]} {
if {[string compare $larg $lflag]==0} {
OptSetPrgCounter desc $i;
return 1;
}
} else {
if {[string compare $larg [string range $lflag 0 $last]]==0} {
lappend hitems $i;
incr hits;
}
}
incr i;
}
if {$hits} {
OptSetPrgCounter desc $hitems;
}
return $hits
}
proc OptName {item} {
lindex $item 1;
}
proc OptHasBeenSet {item} {
Lget $item {2 0};
}
proc OptValue {item} {
Lget $item {2 1};
}
proc OptIsFlag {name} {
string match "-*" $name;
}
proc OptIsOpt {name} {
string match {\?*} $name;
}
proc OptVarName {item} {
set name [OptName $item];
if {[OptIsFlag $name]} {
return [string range $name 1 end];
} elseif {[OptIsOpt $name]} {
return [string trim $name "?"];
} else {
return $name;
}
}
proc OptType {item} {
lindex $item 3
}
proc OptTypeArgs {item} {
lindex $item 4
}
proc OptHelp {item} {
lindex $item 5
}
proc OptNeedValue {item} {
string compare [OptType $item] boolflag
}
proc OptDefaultValue {item} {
set val [OptTypeArgs $item]
switch -exact -- [OptType $item] {
choice {return [lindex $val 0]}
boolean -
boolflag {
if {$val} {
return 1
} else {
return 0
}
}
}
return $val
}
proc OptOptUsage {item {what ""}} {
return -code error "invalid description format$what: $item\n\
should be a list of {varname|-flagname ?-type? ?defaultvalue?\
?helpstring?}";
}
proc OptNewInst {state varname type typeArgs help} {
list $state $varname [list 0 {}] $type $typeArgs $help;
}
proc OptNormalizeOne {item} {
set lg [Lassign $item varname arg1 arg2 arg3];
set isflag [OptIsFlag $varname];
set isopt [OptIsOpt $varname];
if {$isflag} {
set state "flags";
} elseif {$isopt} {
set state "optValue";
} elseif {[string compare $varname "args"]} {
set state "value";
} else {
set state "args";
}
switch $lg {
1 {
if {$isflag} {
return [OptNewInst $state $varname boolflag false ""];
} else {
return [OptNewInst $state $varname any "" ""];
}
}
2 {
set type [OptGuessType $arg1]
if {[string compare $type "string"] == 0} {
if {$isflag} {
set type boolflag
set def false
} else {
set type any
set def ""
}
set help $arg1
} else {
set help ""
set def $arg1
}
return [OptNewInst $state $varname $type $def $help];
}
3 {
if {[regexp {^-(.+)$} $arg1 x type]} {
if {$isflag || $isopt || ($type == "choice")} {
return [OptNewInst $state $varname $type $arg2 ""];
} else {
return [OptNewInst $state $varname $type "" $arg2];
}
} else {
return [OptNewInst $state $varname\
[OptGuessType $arg1] $arg1 $arg2]
}
}
4 {
if {[regexp {^-(.+)$} $arg1 x type]} {
return [OptNewInst $state $varname $type $arg2 $arg3];
} else {
return -code error [OptOptUsage $item];
}
}
default {
return -code error [OptOptUsage $item];
}
}
}
proc OptGuessType {arg} {
if {[regexp -nocase {^(true|false)$} $arg]} {
return boolean
}
if {[regexp {^(-+)?[0-9]+$} $arg]} {
return int
}
if {![catch {expr {double($arg)}}]} {
return float
}
return string
}
proc OptAmbigous {desc arg} {
OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
}
proc OptFlagUsage {desc arg} {
OptError "bad flag \"$arg\", must be one of" $desc;
}
proc OptTooManyArgs {desc arguments} {
OptError "too many arguments (unexpected argument(s): $arguments),\
usage:"\
$desc 1
}
proc OptParamType {item} {
if {[OptIsFlag $item]} {
return "flag";
} else {
return "parameter";
}
}
proc OptBadValue {item arg {err {}}} {
OptError "bad value \"$arg\" for [OptParamType $item]"\
[list $item]
}
proc OptMissingValue {descriptions} {
set item [OptCurDesc $descriptions];
OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
(use -help for full usage) :"\
[list $item]
}
proc ::tcl::OptKeyError {prefix descKey {header 0}} {
OptError $prefix [OptKeyGetDesc $descKey] $header;
}
proc OptLengths {desc nlName tlName dlName} {
upvar $nlName nl;
upvar $tlName tl;
upvar $dlName dl;
foreach item $desc {
if {[OptIsCounter $item]} continue;
if {[OptIsPrg $item]} {
OptLengths $item nl tl dl
} else {
SetMax nl [string length [OptName $item]]
SetMax tl [string length [OptType $item]]
set dv [OptTypeArgs $item];
if {[OptState $item] != "header"} {
set dv "($dv)";
}
set l [string length $dv];
if {([OptType $item] != "choice") || ($l<=12)} {
SetMax dl $l
} else {
if {![info exists dl]} {
set dl 0
}
}
}
}
}
proc OptTree {desc nl tl dl} {
set res "";
foreach item $desc {
if {[OptIsCounter $item]} continue;
if {[OptIsPrg $item]} {
append res [OptTree $item $nl $tl $dl];
} else {
set dv [OptTypeArgs $item];
if {[OptState $item] != "header"} {
set dv "($dv)";
}
append res [format "\n %-*s %-*s %-*s %s" \
$nl [OptName $item] $tl [OptType $item] \
$dl $dv [OptHelp $item]]
}
}
return $res;
}
proc ::tcl::OptError {prefix desc {header 0}} {
if {$header} {
set h [list [OptNewInst header Var/FlagName Type Value Help]];
lappend h [OptNewInst header ------------ ---- ----- ----];
lappend h [OptNewInst header {( -help} "" "" {gives this help )}]
set desc [concat $h $desc]
}
OptLengths $desc nl tl dl
return "$prefix[OptTree $desc $nl $tl $dl]"
}
proc ::tcl::Lempty {list} {
expr {[llength $list]==0}
}
proc ::tcl::Lget {list indexLst} {
if {[llength $indexLst] <= 1} {
return [lindex $list $indexLst];
}
Lget [lindex $list [Lfirst $indexLst]] [Lrest $indexLst];
}
proc ::tcl::Lvarset {listName indexLst newValue} {
upvar $listName list;
if {[llength $indexLst] <= 1} {
Lvarset1nc list $indexLst $newValue;
} else {
set idx [Lfirst $indexLst];
set targetList [lindex $list $idx];
Lvarset targetList [Lrest $indexLst] $newValue;
Lvarset1nc list $idx $targetList;
}
}
variable emptyList {}
proc ::tcl::Lvarset1 {listName index newValue} {
upvar $listName list;
if {$index < 0} {return -code error "invalid negative index"}
set lg [llength $list];
if {$index >= $lg} {
variable emptyList;
for {set i $lg} {$i<$index} {incr i} {
lappend list $emptyList;
}
lappend list $newValue;
} else {
set list [lreplace $list $index $index $newValue];
}
}
proc ::tcl::Lvarset1nc {listName index newValue} {
upvar $listName list;
set list [lreplace $list $index $index $newValue];
}
proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
upvar $listName list;
if {[llength $indexLst] <= 1} {
Lvarincr1 list $indexLst $howMuch;
} else {
set idx [Lfirst $indexLst];
set targetList [lindex $list $idx];
Lvarset1nc list $idx {};
Lvarincr targetList [Lrest $indexLst] $howMuch;
Lvarset1nc list $idx $targetList;
}
}
proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
upvar $listName list;
set newValue [expr {[lindex $list $index]+$howMuch}];
set list [lreplace $list $index $index $newValue];
return $newValue;
}
proc ::tcl::Lfirst {list} {
lindex $list 0
}
proc ::tcl::Lrest {list} {
lrange $list 1 end
}
proc ::tcl::Lvarpop {listName} {
upvar $listName list;
set list [lrange $list 1 end];
}
proc ::tcl::Lvarpop2 {listName} {
upvar $listName list;
set el [Lfirst $list];
set list [lrange $list 1 end];
return $el;
}
proc ::tcl::Lassign {list args} {
set i 0;
set lg [llength $list];
foreach vname $args {
if {$i>=$lg} break
uplevel [list set $vname [lindex $list $i]];
incr i;
}
return $lg;
}
proc ::tcl::SetMax {varname value} {
upvar 1 $varname var
if {![info exists var] || $value > $var} {
set var $value
}
}
proc ::tcl::SetMin {varname value} {
upvar 1 $varname var
if {![info exists var] || $value < $var} {
set var $value
}
}
OptCreateTestProc
rename OptCreateTestProc {}
}