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