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