tcl/library/opt0.1/optparse.tcl

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