figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

optparse.tcl (32718B)


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