source: proiecte/pmake3d/make3d_original/Make3dSingleImageStanford_version0.1/third_party/vrippack-0.31/src/vrip/lib/tcl/opt0.4/optparse.tcl @ 37

Last change on this file since 37 was 37, checked in by (none), 14 years ago

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