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.8.2.1 2003/09/10 20:29:59 dgp Exp $ 12 13package require Tcl 8.2 14# When this version number changes, update the pkgIndex.tcl file 15# and the install directory in the Makefiles. 16package provide opt 0.4.4.1 17 18namespace 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# 147proc ::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# 217proc ::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 236proc ::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". 250proc ::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 265proc ::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 526proc ::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) 575proc ::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 lasy type determination 815 proc OptGuessType {arg} { 816 if {[regexp -nocase {^(true|false)$} $arg]} { 817 return boolean 818 } 819 if {[regexp {^(-+)?[0-9]+$} $arg]} { 820 return int 821 } 822 if {![catch {expr {double($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 861proc ::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 914proc ::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 ? 941proc ::tcl::Lempty {list} { 942 expr {[llength $list]==0} 943} 944 945# Gets the value of one leaf of a lists tree 946proc ::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...) 960proc ::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) 978variable emptyList {} 979proc ::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 994proc ::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) 1000proc ::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 1016proc ::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 1024proc ::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) 1030proc ::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 1037proc ::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 1053proc ::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 1062proc ::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} 1075