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