Mercurial > repos > rliterman > csp2

comparison CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tcl8.6/opt0.4/optparse.tcl @ 68:5028fdace37b

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