Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tcl8.6/opt0.4/optparse.tcl @ 69:33d812a61356

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