Commit | Line | Data |
---|---|---|
920dae64 AT |
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 | } |