source: data/Media/tcl8.4/opt/optparse.tcl @ 5162

# 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.8.2.1 2003/09/10 20:29:59 dgp Exp $

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.4.1

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 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 [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 {}
}