1073 lines
32 KiB
Tcl
1073 lines
32 KiB
Tcl
|
# optparse.tcl --
|
||
|
|
#
|
||
|
|
# (private) Option parsing package
|
||
|
|
# Primarily used internally by the safe:: code.
|
||
|
|
#
|
||
|
|
# WARNING: This code will go away in a future release
|
||
|
|
# of Tcl. It is NOT supported and you should not rely
|
||
|
|
# on it. If your code does rely on this package you
|
||
|
|
# may directly incorporate this code into your application.
|
||
|
|
|
||
|
|
package require Tcl 8.2
|
||
|
|
# When this version number changes, update the pkgIndex.tcl file
|
||
|
|
# and the install directory in the Makefiles.
|
||
|
|
package provide opt 0.4.5
|
||
|
|
|
||
|
|
namespace eval ::tcl {
|
||
|
|
|
||
|
|
# Exported APIs
|
||
|
|
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
|
||
|
|
OptProc OptProcArgGiven OptParse \
|
||
|
|
Lempty Lget \
|
||
|
|
Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \
|
||
|
|
SetMax SetMin
|
||
|
|
|
||
|
|
|
||
|
|
################# Example of use / 'user documentation' ###################
|
||
|
|
|
||
|
|
proc OptCreateTestProc {} {
|
||
|
|
|
||
|
|
# Defines ::tcl::OptParseTest as a test proc with parsed arguments
|
||
|
|
# (can't be defined before the code below is loaded (before "OptProc"))
|
||
|
|
|
||
|
|
# Every OptProc give usage information on "procname -help".
|
||
|
|
# Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
|
||
|
|
# then other arguments.
|
||
|
|
#
|
||
|
|
# example of 'valid' call:
|
||
|
|
# ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
|
||
|
|
# -nostatics false ch1
|
||
|
|
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]]
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
################### No User serviceable part below ! ###############
|
||
|
|
|
||
|
|
# Array storing the parsed descriptions
|
||
|
|
variable OptDesc;
|
||
|
|
array set OptDesc {};
|
||
|
|
# Next potentially free key id (numeric)
|
||
|
|
variable OptDescN 0;
|
||
|
|
|
||
|
|
# Inside algorithm/mechanism description:
|
||
|
|
# (not for the faint hearted ;-)
|
||
|
|
#
|
||
|
|
# The argument description is parsed into a "program tree"
|
||
|
|
# It is called a "program" because it is the program used by
|
||
|
|
# the state machine interpreter that use that program to
|
||
|
|
# actually parse the arguments at run time.
|
||
|
|
#
|
||
|
|
# The general structure of a "program" is
|
||
|
|
# notation (pseudo bnf like)
|
||
|
|
# name :== definition defines "name" as being "definition"
|
||
|
|
# { x y z } means list of x, y, and z
|
||
|
|
# x* means x repeated 0 or more time
|
||
|
|
# x+ means "x x*"
|
||
|
|
# x? means optionally x
|
||
|
|
# x | y means x or y
|
||
|
|
# "cccc" means the literal string
|
||
|
|
#
|
||
|
|
# program :== { programCounter programStep* }
|
||
|
|
#
|
||
|
|
# programStep :== program | singleStep
|
||
|
|
#
|
||
|
|
# programCounter :== {"P" integer+ }
|
||
|
|
#
|
||
|
|
# singleStep :== { instruction parameters* }
|
||
|
|
#
|
||
|
|
# instruction :== single element list
|
||
|
|
#
|
||
|
|
# (the difference between singleStep and program is that \
|
||
|
|
# llength [lindex $program 0] >= 2
|
||
|
|
# while
|
||
|
|
# llength [lindex $singleStep 0] == 1
|
||
|
|
# )
|
||
|
|
#
|
||
|
|
# And for this application:
|
||
|
|
#
|
||
|
|
# singleStep :== { instruction varname {hasBeenSet currentValue} type
|
||
|
|
# typeArgs help }
|
||
|
|
# instruction :== "flags" | "value"
|
||
|
|
# type :== knowType | anyword
|
||
|
|
# knowType :== "string" | "int" | "boolean" | "boolflag" | "float"
|
||
|
|
# | "choice"
|
||
|
|
#
|
||
|
|
# for type "choice" typeArgs is a list of possible choices, the first one
|
||
|
|
# is the default value. for all other types the typeArgs is the default value
|
||
|
|
#
|
||
|
|
# a "boolflag" is the type for a flag whose presence or absence, without
|
||
|
|
# additional arguments means respectively true or false (default flag type).
|
||
|
|
#
|
||
|
|
# programCounter is the index in the list of the currently processed
|
||
|
|
# programStep (thus starting at 1 (0 is {"P" prgCounterValue}).
|
||
|
|
# If it is a list it points toward each currently selected programStep.
|
||
|
|
# (like for "flags", as they are optional, form a set and programStep).
|
||
|
|
|
||
|
|
# Performance/Implementation issues
|
||
|
|
# ---------------------------------
|
||
|
|
# We use tcl lists instead of arrays because with tcl8.0
|
||
|
|
# they should start to be much faster.
|
||
|
|
# But this code use a lot of helper procs (like Lvarset)
|
||
|
|
# which are quite slow and would be helpfully optimized
|
||
|
|
# for instance by being written in C. Also our struture
|
||
|
|
# is complex and there is maybe some places where the
|
||
|
|
# string rep might be calculated at great exense. to be checked.
|
||
|
|
|
||
|
|
#
|
||
|
|
# Parse a given description and saves it here under the given key
|
||
|
|
# generate a unused keyid if not given
|
||
|
|
#
|
||
|
|
proc ::tcl::OptKeyRegister {desc {key ""}} {
|
||
|
|
variable OptDesc;
|
||
|
|
variable OptDescN;
|
||
|
|
if {[string equal $key ""]} {
|
||
|
|
# in case a key given to us as a parameter was a number
|
||
|
|
while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
|
||
|
|
set key $OptDescN;
|
||
|
|
incr OptDescN;
|
||
|
|
}
|
||
|
|
# program counter
|
||
|
|
set program [list [list "P" 1]];
|
||
|
|
|
||
|
|
# are we processing flags (which makes a single program step)
|
||
|
|
set inflags 0;
|
||
|
|
|
||
|
|
set state {};
|
||
|
|
|
||
|
|
# flag used to detect that we just have a single (flags set) subprogram.
|
||
|
|
set empty 1;
|
||
|
|
|
||
|
|
foreach item $desc {
|
||
|
|
if {$state == "args"} {
|
||
|
|
# more items after 'args'...
|
||
|
|
return -code error "'args' special argument must be the last one";
|
||
|
|
}
|
||
|
|
set res [OptNormalizeOne $item];
|
||
|
|
set state [lindex $res 0];
|
||
|
|
if {$inflags} {
|
||
|
|
if {$state == "flags"} {
|
||
|
|
# add to 'subprogram'
|
||
|
|
lappend flagsprg $res;
|
||
|
|
} else {
|
||
|
|
# put in the flags
|
||
|
|
# structure for flag programs items is a list of
|
||
|
|
# {subprgcounter {prg flag 1} {prg flag 2} {...}}
|
||
|
|
lappend program $flagsprg;
|
||
|
|
# put the other regular stuff
|
||
|
|
lappend program $res;
|
||
|
|
set inflags 0;
|
||
|
|
set empty 0;
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
if {$state == "flags"} {
|
||
|
|
set inflags 1;
|
||
|
|
# sub program counter + first sub program
|
||
|
|
set flagsprg [list [list "P" 1] $res];
|
||
|
|
} else {
|
||
|
|
lappend program $res;
|
||
|
|
set empty 0;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if {$inflags} {
|
||
|
|
if {$empty} {
|
||
|
|
# We just have the subprogram, optimize and remove
|
||
|
|
# unneeded level:
|
||
|
|
set program $flagsprg;
|
||
|
|
} else {
|
||
|
|
lappend program $flagsprg;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
set OptDesc($key) $program;
|
||
|
|
|
||
|
|
return $key;
|
||
|
|
}
|
||
|
|
|
||
|
|
#
|
||
|
|
# Free the storage for that given key
|
||
|
|
#
|
||
|
|
proc ::tcl::OptKeyDelete {key} {
|
||
|
|
variable OptDesc;
|
||
|
|
unset OptDesc($key);
|
||
|
|
}
|
||
|
|
|
||
|
|
# Get the parsed description stored under the given key.
|
||
|
|
proc OptKeyGetDesc {descKey} {
|
||
|
|
variable OptDesc;
|
||
|
|
if {![info exists OptDesc($descKey)]} {
|
||
|
|
return -code error "Unknown option description key \"$descKey\"";
|
||
|
|
}
|
||
|
|
set OptDesc($descKey);
|
||
|
|
}
|
||
|
|
|
||
|
|
# Parse entry point for ppl who don't want to register with a key,
|
||
|
|
# for instance because the description changes dynamically.
|
||
|
|
# (otherwise one should really use OptKeyRegister once + OptKeyParse
|
||
|
|
# as it is way faster or simply OptProc which does it all)
|
||
|
|
# Assign a temporary key, call OptKeyParse and then free the storage
|
||
|
|
proc ::tcl::OptParse {desc arglist} {
|
||
|
|
set tempkey [OptKeyRegister $desc];
|
||
|
|
set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res];
|
||
|
|
OptKeyDelete $tempkey;
|
||
|
|
return -code $ret $res;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Helper function, replacement for proc that both
|
||
|
|
# register the description under a key which is the name of the proc
|
||
|
|
# (and thus unique to that code)
|
||
|
|
# and add a first line to the code to call the OptKeyParse proc
|
||
|
|
# Stores the list of variables that have been actually given by the user
|
||
|
|
# (the other will be sets to their default value)
|
||
|
|
# into local variable named "Args".
|
||
|
|
proc ::tcl::OptProc {name desc body} {
|
||
|
|
set namespace [uplevel 1 [list ::namespace current]];
|
||
|
|
if {[string match "::*" $name] || [string equal $namespace "::"]} {
|
||
|
|
# absolute name or global namespace, name is the key
|
||
|
|
set key $name;
|
||
|
|
} else {
|
||
|
|
# we are relative to some non top level namespace:
|
||
|
|
set key "${namespace}::${name}";
|
||
|
|
}
|
||
|
|
OptKeyRegister $desc $key;
|
||
|
|
uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"];
|
||
|
|
return $key;
|
||
|
|
}
|
||
|
|
# Check that a argument has been given
|
||
|
|
# assumes that "OptProc" has been used as it will check in "Args" list
|
||
|
|
proc ::tcl::OptProcArgGiven {argname} {
|
||
|
|
upvar Args alist;
|
||
|
|
expr {[lsearch $alist $argname] >=0}
|
||
|
|
}
|
||
|
|
|
||
|
|
#######
|
||
|
|
# Programs/Descriptions manipulation
|
||
|
|
|
||
|
|
# Return the instruction word/list of a given step/(sub)program
|
||
|
|
proc OptInstr {lst} {
|
||
|
|
lindex $lst 0;
|
||
|
|
}
|
||
|
|
# Is a (sub) program or a plain instruction ?
|
||
|
|
proc OptIsPrg {lst} {
|
||
|
|
expr {[llength [OptInstr $lst]]>=2}
|
||
|
|
}
|
||
|
|
# Is this instruction a program counter or a real instr
|
||
|
|
proc OptIsCounter {item} {
|
||
|
|
expr {[lindex $item 0]=="P"}
|
||
|
|
}
|
||
|
|
# Current program counter (2nd word of first word)
|
||
|
|
proc OptGetPrgCounter {lst} {
|
||
|
|
Lget $lst {0 1}
|
||
|
|
}
|
||
|
|
# Current program counter (2nd word of first word)
|
||
|
|
proc OptSetPrgCounter {lstName newValue} {
|
||
|
|
upvar $lstName lst;
|
||
|
|
set lst [lreplace $lst 0 0 [concat "P" $newValue]];
|
||
|
|
}
|
||
|
|
# returns a list of currently selected items.
|
||
|
|
proc OptSelection {lst} {
|
||
|
|
set res {};
|
||
|
|
foreach idx [lrange [lindex $lst 0] 1 end] {
|
||
|
|
lappend res [Lget $lst $idx];
|
||
|
|
}
|
||
|
|
return $res;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Advance to next description
|
||
|
|
proc OptNextDesc {descName} {
|
||
|
|
uplevel 1 [list Lvarincr $descName {0 1}];
|
||
|
|
}
|
||
|
|
|
||
|
|
# Get the current description, eventually descend
|
||
|
|
proc OptCurDesc {descriptions} {
|
||
|
|
lindex $descriptions [OptGetPrgCounter $descriptions];
|
||
|
|
}
|
||
|
|
# get the current description, eventually descend
|
||
|
|
# through sub programs as needed.
|
||
|
|
proc OptCurDescFinal {descriptions} {
|
||
|
|
set item [OptCurDesc $descriptions];
|
||
|
|
# Descend untill we get the actual item and not a sub program
|
||
|
|
while {[OptIsPrg $item]} {
|
||
|
|
set item [OptCurDesc $item];
|
||
|
|
}
|
||
|
|
return $item;
|
||
|
|
}
|
||
|
|
# Current final instruction adress
|
||
|
|
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;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# Set the value field of the current instruction
|
||
|
|
proc OptCurSetValue {descriptionsName value} {
|
||
|
|
upvar $descriptionsName descriptions
|
||
|
|
# get the current item full adress
|
||
|
|
set adress [OptCurAddr $descriptions];
|
||
|
|
# use the 3th field of the item (see OptValue / OptNewInst)
|
||
|
|
lappend adress 2
|
||
|
|
Lvarset descriptions $adress [list 1 $value];
|
||
|
|
# ^hasBeenSet flag
|
||
|
|
}
|
||
|
|
|
||
|
|
# empty state means done/paste the end of the program
|
||
|
|
proc OptState {item} {
|
||
|
|
lindex $item 0
|
||
|
|
}
|
||
|
|
|
||
|
|
# current state
|
||
|
|
proc OptCurState {descriptions} {
|
||
|
|
OptState [OptCurDesc $descriptions];
|
||
|
|
}
|
||
|
|
|
||
|
|
#######
|
||
|
|
# Arguments manipulation
|
||
|
|
|
||
|
|
# Returns the argument that has to be processed now
|
||
|
|
proc OptCurrentArg {lst} {
|
||
|
|
lindex $lst 0;
|
||
|
|
}
|
||
|
|
# Advance to next argument
|
||
|
|
proc OptNextArg {argsName} {
|
||
|
|
uplevel 1 [list Lvarpop1 $argsName];
|
||
|
|
}
|
||
|
|
#######
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
# Loop over all descriptions, calling OptDoOne which will
|
||
|
|
# eventually eat all the arguments.
|
||
|
|
proc OptDoAll {descriptionsName argumentsName} {
|
||
|
|
upvar $descriptionsName descriptions
|
||
|
|
upvar $argumentsName arguments;
|
||
|
|
# puts "entered DoAll";
|
||
|
|
# Nb: the places where "state" can be set are tricky to figure
|
||
|
|
# because DoOne sets the state to flagsValue and return -continue
|
||
|
|
# when needed...
|
||
|
|
set state [OptCurState $descriptions];
|
||
|
|
# We'll exit the loop in "OptDoOne" or when state is empty.
|
||
|
|
while 1 {
|
||
|
|
set curitem [OptCurDesc $descriptions];
|
||
|
|
# Do subprograms if needed, call ourselves on the sub branch
|
||
|
|
while {[OptIsPrg $curitem]} {
|
||
|
|
OptDoAll curitem arguments
|
||
|
|
# puts "done DoAll sub";
|
||
|
|
# Insert back the results in current tree;
|
||
|
|
Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
|
||
|
|
$curitem;
|
||
|
|
OptNextDesc descriptions;
|
||
|
|
set curitem [OptCurDesc $descriptions];
|
||
|
|
set state [OptCurState $descriptions];
|
||
|
|
}
|
||
|
|
# puts "state = \"$state\" - arguments=($arguments)";
|
||
|
|
if {[Lempty $state]} {
|
||
|
|
# Nothing left to do, we are done in this branch:
|
||
|
|
break;
|
||
|
|
}
|
||
|
|
# The following statement can make us terminate/continue
|
||
|
|
# as it use return -code {break, continue, return and error}
|
||
|
|
# codes
|
||
|
|
OptDoOne descriptions state arguments;
|
||
|
|
# If we are here, no special return code where issued,
|
||
|
|
# we'll step to next instruction :
|
||
|
|
# puts "new state = \"$state\"";
|
||
|
|
OptNextDesc descriptions;
|
||
|
|
set state [OptCurState $descriptions];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Process one step for the state machine,
|
||
|
|
# eventually consuming the current argument.
|
||
|
|
proc OptDoOne {descriptionsName stateName argumentsName} {
|
||
|
|
upvar $argumentsName arguments;
|
||
|
|
upvar $descriptionsName descriptions;
|
||
|
|
upvar $stateName state;
|
||
|
|
|
||
|
|
# the special state/instruction "args" eats all
|
||
|
|
# the remaining args (if any)
|
||
|
|
if {($state == "args")} {
|
||
|
|
if {![Lempty $arguments]} {
|
||
|
|
# If there is no additional arguments, leave the default value
|
||
|
|
# in.
|
||
|
|
OptCurSetValue descriptions $arguments;
|
||
|
|
set arguments {};
|
||
|
|
}
|
||
|
|
# puts "breaking out ('args' state: consuming every reminding args)"
|
||
|
|
return -code break;
|
||
|
|
}
|
||
|
|
|
||
|
|
if {[Lempty $arguments]} {
|
||
|
|
if {$state == "flags"} {
|
||
|
|
# no argument and no flags : we're done
|
||
|
|
# puts "returning to previous (sub)prg (no more args)";
|
||
|
|
return -code return;
|
||
|
|
} elseif {$state == "optValue"} {
|
||
|
|
set state next; # not used, for debug only
|
||
|
|
# go to next state
|
||
|
|
return ;
|
||
|
|
} else {
|
||
|
|
return -code error [OptMissingValue $descriptions];
|
||
|
|
}
|
||
|
|
} else {
|
||
|
|
set arg [OptCurrentArg $arguments];
|
||
|
|
}
|
||
|
|
|
||
|
|
switch $state {
|
||
|
|
flags {
|
||
|
|
# A non-dash argument terminates the options, as does --
|
||
|
|
|
||
|
|
# Still a flag ?
|
||
|
|
if {![OptIsFlag $arg]} {
|
||
|
|
# don't consume the argument, return to previous prg
|
||
|
|
return -code return;
|
||
|
|
}
|
||
|
|
# consume the flag
|
||
|
|
OptNextArg arguments;
|
||
|
|
if {[string equal "--" $arg]} {
|
||
|
|
# return from 'flags' state
|
||
|
|
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]} {
|
||
|
|
# we need a value, next state is
|
||
|
|
set state flagValue;
|
||
|
|
} else {
|
||
|
|
OptCurSetValue descriptions 1;
|
||
|
|
}
|
||
|
|
# continue
|
||
|
|
return -code continue;
|
||
|
|
}
|
||
|
|
flagValue -
|
||
|
|
value {
|
||
|
|
set item [OptCurDesc $descriptions];
|
||
|
|
# Test the values against their required type
|
||
|
|
if {[catch {OptCheckType $arg\
|
||
|
|
[OptType $item] [OptTypeArgs $item]} val]} {
|
||
|
|
return -code error [OptBadValue $item $arg $val]
|
||
|
|
}
|
||
|
|
# consume the value
|
||
|
|
OptNextArg arguments;
|
||
|
|
# set the value
|
||
|
|
OptCurSetValue descriptions $val;
|
||
|
|
# go to next state
|
||
|
|
if {$state == "flagValue"} {
|
||
|
|
set state flags
|
||
|
|
return -code continue;
|
||
|
|
} else {
|
||
|
|
set state next; # not used, for debug only
|
||
|
|
return ; # will go on next step
|
||
|
|
}
|
||
|
|
}
|
||
|
|
optValue {
|
||
|
|
set item [OptCurDesc $descriptions];
|
||
|
|
# Test the values against their required type
|
||
|
|
if {![catch {OptCheckType $arg\
|
||
|
|
[OptType $item] [OptTypeArgs $item]} val]} {
|
||
|
|
# right type, so :
|
||
|
|
# consume the value
|
||
|
|
OptNextArg arguments;
|
||
|
|
# set the value
|
||
|
|
OptCurSetValue descriptions $val;
|
||
|
|
}
|
||
|
|
# go to next state
|
||
|
|
set state next; # not used, for debug only
|
||
|
|
return ; # will go on next step
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# If we reach this point: an unknown
|
||
|
|
# state as been entered !
|
||
|
|
return -code error "Bug! unknown state in DoOne \"$state\"\
|
||
|
|
(prg counter [OptGetPrgCounter $descriptions]:\
|
||
|
|
[OptCurDesc $descriptions])";
|
||
|
|
}
|
||
|
|
|
||
|
|
# Parse the options given the key to previously registered description
|
||
|
|
# and arguments list
|
||
|
|
proc ::tcl::OptKeyParse {descKey arglist} {
|
||
|
|
|
||
|
|
set desc [OptKeyGetDesc $descKey];
|
||
|
|
|
||
|
|
# make sure -help always give usage
|
||
|
|
if {[string equal -nocase "-help" $arglist]} {
|
||
|
|
return -code error [OptError "Usage information:" $desc 1];
|
||
|
|
}
|
||
|
|
|
||
|
|
OptDoAll desc arglist;
|
||
|
|
|
||
|
|
if {![Lempty $arglist]} {
|
||
|
|
return -code error [OptTooManyArgs $desc $arglist];
|
||
|
|
}
|
||
|
|
|
||
|
|
# Analyse the result
|
||
|
|
# Walk through the tree:
|
||
|
|
OptTreeVars $desc "#[expr {[info level]-1}]" ;
|
||
|
|
}
|
||
|
|
|
||
|
|
# determine string length for nice tabulated output
|
||
|
|
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]} {
|
||
|
|
# puts "adding $vname"
|
||
|
|
# lets use the input name for the returned list
|
||
|
|
# it is more usefull, for instance you can check that
|
||
|
|
# no flags at all was given with expr
|
||
|
|
# {![string match "*-*" $Args]}
|
||
|
|
lappend vnamesLst [OptName $item];
|
||
|
|
set var [OptValue $item];
|
||
|
|
} else {
|
||
|
|
set var [OptDefaultValue $item];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $vnamesLst
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Check the type of a value
|
||
|
|
# and emit an error if arg is not of the correct type
|
||
|
|
# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
|
||
|
|
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
|
||
|
|
# puts "checking '$arg' against '$type' ($typeArgs)";
|
||
|
|
|
||
|
|
# only types "any", "choice", and numbers can have leading "-"
|
||
|
|
|
||
|
|
switch -exact -- $type {
|
||
|
|
int {
|
||
|
|
if {![string is integer -strict $arg]} {
|
||
|
|
error "not an integer"
|
||
|
|
}
|
||
|
|
return $arg;
|
||
|
|
}
|
||
|
|
float {
|
||
|
|
return [expr {double($arg)}]
|
||
|
|
}
|
||
|
|
script -
|
||
|
|
list {
|
||
|
|
# if llength fail : malformed list
|
||
|
|
if {[llength $arg]==0 && [OptIsFlag $arg]} {
|
||
|
|
error "no values with leading -"
|
||
|
|
}
|
||
|
|
return $arg;
|
||
|
|
}
|
||
|
|
boolean {
|
||
|
|
if {![string is boolean -strict $arg]} {
|
||
|
|
error "non canonic boolean"
|
||
|
|
}
|
||
|
|
# convert true/false because expr/if is broken with "!,...
|
||
|
|
return [expr {$arg ? 1 : 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;
|
||
|
|
}
|
||
|
|
|
||
|
|
# internal utilities
|
||
|
|
|
||
|
|
# returns the number of flags matching the given arg
|
||
|
|
# sets the (local) prg counter to the list of matches
|
||
|
|
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]
|
||
|
|
# lets try to match case insensitively
|
||
|
|
# (string length ought to be cheap)
|
||
|
|
set lflag [string tolower $flag];
|
||
|
|
if {$len == [string length $lflag]} {
|
||
|
|
if {[string equal $larg $lflag]} {
|
||
|
|
# Exact match case
|
||
|
|
OptSetPrgCounter desc $i;
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
} elseif {[string equal $larg [string range $lflag 0 $last]]} {
|
||
|
|
lappend hitems $i;
|
||
|
|
incr hits;
|
||
|
|
}
|
||
|
|
incr i;
|
||
|
|
}
|
||
|
|
if {$hits} {
|
||
|
|
OptSetPrgCounter desc $hitems;
|
||
|
|
}
|
||
|
|
return $hits
|
||
|
|
}
|
||
|
|
|
||
|
|
# Extract fields from the list structure:
|
||
|
|
|
||
|
|
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} {
|
||
|
|
expr {![string equal [OptType $item] boolflag]}
|
||
|
|
}
|
||
|
|
proc OptDefaultValue {item} {
|
||
|
|
set val [OptTypeArgs $item]
|
||
|
|
switch -exact -- [OptType $item] {
|
||
|
|
choice {return [lindex $val 0]}
|
||
|
|
boolean -
|
||
|
|
boolflag {
|
||
|
|
# convert back false/true to 0/1 because expr !$bool
|
||
|
|
# is broken..
|
||
|
|
if {$val} {
|
||
|
|
return 1
|
||
|
|
} else {
|
||
|
|
return 0
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $val
|
||
|
|
}
|
||
|
|
|
||
|
|
# Description format error helper
|
||
|
|
proc OptOptUsage {item {what ""}} {
|
||
|
|
return -code error "invalid description format$what: $item\n\
|
||
|
|
should be a list of {varname|-flagname ?-type? ?defaultvalue?\
|
||
|
|
?helpstring?}";
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# Generate a canonical form single instruction
|
||
|
|
proc OptNewInst {state varname type typeArgs help} {
|
||
|
|
list $state $varname [list 0 {}] $type $typeArgs $help;
|
||
|
|
# ^ ^
|
||
|
|
# | |
|
||
|
|
# hasBeenSet=+ +=currentValue
|
||
|
|
}
|
||
|
|
|
||
|
|
# Translate one item to canonical form
|
||
|
|
proc OptNormalizeOne {item} {
|
||
|
|
set lg [Lassign $item varname arg1 arg2 arg3];
|
||
|
|
# puts "called optnormalizeone '$item' v=($varname), lg=$lg";
|
||
|
|
set isflag [OptIsFlag $varname];
|
||
|
|
set isopt [OptIsOpt $varname];
|
||
|
|
if {$isflag} {
|
||
|
|
set state "flags";
|
||
|
|
} elseif {$isopt} {
|
||
|
|
set state "optValue";
|
||
|
|
} elseif {![string equal $varname "args"]} {
|
||
|
|
set state "value";
|
||
|
|
} else {
|
||
|
|
set state "args";
|
||
|
|
}
|
||
|
|
|
||
|
|
# apply 'smart' 'fuzzy' logic to try to make
|
||
|
|
# description writer's life easy, and our's difficult :
|
||
|
|
# let's guess the missing arguments :-)
|
||
|
|
|
||
|
|
switch $lg {
|
||
|
|
1 {
|
||
|
|
if {$isflag} {
|
||
|
|
return [OptNewInst $state $varname boolflag false ""];
|
||
|
|
} else {
|
||
|
|
return [OptNewInst $state $varname any "" ""];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
2 {
|
||
|
|
# varname default
|
||
|
|
# varname help
|
||
|
|
set type [OptGuessType $arg1]
|
||
|
|
if {[string equal $type "string"]} {
|
||
|
|
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 {
|
||
|
|
# varname type value
|
||
|
|
# varname value comment
|
||
|
|
|
||
|
|
if {[regexp {^-(.+)$} $arg1 x type]} {
|
||
|
|
# flags/optValue as they are optional, need a "value",
|
||
|
|
# on the contrary, for a variable (non optional),
|
||
|
|
# default value is pointless, 'cept for choices :
|
||
|
|
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];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Auto magic lazy type determination
|
||
|
|
proc OptGuessType {arg} {
|
||
|
|
if { $arg == "true" || $arg == "false" } {
|
||
|
|
return boolean
|
||
|
|
}
|
||
|
|
if {[string is integer -strict $arg]} {
|
||
|
|
return int
|
||
|
|
}
|
||
|
|
if {[string is double -strict $arg]} {
|
||
|
|
return float
|
||
|
|
}
|
||
|
|
return string
|
||
|
|
}
|
||
|
|
|
||
|
|
# Error messages front ends
|
||
|
|
|
||
|
|
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 {}}} {
|
||
|
|
# puts "bad val err = \"$err\"";
|
||
|
|
OptError "bad value \"$arg\" for [OptParamType $item]"\
|
||
|
|
[list $item]
|
||
|
|
}
|
||
|
|
proc OptMissingValue {descriptions} {
|
||
|
|
# set item [OptCurDescFinal $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;
|
||
|
|
}
|
||
|
|
|
||
|
|
# determine string length for nice tabulated output
|
||
|
|
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];
|
||
|
|
# limit the space allocated to potentially big "choices"
|
||
|
|
if {([OptType $item] != "choice") || ($l<=12)} {
|
||
|
|
SetMax dl $l
|
||
|
|
} else {
|
||
|
|
if {![info exists dl]} {
|
||
|
|
set dl 0
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# output the tree
|
||
|
|
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;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Give nice usage string
|
||
|
|
proc ::tcl::OptError {prefix desc {header 0}} {
|
||
|
|
# determine length
|
||
|
|
if {$header} {
|
||
|
|
# add faked instruction
|
||
|
|
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
|
||
|
|
# actually output
|
||
|
|
return "$prefix[OptTree $desc $nl $tl $dl]"
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
################ General Utility functions #######################
|
||
|
|
|
||
|
|
#
|
||
|
|
# List utility functions
|
||
|
|
# Naming convention:
|
||
|
|
# "Lvarxxx" take the list VARiable name as argument
|
||
|
|
# "Lxxxx" take the list value as argument
|
||
|
|
# (which is not costly with Tcl8 objects system
|
||
|
|
# as it's still a reference and not a copy of the values)
|
||
|
|
#
|
||
|
|
|
||
|
|
# Is that list empty ?
|
||
|
|
proc ::tcl::Lempty {list} {
|
||
|
|
expr {[llength $list]==0}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Gets the value of one leaf of a lists tree
|
||
|
|
proc ::tcl::Lget {list indexLst} {
|
||
|
|
if {[llength $indexLst] <= 1} {
|
||
|
|
return [lindex $list $indexLst];
|
||
|
|
}
|
||
|
|
Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end];
|
||
|
|
}
|
||
|
|
# Sets the value of one leaf of a lists tree
|
||
|
|
# (we use the version that does not create the elements because
|
||
|
|
# it would be even slower... needs to be written in C !)
|
||
|
|
# (nb: there is a non trivial recursive problem with indexes 0,
|
||
|
|
# which appear because there is no difference between a list
|
||
|
|
# of 1 element and 1 element alone : [list "a"] == "a" while
|
||
|
|
# it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
|
||
|
|
# and [listp "a b"] maybe 0. listp does not exist either...)
|
||
|
|
proc ::tcl::Lvarset {listName indexLst newValue} {
|
||
|
|
upvar $listName list;
|
||
|
|
if {[llength $indexLst] <= 1} {
|
||
|
|
Lvarset1nc list $indexLst $newValue;
|
||
|
|
} else {
|
||
|
|
set idx [lindex $indexLst 0];
|
||
|
|
set targetList [lindex $list $idx];
|
||
|
|
# reduce refcount on targetList (not really usefull now,
|
||
|
|
# could be with optimizing compiler)
|
||
|
|
# Lvarset1 list $idx {};
|
||
|
|
# recursively replace in targetList
|
||
|
|
Lvarset targetList [lrange $indexLst 1 end] $newValue;
|
||
|
|
# put updated sub list back in the tree
|
||
|
|
Lvarset1nc list $idx $targetList;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# Set one cell to a value, eventually create all the needed elements
|
||
|
|
# (on level-1 of lists)
|
||
|
|
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];
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# same as Lvarset1 but no bound checking / creation
|
||
|
|
proc ::tcl::Lvarset1nc {listName index newValue} {
|
||
|
|
upvar $listName list;
|
||
|
|
set list [lreplace $list $index $index $newValue];
|
||
|
|
}
|
||
|
|
# Increments the value of one leaf of a lists tree
|
||
|
|
# (which must exists)
|
||
|
|
proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
|
||
|
|
upvar $listName list;
|
||
|
|
if {[llength $indexLst] <= 1} {
|
||
|
|
Lvarincr1 list $indexLst $howMuch;
|
||
|
|
} else {
|
||
|
|
set idx [lindex $indexLst 0];
|
||
|
|
set targetList [lindex $list $idx];
|
||
|
|
# reduce refcount on targetList
|
||
|
|
Lvarset1nc list $idx {};
|
||
|
|
# recursively replace in targetList
|
||
|
|
Lvarincr targetList [lrange $indexLst 1 end] $howMuch;
|
||
|
|
# put updated sub list back in the tree
|
||
|
|
Lvarset1nc list $idx $targetList;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# Increments the value of one cell of a list
|
||
|
|
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;
|
||
|
|
}
|
||
|
|
# Removes the first element of a list
|
||
|
|
# and returns the new list value
|
||
|
|
proc ::tcl::Lvarpop1 {listName} {
|
||
|
|
upvar $listName list;
|
||
|
|
set list [lrange $list 1 end];
|
||
|
|
}
|
||
|
|
# Same but returns the removed element
|
||
|
|
# (Like the tclX version)
|
||
|
|
proc ::tcl::Lvarpop {listName} {
|
||
|
|
upvar $listName list;
|
||
|
|
set el [lindex $list 0];
|
||
|
|
set list [lrange $list 1 end];
|
||
|
|
return $el;
|
||
|
|
}
|
||
|
|
# Assign list elements to variables and return the length of the list
|
||
|
|
proc ::tcl::Lassign {list args} {
|
||
|
|
# faster than direct blown foreach (which does not byte compile)
|
||
|
|
set i 0;
|
||
|
|
set lg [llength $list];
|
||
|
|
foreach vname $args {
|
||
|
|
if {$i>=$lg} break
|
||
|
|
uplevel 1 [list ::set $vname [lindex $list $i]];
|
||
|
|
incr i;
|
||
|
|
}
|
||
|
|
return $lg;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Misc utilities
|
||
|
|
|
||
|
|
# Set the varname to value if value is greater than varname's current value
|
||
|
|
# or if varname is undefined
|
||
|
|
proc ::tcl::SetMax {varname value} {
|
||
|
|
upvar 1 $varname var
|
||
|
|
if {![info exists var] || $value > $var} {
|
||
|
|
set var $value
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Set the varname to value if value is smaller than varname's current value
|
||
|
|
# or if varname is undefined
|
||
|
|
proc ::tcl::SetMin {varname value} {
|
||
|
|
upvar 1 $varname var
|
||
|
|
if {![info exists var] || $value < $var} {
|
||
|
|
set var $value
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
# everything loaded fine, lets create the test proc:
|
||
|
|
# OptCreateTestProc
|
||
|
|
# Don't need the create temp proc anymore:
|
||
|
|
# rename OptCreateTestProc {}
|
||
|
|
}
|