I686LINUX/util/I686LINUX/lib/tcl8.4/opt0.4/optparse.tcl

   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
  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.4.1
  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 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
 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 }