merged tcl 8.1 branch back into the main trunk

1 files changed, 1097 insertions, 0 deletions

diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl
new file mode 100644
index 0000000..289a39a
--- /dev/null
+++ b/library/opt/optparse.tcl
@@ -0,0 +1,1097 @@
+# 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.
+#
+# RCS: @(#) $Id: optparse.tcl,v 1.2 1999/04/16 00:47:18 stanton Exp $
+
+package provide opt 0.4.1
+
+namespace eval ::tcl {
+
+    # Exported APIs
+    namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
+             OptProc OptProcArgGiven OptParse \
+	     Lempty Lget \
+             Lassign Lvarpop Lvarpop1 Lvarset Lvarincr Lfirst Lrest \
+             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 ! ###############
+# You should really not look any further :
+# The following is private unexported undocumented unblessed... code 
+# time to hit "q" ;-) !
+
+# Hmmm... ok, you really want to know ?
+
+# You've been warned... Here it is...
+
+    # 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 [Lfirst $program] >= 2
+# while
+#   llength [Lfirst $singleStep] == 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 compare $key ""] == 0} {
+        # 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 [Lfirst $res];
+        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 [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 namespace current];
+    if {   ([string match $name "::*"]) 
+        || ([string compare $namespace "::"]==0)} {
+        # 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 [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} {
+	Lfirst $lst;
+    }
+    # 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 {[Lfirst $item]=="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 [Lfirst $lst] 1 end] {
+	    lappend res [Lget $lst $idx];
+	}
+	return $res;
+    }
+
+    # Advance to next description
+    proc OptNextDesc {descName} {
+        uplevel [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} {
+        Lfirst $item
+    }
+    
+    # current state
+    proc OptCurState {descriptions} {
+        OptState [OptCurDesc $descriptions];
+    }
+
+    #######
+    # Arguments manipulation
+
+    # Returns the argument that has to be processed now
+    proc OptCurrentArg {lst} {
+        Lfirst $lst;
+    }
+    # Advance to next argument
+    proc OptNextArg {argsName} {
+        uplevel [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 compare "--" $arg] == 0} {
+                    # 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 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];
+    }
+    
+    # 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 {![regexp {^(-+)?[0-9]+$} $arg]} {
+                error "not an integer"
+            }
+	    return $arg;
+        }
+        float {
+            return [expr {double($arg)}]
+        }
+	script -
+        list {
+	    # if llength fail : malformed 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"
+            }
+	    # convert true/false because expr/if is broken with "!,...
+	    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;
+}
+
+    # 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 compare $larg $lflag]==0} {
+		    # Exact match case
+		    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
+    }
+
+    # 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} {
+        string compare [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 compare $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 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 {
+                # 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 lasy type determination
+    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
+    }
+
+    # 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 [Lfirst $indexLst]] [Lrest $indexLst];
+}
+# 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 [Lfirst $indexLst];
+        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 [Lrest $indexLst] $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 [Lfirst $indexLst];
+        set targetList [lindex $list $idx];
+        # reduce refcount on targetList
+        Lvarset1nc list $idx {};
+        # recursively replace in targetList
+        Lvarincr targetList [Lrest $indexLst] $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;
+}
+# Returns the first element of a list
+proc ::tcl::Lfirst {list} {
+    lindex $list 0
+}
+# Returns the rest of the list minus first element
+proc ::tcl::Lrest {list} {
+    lrange $list 1 end
+}
+# 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 [Lfirst $list];
+    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 [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 {}
+}