optparse.tcl
上传用户:rrhhcc
上传日期:2015-12-11
资源大小:54129k
文件大小:32k
源码类别:

通讯编程

开发平台:

Visual C++

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