[5049] | 1 | # optparse.tcl -- |
---|
| 2 | # |
---|
| 3 | # (private) Option parsing package |
---|
| 4 | # Primarily used internally by the safe:: code. |
---|
| 5 | # |
---|
| 6 | # WARNING: This code will go away in a future release |
---|
| 7 | # of Tcl. It is NOT supported and you should not rely |
---|
| 8 | # on it. If your code does rely on this package you |
---|
| 9 | # may directly incorporate this code into your application. |
---|
| 10 | # |
---|
| 11 | # RCS: @(#) $Id: optparse.tcl,v 1.10 2003/09/10 20:27:30 dgp Exp $ |
---|
| 12 | |
---|
| 13 | package require Tcl 8.2 |
---|
| 14 | # When this version number changes, update the pkgIndex.tcl file |
---|
| 15 | # and the install directory in the Makefiles. |
---|
| 16 | package provide opt 0.4.5 |
---|
| 17 | |
---|
| 18 | namespace eval ::tcl { |
---|
| 19 | |
---|
| 20 | # Exported APIs |
---|
| 21 | namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ |
---|
| 22 | OptProc OptProcArgGiven OptParse \ |
---|
| 23 | Lempty Lget \ |
---|
| 24 | Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \ |
---|
| 25 | SetMax SetMin |
---|
| 26 | |
---|
| 27 | |
---|
| 28 | ################# Example of use / 'user documentation' ################### |
---|
| 29 | |
---|
| 30 | proc OptCreateTestProc {} { |
---|
| 31 | |
---|
| 32 | # Defines ::tcl::OptParseTest as a test proc with parsed arguments |
---|
| 33 | # (can't be defined before the code below is loaded (before "OptProc")) |
---|
| 34 | |
---|
| 35 | # Every OptProc give usage information on "procname -help". |
---|
| 36 | # Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and |
---|
| 37 | # then other arguments. |
---|
| 38 | # |
---|
| 39 | # example of 'valid' call: |
---|
| 40 | # ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\ |
---|
| 41 | # -nostatics false ch1 |
---|
| 42 | OptProc OptParseTest { |
---|
| 43 | {subcommand -choice {save print} "sub command"} |
---|
| 44 | {arg1 3 "some number"} |
---|
| 45 | {-aflag} |
---|
| 46 | {-intflag 7} |
---|
| 47 | {-weirdflag "help string"} |
---|
| 48 | {-noStatics "Not ok to load static packages"} |
---|
| 49 | {-nestedloading1 true "OK to load into nested slaves"} |
---|
| 50 | {-nestedloading2 -boolean true "OK to load into nested slaves"} |
---|
| 51 | {-libsOK -choice {Tk SybTcl} |
---|
| 52 | "List of packages that can be loaded"} |
---|
| 53 | {-precision -int 12 "Number of digits of precision"} |
---|
| 54 | {-intval 7 "An integer"} |
---|
| 55 | {-scale -float 1.0 "Scale factor"} |
---|
| 56 | {-zoom 1.0 "Zoom factor"} |
---|
| 57 | {-arbitrary foobar "Arbitrary string"} |
---|
| 58 | {-random -string 12 "Random string"} |
---|
| 59 | {-listval -list {} "List value"} |
---|
| 60 | {-blahflag -blah abc "Funny type"} |
---|
| 61 | {arg2 -boolean "a boolean"} |
---|
| 62 | {arg3 -choice "ch1 ch2"} |
---|
| 63 | {?optarg? -list {} "optional argument"} |
---|
| 64 | } { |
---|
| 65 | foreach v [info locals] { |
---|
| 66 | puts stderr [format "%14s : %s" $v [set $v]] |
---|
| 67 | } |
---|
| 68 | } |
---|
| 69 | } |
---|
| 70 | |
---|
| 71 | ################### No User serviceable part below ! ############### |
---|
| 72 | |
---|
| 73 | # Array storing the parsed descriptions |
---|
| 74 | variable OptDesc; |
---|
| 75 | array set OptDesc {}; |
---|
| 76 | # Next potentially free key id (numeric) |
---|
| 77 | variable OptDescN 0; |
---|
| 78 | |
---|
| 79 | # Inside algorithm/mechanism description: |
---|
| 80 | # (not for the faint hearted ;-) |
---|
| 81 | # |
---|
| 82 | # The argument description is parsed into a "program tree" |
---|
| 83 | # It is called a "program" because it is the program used by |
---|
| 84 | # the state machine interpreter that use that program to |
---|
| 85 | # actually parse the arguments at run time. |
---|
| 86 | # |
---|
| 87 | # The general structure of a "program" is |
---|
| 88 | # notation (pseudo bnf like) |
---|
| 89 | # name :== definition defines "name" as being "definition" |
---|
| 90 | # { x y z } means list of x, y, and z |
---|
| 91 | # x* means x repeated 0 or more time |
---|
| 92 | # x+ means "x x*" |
---|
| 93 | # x? means optionally x |
---|
| 94 | # x | y means x or y |
---|
| 95 | # "cccc" means the literal string |
---|
| 96 | # |
---|
| 97 | # program :== { programCounter programStep* } |
---|
| 98 | # |
---|
| 99 | # programStep :== program | singleStep |
---|
| 100 | # |
---|
| 101 | # programCounter :== {"P" integer+ } |
---|
| 102 | # |
---|
| 103 | # singleStep :== { instruction parameters* } |
---|
| 104 | # |
---|
| 105 | # instruction :== single element list |
---|
| 106 | # |
---|
| 107 | # (the difference between singleStep and program is that \ |
---|
| 108 | # llength [lindex $program 0] >= 2 |
---|
| 109 | # while |
---|
| 110 | # llength [lindex $singleStep 0] == 1 |
---|
| 111 | # ) |
---|
| 112 | # |
---|
| 113 | # And for this application: |
---|
| 114 | # |
---|
| 115 | # singleStep :== { instruction varname {hasBeenSet currentValue} type |
---|
| 116 | # typeArgs help } |
---|
| 117 | # instruction :== "flags" | "value" |
---|
| 118 | # type :== knowType | anyword |
---|
| 119 | # knowType :== "string" | "int" | "boolean" | "boolflag" | "float" |
---|
| 120 | # | "choice" |
---|
| 121 | # |
---|
| 122 | # for type "choice" typeArgs is a list of possible choices, the first one |
---|
| 123 | # is the default value. for all other types the typeArgs is the default value |
---|
| 124 | # |
---|
| 125 | # a "boolflag" is the type for a flag whose presence or absence, without |
---|
| 126 | # additional arguments means respectively true or false (default flag type). |
---|
| 127 | # |
---|
| 128 | # programCounter is the index in the list of the currently processed |
---|
| 129 | # programStep (thus starting at 1 (0 is {"P" prgCounterValue}). |
---|
| 130 | # If it is a list it points toward each currently selected programStep. |
---|
| 131 | # (like for "flags", as they are optional, form a set and programStep). |
---|
| 132 | |
---|
| 133 | # Performance/Implementation issues |
---|
| 134 | # --------------------------------- |
---|
| 135 | # We use tcl lists instead of arrays because with tcl8.0 |
---|
| 136 | # they should start to be much faster. |
---|
| 137 | # But this code use a lot of helper procs (like Lvarset) |
---|
| 138 | # which are quite slow and would be helpfully optimized |
---|
| 139 | # for instance by being written in C. Also our struture |
---|
| 140 | # is complex and there is maybe some places where the |
---|
| 141 | # string rep might be calculated at great exense. to be checked. |
---|
| 142 | |
---|
| 143 | # |
---|
| 144 | # Parse a given description and saves it here under the given key |
---|
| 145 | # generate a unused keyid if not given |
---|
| 146 | # |
---|
| 147 | proc ::tcl::OptKeyRegister {desc {key ""}} { |
---|
| 148 | variable OptDesc; |
---|
| 149 | variable OptDescN; |
---|
| 150 | if {[string equal $key ""]} { |
---|
| 151 | # in case a key given to us as a parameter was a number |
---|
| 152 | while {[info exists OptDesc($OptDescN)]} {incr OptDescN} |
---|
| 153 | set key $OptDescN; |
---|
| 154 | incr OptDescN; |
---|
| 155 | } |
---|
| 156 | # program counter |
---|
| 157 | set program [list [list "P" 1]]; |
---|
| 158 | |
---|
| 159 | # are we processing flags (which makes a single program step) |
---|
| 160 | set inflags 0; |
---|
| 161 | |
---|
| 162 | set state {}; |
---|
| 163 | |
---|
| 164 | # flag used to detect that we just have a single (flags set) subprogram. |
---|
| 165 | set empty 1; |
---|
| 166 | |
---|
| 167 | foreach item $desc { |
---|
| 168 | if {$state == "args"} { |
---|
| 169 | # more items after 'args'... |
---|
| 170 | return -code error "'args' special argument must be the last one"; |
---|
| 171 | } |
---|
| 172 | set res [OptNormalizeOne $item]; |
---|
| 173 | set state [lindex $res 0]; |
---|
| 174 | if {$inflags} { |
---|
| 175 | if {$state == "flags"} { |
---|
| 176 | # add to 'subprogram' |
---|
| 177 | lappend flagsprg $res; |
---|
| 178 | } else { |
---|
| 179 | # put in the flags |
---|
| 180 | # structure for flag programs items is a list of |
---|
| 181 | # {subprgcounter {prg flag 1} {prg flag 2} {...}} |
---|
| 182 | lappend program $flagsprg; |
---|
| 183 | # put the other regular stuff |
---|
| 184 | lappend program $res; |
---|
| 185 | set inflags 0; |
---|
| 186 | set empty 0; |
---|
| 187 | } |
---|
| 188 | } else { |
---|
| 189 | if {$state == "flags"} { |
---|
| 190 | set inflags 1; |
---|
| 191 | # sub program counter + first sub program |
---|
| 192 | set flagsprg [list [list "P" 1] $res]; |
---|
| 193 | } else { |
---|
| 194 | lappend program $res; |
---|
| 195 | set empty 0; |
---|
| 196 | } |
---|
| 197 | } |
---|
| 198 | } |
---|
| 199 | if {$inflags} { |
---|
| 200 | if {$empty} { |
---|
| 201 | # We just have the subprogram, optimize and remove |
---|
| 202 | # unneeded level: |
---|
| 203 | set program $flagsprg; |
---|
| 204 | } else { |
---|
| 205 | lappend program $flagsprg; |
---|
| 206 | } |
---|
| 207 | } |
---|
| 208 | |
---|
| 209 | set OptDesc($key) $program; |
---|
| 210 | |
---|
| 211 | return $key; |
---|
| 212 | } |
---|
| 213 | |
---|
| 214 | # |
---|
| 215 | # Free the storage for that given key |
---|
| 216 | # |
---|
| 217 | proc ::tcl::OptKeyDelete {key} { |
---|
| 218 | variable OptDesc; |
---|
| 219 | unset OptDesc($key); |
---|
| 220 | } |
---|
| 221 | |
---|
| 222 | # Get the parsed description stored under the given key. |
---|
| 223 | proc OptKeyGetDesc {descKey} { |
---|
| 224 | variable OptDesc; |
---|
| 225 | if {![info exists OptDesc($descKey)]} { |
---|
| 226 | return -code error "Unknown option description key \"$descKey\""; |
---|
| 227 | } |
---|
| 228 | set OptDesc($descKey); |
---|
| 229 | } |
---|
| 230 | |
---|
| 231 | # Parse entry point for ppl who don't want to register with a key, |
---|
| 232 | # for instance because the description changes dynamically. |
---|
| 233 | # (otherwise one should really use OptKeyRegister once + OptKeyParse |
---|
| 234 | # as it is way faster or simply OptProc which does it all) |
---|
| 235 | # Assign a temporary key, call OptKeyParse and then free the storage |
---|
| 236 | proc ::tcl::OptParse {desc arglist} { |
---|
| 237 | set tempkey [OptKeyRegister $desc]; |
---|
| 238 | set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res]; |
---|
| 239 | OptKeyDelete $tempkey; |
---|
| 240 | return -code $ret $res; |
---|
| 241 | } |
---|
| 242 | |
---|
| 243 | # Helper function, replacement for proc that both |
---|
| 244 | # register the description under a key which is the name of the proc |
---|
| 245 | # (and thus unique to that code) |
---|
| 246 | # and add a first line to the code to call the OptKeyParse proc |
---|
| 247 | # Stores the list of variables that have been actually given by the user |
---|
| 248 | # (the other will be sets to their default value) |
---|
| 249 | # into local variable named "Args". |
---|
| 250 | proc ::tcl::OptProc {name desc body} { |
---|
| 251 | set namespace [uplevel 1 [list ::namespace current]]; |
---|
| 252 | if {[string match "::*" $name] || [string equal $namespace "::"]} { |
---|
| 253 | # absolute name or global namespace, name is the key |
---|
| 254 | set key $name; |
---|
| 255 | } else { |
---|
| 256 | # we are relative to some non top level namespace: |
---|
| 257 | set key "${namespace}::${name}"; |
---|
| 258 | } |
---|
| 259 | OptKeyRegister $desc $key; |
---|
| 260 | uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"]; |
---|
| 261 | return $key; |
---|
| 262 | } |
---|
| 263 | # Check that a argument has been given |
---|
| 264 | # assumes that "OptProc" has been used as it will check in "Args" list |
---|
| 265 | proc ::tcl::OptProcArgGiven {argname} { |
---|
| 266 | upvar Args alist; |
---|
| 267 | expr {[lsearch $alist $argname] >=0} |
---|
| 268 | } |
---|
| 269 | |
---|
| 270 | ####### |
---|
| 271 | # Programs/Descriptions manipulation |
---|
| 272 | |
---|
| 273 | # Return the instruction word/list of a given step/(sub)program |
---|
| 274 | proc OptInstr {lst} { |
---|
| 275 | lindex $lst 0; |
---|
| 276 | } |
---|
| 277 | # Is a (sub) program or a plain instruction ? |
---|
| 278 | proc OptIsPrg {lst} { |
---|
| 279 | expr {[llength [OptInstr $lst]]>=2} |
---|
| 280 | } |
---|
| 281 | # Is this instruction a program counter or a real instr |
---|
| 282 | proc OptIsCounter {item} { |
---|
| 283 | expr {[lindex $item 0]=="P"} |
---|
| 284 | } |
---|
| 285 | # Current program counter (2nd word of first word) |
---|
| 286 | proc OptGetPrgCounter {lst} { |
---|
| 287 | Lget $lst {0 1} |
---|
| 288 | } |
---|
| 289 | # Current program counter (2nd word of first word) |
---|
| 290 | proc OptSetPrgCounter {lstName newValue} { |
---|
| 291 | upvar $lstName lst; |
---|
| 292 | set lst [lreplace $lst 0 0 [concat "P" $newValue]]; |
---|
| 293 | } |
---|
| 294 | # returns a list of currently selected items. |
---|
| 295 | proc OptSelection {lst} { |
---|
| 296 | set res {}; |
---|
| 297 | foreach idx [lrange [lindex $lst 0] 1 end] { |
---|
| 298 | lappend res [Lget $lst $idx]; |
---|
| 299 | } |
---|
| 300 | return $res; |
---|
| 301 | } |
---|
| 302 | |
---|
| 303 | # Advance to next description |
---|
| 304 | proc OptNextDesc {descName} { |
---|
| 305 | uplevel 1 [list Lvarincr $descName {0 1}]; |
---|
| 306 | } |
---|
| 307 | |
---|
| 308 | # Get the current description, eventually descend |
---|
| 309 | proc OptCurDesc {descriptions} { |
---|
| 310 | lindex $descriptions [OptGetPrgCounter $descriptions]; |
---|
| 311 | } |
---|
| 312 | # get the current description, eventually descend |
---|
| 313 | # through sub programs as needed. |
---|
| 314 | proc OptCurDescFinal {descriptions} { |
---|
| 315 | set item [OptCurDesc $descriptions]; |
---|
| 316 | # Descend untill we get the actual item and not a sub program |
---|
| 317 | while {[OptIsPrg $item]} { |
---|
| 318 | set item [OptCurDesc $item]; |
---|
| 319 | } |
---|
| 320 | return $item; |
---|
| 321 | } |
---|
| 322 | # Current final instruction adress |
---|
| 323 | proc OptCurAddr {descriptions {start {}}} { |
---|
| 324 | set adress [OptGetPrgCounter $descriptions]; |
---|
| 325 | lappend start $adress; |
---|
| 326 | set item [lindex $descriptions $adress]; |
---|
| 327 | if {[OptIsPrg $item]} { |
---|
| 328 | return [OptCurAddr $item $start]; |
---|
| 329 | } else { |
---|
| 330 | return $start; |
---|
| 331 | } |
---|
| 332 | } |
---|
| 333 | # Set the value field of the current instruction |
---|
| 334 | proc OptCurSetValue {descriptionsName value} { |
---|
| 335 | upvar $descriptionsName descriptions |
---|
| 336 | # get the current item full adress |
---|
| 337 | set adress [OptCurAddr $descriptions]; |
---|
| 338 | # use the 3th field of the item (see OptValue / OptNewInst) |
---|
| 339 | lappend adress 2 |
---|
| 340 | Lvarset descriptions $adress [list 1 $value]; |
---|
| 341 | # ^hasBeenSet flag |
---|
| 342 | } |
---|
| 343 | |
---|
| 344 | # empty state means done/paste the end of the program |
---|
| 345 | proc OptState {item} { |
---|
| 346 | lindex $item 0 |
---|
| 347 | } |
---|
| 348 | |
---|
| 349 | # current state |
---|
| 350 | proc OptCurState {descriptions} { |
---|
| 351 | OptState [OptCurDesc $descriptions]; |
---|
| 352 | } |
---|
| 353 | |
---|
| 354 | ####### |
---|
| 355 | # Arguments manipulation |
---|
| 356 | |
---|
| 357 | # Returns the argument that has to be processed now |
---|
| 358 | proc OptCurrentArg {lst} { |
---|
| 359 | lindex $lst 0; |
---|
| 360 | } |
---|
| 361 | # Advance to next argument |
---|
| 362 | proc OptNextArg {argsName} { |
---|
| 363 | uplevel 1 [list Lvarpop1 $argsName]; |
---|
| 364 | } |
---|
| 365 | ####### |
---|
| 366 | |
---|
| 367 | |
---|
| 368 | |
---|
| 369 | |
---|
| 370 | |
---|
| 371 | # Loop over all descriptions, calling OptDoOne which will |
---|
| 372 | # eventually eat all the arguments. |
---|
| 373 | proc OptDoAll {descriptionsName argumentsName} { |
---|
| 374 | upvar $descriptionsName descriptions |
---|
| 375 | upvar $argumentsName arguments; |
---|
| 376 | # puts "entered DoAll"; |
---|
| 377 | # Nb: the places where "state" can be set are tricky to figure |
---|
| 378 | # because DoOne sets the state to flagsValue and return -continue |
---|
| 379 | # when needed... |
---|
| 380 | set state [OptCurState $descriptions]; |
---|
| 381 | # We'll exit the loop in "OptDoOne" or when state is empty. |
---|
| 382 | while 1 { |
---|
| 383 | set curitem [OptCurDesc $descriptions]; |
---|
| 384 | # Do subprograms if needed, call ourselves on the sub branch |
---|
| 385 | while {[OptIsPrg $curitem]} { |
---|
| 386 | OptDoAll curitem arguments |
---|
| 387 | # puts "done DoAll sub"; |
---|
| 388 | # Insert back the results in current tree; |
---|
| 389 | Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\ |
---|
| 390 | $curitem; |
---|
| 391 | OptNextDesc descriptions; |
---|
| 392 | set curitem [OptCurDesc $descriptions]; |
---|
| 393 | set state [OptCurState $descriptions]; |
---|
| 394 | } |
---|
| 395 | # puts "state = \"$state\" - arguments=($arguments)"; |
---|
| 396 | if {[Lempty $state]} { |
---|
| 397 | # Nothing left to do, we are done in this branch: |
---|
| 398 | break; |
---|
| 399 | } |
---|
| 400 | # The following statement can make us terminate/continue |
---|
| 401 | # as it use return -code {break, continue, return and error} |
---|
| 402 | # codes |
---|
| 403 | OptDoOne descriptions state arguments; |
---|
| 404 | # If we are here, no special return code where issued, |
---|
| 405 | # we'll step to next instruction : |
---|
| 406 | # puts "new state = \"$state\""; |
---|
| 407 | OptNextDesc descriptions; |
---|
| 408 | set state [OptCurState $descriptions]; |
---|
| 409 | } |
---|
| 410 | } |
---|
| 411 | |
---|
| 412 | # Process one step for the state machine, |
---|
| 413 | # eventually consuming the current argument. |
---|
| 414 | proc OptDoOne {descriptionsName stateName argumentsName} { |
---|
| 415 | upvar $argumentsName arguments; |
---|
| 416 | upvar $descriptionsName descriptions; |
---|
| 417 | upvar $stateName state; |
---|
| 418 | |
---|
| 419 | # the special state/instruction "args" eats all |
---|
| 420 | # the remaining args (if any) |
---|
| 421 | if {($state == "args")} { |
---|
| 422 | if {![Lempty $arguments]} { |
---|
| 423 | # If there is no additional arguments, leave the default value |
---|
| 424 | # in. |
---|
| 425 | OptCurSetValue descriptions $arguments; |
---|
| 426 | set arguments {}; |
---|
| 427 | } |
---|
| 428 | # puts "breaking out ('args' state: consuming every reminding args)" |
---|
| 429 | return -code break; |
---|
| 430 | } |
---|
| 431 | |
---|
| 432 | if {[Lempty $arguments]} { |
---|
| 433 | if {$state == "flags"} { |
---|
| 434 | # no argument and no flags : we're done |
---|
| 435 | # puts "returning to previous (sub)prg (no more args)"; |
---|
| 436 | return -code return; |
---|
| 437 | } elseif {$state == "optValue"} { |
---|
| 438 | set state next; # not used, for debug only |
---|
| 439 | # go to next state |
---|
| 440 | return ; |
---|
| 441 | } else { |
---|
| 442 | return -code error [OptMissingValue $descriptions]; |
---|
| 443 | } |
---|
| 444 | } else { |
---|
| 445 | set arg [OptCurrentArg $arguments]; |
---|
| 446 | } |
---|
| 447 | |
---|
| 448 | switch $state { |
---|
| 449 | flags { |
---|
| 450 | # A non-dash argument terminates the options, as does -- |
---|
| 451 | |
---|
| 452 | # Still a flag ? |
---|
| 453 | if {![OptIsFlag $arg]} { |
---|
| 454 | # don't consume the argument, return to previous prg |
---|
| 455 | return -code return; |
---|
| 456 | } |
---|
| 457 | # consume the flag |
---|
| 458 | OptNextArg arguments; |
---|
| 459 | if {[string equal "--" $arg]} { |
---|
| 460 | # return from 'flags' state |
---|
| 461 | return -code return; |
---|
| 462 | } |
---|
| 463 | |
---|
| 464 | set hits [OptHits descriptions $arg]; |
---|
| 465 | if {$hits > 1} { |
---|
| 466 | return -code error [OptAmbigous $descriptions $arg] |
---|
| 467 | } elseif {$hits == 0} { |
---|
| 468 | return -code error [OptFlagUsage $descriptions $arg] |
---|
| 469 | } |
---|
| 470 | set item [OptCurDesc $descriptions]; |
---|
| 471 | if {[OptNeedValue $item]} { |
---|
| 472 | # we need a value, next state is |
---|
| 473 | set state flagValue; |
---|
| 474 | } else { |
---|
| 475 | OptCurSetValue descriptions 1; |
---|
| 476 | } |
---|
| 477 | # continue |
---|
| 478 | return -code continue; |
---|
| 479 | } |
---|
| 480 | flagValue - |
---|
| 481 | value { |
---|
| 482 | set item [OptCurDesc $descriptions]; |
---|
| 483 | # Test the values against their required type |
---|
| 484 | if {[catch {OptCheckType $arg\ |
---|
| 485 | [OptType $item] [OptTypeArgs $item]} val]} { |
---|
| 486 | return -code error [OptBadValue $item $arg $val] |
---|
| 487 | } |
---|
| 488 | # consume the value |
---|
| 489 | OptNextArg arguments; |
---|
| 490 | # set the value |
---|
| 491 | OptCurSetValue descriptions $val; |
---|
| 492 | # go to next state |
---|
| 493 | if {$state == "flagValue"} { |
---|
| 494 | set state flags |
---|
| 495 | return -code continue; |
---|
| 496 | } else { |
---|
| 497 | set state next; # not used, for debug only |
---|
| 498 | return ; # will go on next step |
---|
| 499 | } |
---|
| 500 | } |
---|
| 501 | optValue { |
---|
| 502 | set item [OptCurDesc $descriptions]; |
---|
| 503 | # Test the values against their required type |
---|
| 504 | if {![catch {OptCheckType $arg\ |
---|
| 505 | [OptType $item] [OptTypeArgs $item]} val]} { |
---|
| 506 | # right type, so : |
---|
| 507 | # consume the value |
---|
| 508 | OptNextArg arguments; |
---|
| 509 | # set the value |
---|
| 510 | OptCurSetValue descriptions $val; |
---|
| 511 | } |
---|
| 512 | # go to next state |
---|
| 513 | set state next; # not used, for debug only |
---|
| 514 | return ; # will go on next step |
---|
| 515 | } |
---|
| 516 | } |
---|
| 517 | # If we reach this point: an unknown |
---|
| 518 | # state as been entered ! |
---|
| 519 | return -code error "Bug! unknown state in DoOne \"$state\"\ |
---|
| 520 | (prg counter [OptGetPrgCounter $descriptions]:\ |
---|
| 521 | [OptCurDesc $descriptions])"; |
---|
| 522 | } |
---|
| 523 | |
---|
| 524 | # Parse the options given the key to previously registered description |
---|
| 525 | # and arguments list |
---|
| 526 | proc ::tcl::OptKeyParse {descKey arglist} { |
---|
| 527 | |
---|
| 528 | set desc [OptKeyGetDesc $descKey]; |
---|
| 529 | |
---|
| 530 | # make sure -help always give usage |
---|
| 531 | if {[string equal -nocase "-help" $arglist]} { |
---|
| 532 | return -code error [OptError "Usage information:" $desc 1]; |
---|
| 533 | } |
---|
| 534 | |
---|
| 535 | OptDoAll desc arglist; |
---|
| 536 | |
---|
| 537 | if {![Lempty $arglist]} { |
---|
| 538 | return -code error [OptTooManyArgs $desc $arglist]; |
---|
| 539 | } |
---|
| 540 | |
---|
| 541 | # Analyse the result |
---|
| 542 | # Walk through the tree: |
---|
| 543 | OptTreeVars $desc "#[expr {[info level]-1}]" ; |
---|
| 544 | } |
---|
| 545 | |
---|
| 546 | # determine string length for nice tabulated output |
---|
| 547 | proc OptTreeVars {desc level {vnamesLst {}}} { |
---|
| 548 | foreach item $desc { |
---|
| 549 | if {[OptIsCounter $item]} continue; |
---|
| 550 | if {[OptIsPrg $item]} { |
---|
| 551 | set vnamesLst [OptTreeVars $item $level $vnamesLst]; |
---|
| 552 | } else { |
---|
| 553 | set vname [OptVarName $item]; |
---|
| 554 | upvar $level $vname var |
---|
| 555 | if {[OptHasBeenSet $item]} { |
---|
| 556 | # puts "adding $vname" |
---|
| 557 | # lets use the input name for the returned list |
---|
| 558 | # it is more usefull, for instance you can check that |
---|
| 559 | # no flags at all was given with expr |
---|
| 560 | # {![string match "*-*" $Args]} |
---|
| 561 | lappend vnamesLst [OptName $item]; |
---|
| 562 | set var [OptValue $item]; |
---|
| 563 | } else { |
---|
| 564 | set var [OptDefaultValue $item]; |
---|
| 565 | } |
---|
| 566 | } |
---|
| 567 | } |
---|
| 568 | return $vnamesLst |
---|
| 569 | } |
---|
| 570 | |
---|
| 571 | |
---|
| 572 | # Check the type of a value |
---|
| 573 | # and emit an error if arg is not of the correct type |
---|
| 574 | # otherwise returns the canonical value of that arg (ie 0/1 for booleans) |
---|
| 575 | proc ::tcl::OptCheckType {arg type {typeArgs ""}} { |
---|
| 576 | # puts "checking '$arg' against '$type' ($typeArgs)"; |
---|
| 577 | |
---|
| 578 | # only types "any", "choice", and numbers can have leading "-" |
---|
| 579 | |
---|
| 580 | switch -exact -- $type { |
---|
| 581 | int { |
---|
| 582 | if {![string is integer -strict $arg]} { |
---|
| 583 | error "not an integer" |
---|
| 584 | } |
---|
| 585 | return $arg; |
---|
| 586 | } |
---|
| 587 | float { |
---|
| 588 | return [expr {double($arg)}] |
---|
| 589 | } |
---|
| 590 | script - |
---|
| 591 | list { |
---|
| 592 | # if llength fail : malformed list |
---|
| 593 | if {[llength $arg]==0 && [OptIsFlag $arg]} { |
---|
| 594 | error "no values with leading -" |
---|
| 595 | } |
---|
| 596 | return $arg; |
---|
| 597 | } |
---|
| 598 | boolean { |
---|
| 599 | if {![string is boolean -strict $arg]} { |
---|
| 600 | error "non canonic boolean" |
---|
| 601 | } |
---|
| 602 | # convert true/false because expr/if is broken with "!,... |
---|
| 603 | return [expr {$arg ? 1 : 0}] |
---|
| 604 | } |
---|
| 605 | choice { |
---|
| 606 | if {[lsearch -exact $typeArgs $arg] < 0} { |
---|
| 607 | error "invalid choice" |
---|
| 608 | } |
---|
| 609 | return $arg; |
---|
| 610 | } |
---|
| 611 | any { |
---|
| 612 | return $arg; |
---|
| 613 | } |
---|
| 614 | string - |
---|
| 615 | default { |
---|
| 616 | if {[OptIsFlag $arg]} { |
---|
| 617 | error "no values with leading -" |
---|
| 618 | } |
---|
| 619 | return $arg |
---|
| 620 | } |
---|
| 621 | } |
---|
| 622 | return neverReached; |
---|
| 623 | } |
---|
| 624 | |
---|
| 625 | # internal utilities |
---|
| 626 | |
---|
| 627 | # returns the number of flags matching the given arg |
---|
| 628 | # sets the (local) prg counter to the list of matches |
---|
| 629 | proc OptHits {descName arg} { |
---|
| 630 | upvar $descName desc; |
---|
| 631 | set hits 0 |
---|
| 632 | set hitems {} |
---|
| 633 | set i 1; |
---|
| 634 | |
---|
| 635 | set larg [string tolower $arg]; |
---|
| 636 | set len [string length $larg]; |
---|
| 637 | set last [expr {$len-1}]; |
---|
| 638 | |
---|
| 639 | foreach item [lrange $desc 1 end] { |
---|
| 640 | set flag [OptName $item] |
---|
| 641 | # lets try to match case insensitively |
---|
| 642 | # (string length ought to be cheap) |
---|
| 643 | set lflag [string tolower $flag]; |
---|
| 644 | if {$len == [string length $lflag]} { |
---|
| 645 | if {[string equal $larg $lflag]} { |
---|
| 646 | # Exact match case |
---|
| 647 | OptSetPrgCounter desc $i; |
---|
| 648 | return 1; |
---|
| 649 | } |
---|
| 650 | } elseif {[string equal $larg [string range $lflag 0 $last]]} { |
---|
| 651 | lappend hitems $i; |
---|
| 652 | incr hits; |
---|
| 653 | } |
---|
| 654 | incr i; |
---|
| 655 | } |
---|
| 656 | if {$hits} { |
---|
| 657 | OptSetPrgCounter desc $hitems; |
---|
| 658 | } |
---|
| 659 | return $hits |
---|
| 660 | } |
---|
| 661 | |
---|
| 662 | # Extract fields from the list structure: |
---|
| 663 | |
---|
| 664 | proc OptName {item} { |
---|
| 665 | lindex $item 1; |
---|
| 666 | } |
---|
| 667 | proc OptHasBeenSet {item} { |
---|
| 668 | Lget $item {2 0}; |
---|
| 669 | } |
---|
| 670 | proc OptValue {item} { |
---|
| 671 | Lget $item {2 1}; |
---|
| 672 | } |
---|
| 673 | |
---|
| 674 | proc OptIsFlag {name} { |
---|
| 675 | string match "-*" $name; |
---|
| 676 | } |
---|
| 677 | proc OptIsOpt {name} { |
---|
| 678 | string match {\?*} $name; |
---|
| 679 | } |
---|
| 680 | proc OptVarName {item} { |
---|
| 681 | set name [OptName $item]; |
---|
| 682 | if {[OptIsFlag $name]} { |
---|
| 683 | return [string range $name 1 end]; |
---|
| 684 | } elseif {[OptIsOpt $name]} { |
---|
| 685 | return [string trim $name "?"]; |
---|
| 686 | } else { |
---|
| 687 | return $name; |
---|
| 688 | } |
---|
| 689 | } |
---|
| 690 | proc OptType {item} { |
---|
| 691 | lindex $item 3 |
---|
| 692 | } |
---|
| 693 | proc OptTypeArgs {item} { |
---|
| 694 | lindex $item 4 |
---|
| 695 | } |
---|
| 696 | proc OptHelp {item} { |
---|
| 697 | lindex $item 5 |
---|
| 698 | } |
---|
| 699 | proc OptNeedValue {item} { |
---|
| 700 | expr {![string equal [OptType $item] boolflag]} |
---|
| 701 | } |
---|
| 702 | proc OptDefaultValue {item} { |
---|
| 703 | set val [OptTypeArgs $item] |
---|
| 704 | switch -exact -- [OptType $item] { |
---|
| 705 | choice {return [lindex $val 0]} |
---|
| 706 | boolean - |
---|
| 707 | boolflag { |
---|
| 708 | # convert back false/true to 0/1 because expr !$bool |
---|
| 709 | # is broken.. |
---|
| 710 | if {$val} { |
---|
| 711 | return 1 |
---|
| 712 | } else { |
---|
| 713 | return 0 |
---|
| 714 | } |
---|
| 715 | } |
---|
| 716 | } |
---|
| 717 | return $val |
---|
| 718 | } |
---|
| 719 | |
---|
| 720 | # Description format error helper |
---|
| 721 | proc OptOptUsage {item {what ""}} { |
---|
| 722 | return -code error "invalid description format$what: $item\n\ |
---|
| 723 | should be a list of {varname|-flagname ?-type? ?defaultvalue?\ |
---|
| 724 | ?helpstring?}"; |
---|
| 725 | } |
---|
| 726 | |
---|
| 727 | |
---|
| 728 | # Generate a canonical form single instruction |
---|
| 729 | proc OptNewInst {state varname type typeArgs help} { |
---|
| 730 | list $state $varname [list 0 {}] $type $typeArgs $help; |
---|
| 731 | # ^ ^ |
---|
| 732 | # | | |
---|
| 733 | # hasBeenSet=+ +=currentValue |
---|
| 734 | } |
---|
| 735 | |
---|
| 736 | # Translate one item to canonical form |
---|
| 737 | proc OptNormalizeOne {item} { |
---|
| 738 | set lg [Lassign $item varname arg1 arg2 arg3]; |
---|
| 739 | # puts "called optnormalizeone '$item' v=($varname), lg=$lg"; |
---|
| 740 | set isflag [OptIsFlag $varname]; |
---|
| 741 | set isopt [OptIsOpt $varname]; |
---|
| 742 | if {$isflag} { |
---|
| 743 | set state "flags"; |
---|
| 744 | } elseif {$isopt} { |
---|
| 745 | set state "optValue"; |
---|
| 746 | } elseif {![string equal $varname "args"]} { |
---|
| 747 | set state "value"; |
---|
| 748 | } else { |
---|
| 749 | set state "args"; |
---|
| 750 | } |
---|
| 751 | |
---|
| 752 | # apply 'smart' 'fuzzy' logic to try to make |
---|
| 753 | # description writer's life easy, and our's difficult : |
---|
| 754 | # let's guess the missing arguments :-) |
---|
| 755 | |
---|
| 756 | switch $lg { |
---|
| 757 | 1 { |
---|
| 758 | if {$isflag} { |
---|
| 759 | return [OptNewInst $state $varname boolflag false ""]; |
---|
| 760 | } else { |
---|
| 761 | return [OptNewInst $state $varname any "" ""]; |
---|
| 762 | } |
---|
| 763 | } |
---|
| 764 | 2 { |
---|
| 765 | # varname default |
---|
| 766 | # varname help |
---|
| 767 | set type [OptGuessType $arg1] |
---|
| 768 | if {[string equal $type "string"]} { |
---|
| 769 | if {$isflag} { |
---|
| 770 | set type boolflag |
---|
| 771 | set def false |
---|
| 772 | } else { |
---|
| 773 | set type any |
---|
| 774 | set def "" |
---|
| 775 | } |
---|
| 776 | set help $arg1 |
---|
| 777 | } else { |
---|
| 778 | set help "" |
---|
| 779 | set def $arg1 |
---|
| 780 | } |
---|
| 781 | return [OptNewInst $state $varname $type $def $help]; |
---|
| 782 | } |
---|
| 783 | 3 { |
---|
| 784 | # varname type value |
---|
| 785 | # varname value comment |
---|
| 786 | |
---|
| 787 | if {[regexp {^-(.+)$} $arg1 x type]} { |
---|
| 788 | # flags/optValue as they are optional, need a "value", |
---|
| 789 | # on the contrary, for a variable (non optional), |
---|
| 790 | # default value is pointless, 'cept for choices : |
---|
| 791 | if {$isflag || $isopt || ($type == "choice")} { |
---|
| 792 | return [OptNewInst $state $varname $type $arg2 ""]; |
---|
| 793 | } else { |
---|
| 794 | return [OptNewInst $state $varname $type "" $arg2]; |
---|
| 795 | } |
---|
| 796 | } else { |
---|
| 797 | return [OptNewInst $state $varname\ |
---|
| 798 | [OptGuessType $arg1] $arg1 $arg2] |
---|
| 799 | } |
---|
| 800 | } |
---|
| 801 | 4 { |
---|
| 802 | if {[regexp {^-(.+)$} $arg1 x type]} { |
---|
| 803 | return [OptNewInst $state $varname $type $arg2 $arg3]; |
---|
| 804 | } else { |
---|
| 805 | return -code error [OptOptUsage $item]; |
---|
| 806 | } |
---|
| 807 | } |
---|
| 808 | default { |
---|
| 809 | return -code error [OptOptUsage $item]; |
---|
| 810 | } |
---|
| 811 | } |
---|
| 812 | } |
---|
| 813 | |
---|
| 814 | # Auto magic lazy type determination |
---|
| 815 | proc OptGuessType {arg} { |
---|
| 816 | if { $arg == "true" || $arg == "false" } { |
---|
| 817 | return boolean |
---|
| 818 | } |
---|
| 819 | if {[string is integer -strict $arg]} { |
---|
| 820 | return int |
---|
| 821 | } |
---|
| 822 | if {[string is double -strict $arg]} { |
---|
| 823 | return float |
---|
| 824 | } |
---|
| 825 | return string |
---|
| 826 | } |
---|
| 827 | |
---|
| 828 | # Error messages front ends |
---|
| 829 | |
---|
| 830 | proc OptAmbigous {desc arg} { |
---|
| 831 | OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc] |
---|
| 832 | } |
---|
| 833 | proc OptFlagUsage {desc arg} { |
---|
| 834 | OptError "bad flag \"$arg\", must be one of" $desc; |
---|
| 835 | } |
---|
| 836 | proc OptTooManyArgs {desc arguments} { |
---|
| 837 | OptError "too many arguments (unexpected argument(s): $arguments),\ |
---|
| 838 | usage:"\ |
---|
| 839 | $desc 1 |
---|
| 840 | } |
---|
| 841 | proc OptParamType {item} { |
---|
| 842 | if {[OptIsFlag $item]} { |
---|
| 843 | return "flag"; |
---|
| 844 | } else { |
---|
| 845 | return "parameter"; |
---|
| 846 | } |
---|
| 847 | } |
---|
| 848 | proc OptBadValue {item arg {err {}}} { |
---|
| 849 | # puts "bad val err = \"$err\""; |
---|
| 850 | OptError "bad value \"$arg\" for [OptParamType $item]"\ |
---|
| 851 | [list $item] |
---|
| 852 | } |
---|
| 853 | proc OptMissingValue {descriptions} { |
---|
| 854 | # set item [OptCurDescFinal $descriptions]; |
---|
| 855 | set item [OptCurDesc $descriptions]; |
---|
| 856 | OptError "no value given for [OptParamType $item] \"[OptName $item]\"\ |
---|
| 857 | (use -help for full usage) :"\ |
---|
| 858 | [list $item] |
---|
| 859 | } |
---|
| 860 | |
---|
| 861 | proc ::tcl::OptKeyError {prefix descKey {header 0}} { |
---|
| 862 | OptError $prefix [OptKeyGetDesc $descKey] $header; |
---|
| 863 | } |
---|
| 864 | |
---|
| 865 | # determine string length for nice tabulated output |
---|
| 866 | proc OptLengths {desc nlName tlName dlName} { |
---|
| 867 | upvar $nlName nl; |
---|
| 868 | upvar $tlName tl; |
---|
| 869 | upvar $dlName dl; |
---|
| 870 | foreach item $desc { |
---|
| 871 | if {[OptIsCounter $item]} continue; |
---|
| 872 | if {[OptIsPrg $item]} { |
---|
| 873 | OptLengths $item nl tl dl |
---|
| 874 | } else { |
---|
| 875 | SetMax nl [string length [OptName $item]] |
---|
| 876 | SetMax tl [string length [OptType $item]] |
---|
| 877 | set dv [OptTypeArgs $item]; |
---|
| 878 | if {[OptState $item] != "header"} { |
---|
| 879 | set dv "($dv)"; |
---|
| 880 | } |
---|
| 881 | set l [string length $dv]; |
---|
| 882 | # limit the space allocated to potentially big "choices" |
---|
| 883 | if {([OptType $item] != "choice") || ($l<=12)} { |
---|
| 884 | SetMax dl $l |
---|
| 885 | } else { |
---|
| 886 | if {![info exists dl]} { |
---|
| 887 | set dl 0 |
---|
| 888 | } |
---|
| 889 | } |
---|
| 890 | } |
---|
| 891 | } |
---|
| 892 | } |
---|
| 893 | # output the tree |
---|
| 894 | proc OptTree {desc nl tl dl} { |
---|
| 895 | set res ""; |
---|
| 896 | foreach item $desc { |
---|
| 897 | if {[OptIsCounter $item]} continue; |
---|
| 898 | if {[OptIsPrg $item]} { |
---|
| 899 | append res [OptTree $item $nl $tl $dl]; |
---|
| 900 | } else { |
---|
| 901 | set dv [OptTypeArgs $item]; |
---|
| 902 | if {[OptState $item] != "header"} { |
---|
| 903 | set dv "($dv)"; |
---|
| 904 | } |
---|
| 905 | append res [format "\n %-*s %-*s %-*s %s" \ |
---|
| 906 | $nl [OptName $item] $tl [OptType $item] \ |
---|
| 907 | $dl $dv [OptHelp $item]] |
---|
| 908 | } |
---|
| 909 | } |
---|
| 910 | return $res; |
---|
| 911 | } |
---|
| 912 | |
---|
| 913 | # Give nice usage string |
---|
| 914 | proc ::tcl::OptError {prefix desc {header 0}} { |
---|
| 915 | # determine length |
---|
| 916 | if {$header} { |
---|
| 917 | # add faked instruction |
---|
| 918 | set h [list [OptNewInst header Var/FlagName Type Value Help]]; |
---|
| 919 | lappend h [OptNewInst header ------------ ---- ----- ----]; |
---|
| 920 | lappend h [OptNewInst header {( -help} "" "" {gives this help )}] |
---|
| 921 | set desc [concat $h $desc] |
---|
| 922 | } |
---|
| 923 | OptLengths $desc nl tl dl |
---|
| 924 | # actually output |
---|
| 925 | return "$prefix[OptTree $desc $nl $tl $dl]" |
---|
| 926 | } |
---|
| 927 | |
---|
| 928 | |
---|
| 929 | ################ General Utility functions ####################### |
---|
| 930 | |
---|
| 931 | # |
---|
| 932 | # List utility functions |
---|
| 933 | # Naming convention: |
---|
| 934 | # "Lvarxxx" take the list VARiable name as argument |
---|
| 935 | # "Lxxxx" take the list value as argument |
---|
| 936 | # (which is not costly with Tcl8 objects system |
---|
| 937 | # as it's still a reference and not a copy of the values) |
---|
| 938 | # |
---|
| 939 | |
---|
| 940 | # Is that list empty ? |
---|
| 941 | proc ::tcl::Lempty {list} { |
---|
| 942 | expr {[llength $list]==0} |
---|
| 943 | } |
---|
| 944 | |
---|
| 945 | # Gets the value of one leaf of a lists tree |
---|
| 946 | proc ::tcl::Lget {list indexLst} { |
---|
| 947 | if {[llength $indexLst] <= 1} { |
---|
| 948 | return [lindex $list $indexLst]; |
---|
| 949 | } |
---|
| 950 | Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end]; |
---|
| 951 | } |
---|
| 952 | # Sets the value of one leaf of a lists tree |
---|
| 953 | # (we use the version that does not create the elements because |
---|
| 954 | # it would be even slower... needs to be written in C !) |
---|
| 955 | # (nb: there is a non trivial recursive problem with indexes 0, |
---|
| 956 | # which appear because there is no difference between a list |
---|
| 957 | # of 1 element and 1 element alone : [list "a"] == "a" while |
---|
| 958 | # it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1 |
---|
| 959 | # and [listp "a b"] maybe 0. listp does not exist either...) |
---|
| 960 | proc ::tcl::Lvarset {listName indexLst newValue} { |
---|
| 961 | upvar $listName list; |
---|
| 962 | if {[llength $indexLst] <= 1} { |
---|
| 963 | Lvarset1nc list $indexLst $newValue; |
---|
| 964 | } else { |
---|
| 965 | set idx [lindex $indexLst 0]; |
---|
| 966 | set targetList [lindex $list $idx]; |
---|
| 967 | # reduce refcount on targetList (not really usefull now, |
---|
| 968 | # could be with optimizing compiler) |
---|
| 969 | # Lvarset1 list $idx {}; |
---|
| 970 | # recursively replace in targetList |
---|
| 971 | Lvarset targetList [lrange $indexLst 1 end] $newValue; |
---|
| 972 | # put updated sub list back in the tree |
---|
| 973 | Lvarset1nc list $idx $targetList; |
---|
| 974 | } |
---|
| 975 | } |
---|
| 976 | # Set one cell to a value, eventually create all the needed elements |
---|
| 977 | # (on level-1 of lists) |
---|
| 978 | variable emptyList {} |
---|
| 979 | proc ::tcl::Lvarset1 {listName index newValue} { |
---|
| 980 | upvar $listName list; |
---|
| 981 | if {$index < 0} {return -code error "invalid negative index"} |
---|
| 982 | set lg [llength $list]; |
---|
| 983 | if {$index >= $lg} { |
---|
| 984 | variable emptyList; |
---|
| 985 | for {set i $lg} {$i<$index} {incr i} { |
---|
| 986 | lappend list $emptyList; |
---|
| 987 | } |
---|
| 988 | lappend list $newValue; |
---|
| 989 | } else { |
---|
| 990 | set list [lreplace $list $index $index $newValue]; |
---|
| 991 | } |
---|
| 992 | } |
---|
| 993 | # same as Lvarset1 but no bound checking / creation |
---|
| 994 | proc ::tcl::Lvarset1nc {listName index newValue} { |
---|
| 995 | upvar $listName list; |
---|
| 996 | set list [lreplace $list $index $index $newValue]; |
---|
| 997 | } |
---|
| 998 | # Increments the value of one leaf of a lists tree |
---|
| 999 | # (which must exists) |
---|
| 1000 | proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} { |
---|
| 1001 | upvar $listName list; |
---|
| 1002 | if {[llength $indexLst] <= 1} { |
---|
| 1003 | Lvarincr1 list $indexLst $howMuch; |
---|
| 1004 | } else { |
---|
| 1005 | set idx [lindex $indexLst 0]; |
---|
| 1006 | set targetList [lindex $list $idx]; |
---|
| 1007 | # reduce refcount on targetList |
---|
| 1008 | Lvarset1nc list $idx {}; |
---|
| 1009 | # recursively replace in targetList |
---|
| 1010 | Lvarincr targetList [lrange $indexLst 1 end] $howMuch; |
---|
| 1011 | # put updated sub list back in the tree |
---|
| 1012 | Lvarset1nc list $idx $targetList; |
---|
| 1013 | } |
---|
| 1014 | } |
---|
| 1015 | # Increments the value of one cell of a list |
---|
| 1016 | proc ::tcl::Lvarincr1 {listName index {howMuch 1}} { |
---|
| 1017 | upvar $listName list; |
---|
| 1018 | set newValue [expr {[lindex $list $index]+$howMuch}]; |
---|
| 1019 | set list [lreplace $list $index $index $newValue]; |
---|
| 1020 | return $newValue; |
---|
| 1021 | } |
---|
| 1022 | # Removes the first element of a list |
---|
| 1023 | # and returns the new list value |
---|
| 1024 | proc ::tcl::Lvarpop1 {listName} { |
---|
| 1025 | upvar $listName list; |
---|
| 1026 | set list [lrange $list 1 end]; |
---|
| 1027 | } |
---|
| 1028 | # Same but returns the removed element |
---|
| 1029 | # (Like the tclX version) |
---|
| 1030 | proc ::tcl::Lvarpop {listName} { |
---|
| 1031 | upvar $listName list; |
---|
| 1032 | set el [lindex $list 0]; |
---|
| 1033 | set list [lrange $list 1 end]; |
---|
| 1034 | return $el; |
---|
| 1035 | } |
---|
| 1036 | # Assign list elements to variables and return the length of the list |
---|
| 1037 | proc ::tcl::Lassign {list args} { |
---|
| 1038 | # faster than direct blown foreach (which does not byte compile) |
---|
| 1039 | set i 0; |
---|
| 1040 | set lg [llength $list]; |
---|
| 1041 | foreach vname $args { |
---|
| 1042 | if {$i>=$lg} break |
---|
| 1043 | uplevel 1 [list ::set $vname [lindex $list $i]]; |
---|
| 1044 | incr i; |
---|
| 1045 | } |
---|
| 1046 | return $lg; |
---|
| 1047 | } |
---|
| 1048 | |
---|
| 1049 | # Misc utilities |
---|
| 1050 | |
---|
| 1051 | # Set the varname to value if value is greater than varname's current value |
---|
| 1052 | # or if varname is undefined |
---|
| 1053 | proc ::tcl::SetMax {varname value} { |
---|
| 1054 | upvar 1 $varname var |
---|
| 1055 | if {![info exists var] || $value > $var} { |
---|
| 1056 | set var $value |
---|
| 1057 | } |
---|
| 1058 | } |
---|
| 1059 | |
---|
| 1060 | # Set the varname to value if value is smaller than varname's current value |
---|
| 1061 | # or if varname is undefined |
---|
| 1062 | proc ::tcl::SetMin {varname value} { |
---|
| 1063 | upvar 1 $varname var |
---|
| 1064 | if {![info exists var] || $value < $var} { |
---|
| 1065 | set var $value |
---|
| 1066 | } |
---|
| 1067 | } |
---|
| 1068 | |
---|
| 1069 | |
---|
| 1070 | # everything loaded fine, lets create the test proc: |
---|
| 1071 | # OptCreateTestProc |
---|
| 1072 | # Don't need the create temp proc anymore: |
---|
| 1073 | # rename OptCreateTestProc {} |
---|
| 1074 | } |
---|