Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: data/media/tcl8.5/opt/optparse.tcl @ 5523

Last change on this file since 5523 was 5167, checked in by rgrieder, 16 years ago

added svn property svn:eol-style native to all tcl files
  • Property svn:eol-style set to native
File size: 32.2 KB
Line 
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.10 2003/09/10 20:27:30 dgp Exp $
12
13package require Tcl 8.2
14# When this version number changes, update the pkgIndex.tcl file
15# and the install directory in the Makefiles.
16package provide opt 0.4.5
17
18namespace 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#
147proc ::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#
217proc ::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
236proc ::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".
250proc ::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
265proc ::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
526proc ::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)
575proc ::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 lazy type determination
815    proc OptGuessType {arg} {
816         if { $arg == "true" || $arg == "false" } {
817            return boolean
818        }
819        if {[string is integer -strict $arg]} {
820            return int
821        }
822        if {[string is double -strict $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
861proc ::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
914proc ::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 ?
941proc ::tcl::Lempty {list} {
942    expr {[llength $list]==0}
943}
944
945# Gets the value of one leaf of a lists tree
946proc ::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...)
960proc ::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)
978variable emptyList {}
979proc ::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
994proc ::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)
1000proc ::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
1016proc ::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
1024proc ::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)
1030proc ::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
1037proc ::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
1053proc ::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
1062proc ::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}
Note: See TracBrowser for help on using the repository browser.