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