3
# (Private) option parsing package
5
# This might be documented and exported in 8.1
6
# and some function hopefully moved to the C core for
7
# efficiency, if there is enough demand. (mail! ;-)
9
# Author: Laurent Demailly - Laurent.Demailly@sun.com - dl@mail.box.eu.org
12
# this is a complete 'over kill' rewrite by me, from a version
13
# written initially with Brent Welch, itself initially
14
# based on work with Steve Uhler. Thanks them !
16
# SCCS: @(#) optparse.tcl 1.13 97/08/21 11:50:42
18
package provide opt 0.2
20
namespace eval ::tcl {
23
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
24
OptProc OptProcArgGiven OptParse \
25
Lassign Lvarpop Lvarset Lvarincr Lfirst \
29
################# Example of use / 'user documentation' ###################
31
proc OptCreateTestProc {} {
33
# Defines ::tcl::OptParseTest as a test proc with parsed arguments
34
# (can't be defined before the code below is loaded (before "OptProc"))
36
# Every OptProc give usage information on "procname -help".
37
# Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
38
# then other arguments.
40
# example of 'valid' call:
41
# ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
42
# -nostatics false ch1
43
OptProc OptParseTest {
44
{subcommand -choice {save print} "sub command"}
45
{arg1 3 "some number"}
48
{-weirdflag "help string"}
49
{-noStatics "Not ok to load static packages"}
50
{-nestedloading1 true "OK to load into nested slaves"}
51
{-nestedloading2 -boolean true "OK to load into nested slaves"}
52
{-libsOK -choice {Tk SybTcl}
53
"List of packages that can be loaded"}
54
{-precision -int 12 "Number of digits of precision"}
55
{-intval 7 "An integer"}
56
{-scale -float 1.0 "Scale factor"}
57
{-zoom 1.0 "Zoom factor"}
58
{-arbitrary foobar "Arbitrary string"}
59
{-random -string 12 "Random string"}
60
{-listval -list {} "List value"}
61
{-blahflag -blah abc "Funny type"}
62
{arg2 -boolean "a boolean"}
63
{arg3 -choice "ch1 ch2"}
64
{?optarg? -list {} "optional argument"}
66
foreach v [info locals] {
67
puts stderr [format "%14s : %s" $v [set $v]]
72
################### No User serviceable part below ! ###############
73
# You should really not look any further :
74
# The following is private unexported undocumented unblessed... code
75
# time to hit "q" ;-) !
77
# Hmmm... ok, you really want to know ?
79
# You've been warned... Here it is...
81
# Array storing the parsed descriptions
84
# Next potentially free key id (numeric)
87
# Inside algorithm/mechanism description:
88
# (not for the faint hearted ;-)
90
# The argument description is parsed into a "program tree"
91
# It is called a "program" because it is the program used by
92
# the state machine interpreter that use that program to
93
# actually parse the arguments at run time.
95
# The general structure of a "program" is
96
# notation (pseudo bnf like)
97
# name :== definition defines "name" as being "definition"
98
# { x y z } means list of x, y, and z
99
# x* means x repeated 0 or more time
101
# x? means optionally x
103
# "cccc" means the literal string
105
# program :== { programCounter programStep* }
107
# programStep :== program | singleStep
109
# programCounter :== {"P" integer+ }
111
# singleStep :== { instruction parameters* }
113
# instruction :== single element list
115
# (the difference between singleStep and program is that \
116
# llength [Lfirst $program] >= 2
118
# llength [Lfirst $singleStep] == 1
121
# And for this application:
123
# singleStep :== { instruction varname {hasBeenSet currentValue} type
125
# instruction :== "flags" | "value"
126
# type :== knowType | anyword
127
# knowType :== "string" | "int" | "boolean" | "boolflag" | "float"
130
# for type "choice" typeArgs is a list of possible choices, the first one
131
# is the default value. for all other types the typeArgs is the default value
133
# a "boolflag" is the type for a flag whose presence or absence, without
134
# additional arguments means respectively true or false (default flag type).
136
# programCounter is the index in the list of the currently processed
137
# programStep (thus starting at 1 (0 is {"P" prgCounterValue}).
138
# If it is a list it points toward each currently selected programStep.
139
# (like for "flags", as they are optional, form a set and programStep).
141
# Performance/Implementation issues
142
# ---------------------------------
143
# We use tcl lists instead of arrays because with tcl8.0
144
# they should start to be much faster.
145
# But this code use a lot of helper procs (like Lvarset)
146
# which are quite slow and would be helpfully optimized
147
# for instance by being written in C. Also our struture
148
# is complex and there is maybe some places where the
149
# string rep might be calculated at great exense. to be checked.
152
# Parse a given description and saves it here under the given key
153
# generate a unused keyid if not given
155
proc ::tcl::OptKeyRegister {desc {key ""}} {
158
if {[string compare $key ""] == 0} {
159
# in case a key given to us as a parameter was a number
160
while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
165
set program [list [list "P" 1]];
167
# are we processing flags (which makes a single program step)
172
# flag used to detect that we just have a single (flags set) subprogram.
176
if {$state == "args"} {
177
# more items after 'args'...
178
return -code error "'args' special argument must be the last one";
180
set res [OptNormalizeOne $item];
181
set state [Lfirst $res];
183
if {$state == "flags"} {
184
# add to 'subprogram'
185
lappend flagsprg $res;
188
# structure for flag programs items is a list of
189
# {subprgcounter {prg flag 1} {prg flag 2} {...}}
190
lappend program $flagsprg;
191
# put the other regular stuff
192
lappend program $res;
197
if {$state == "flags"} {
199
# sub program counter + first sub program
200
set flagsprg [list [list "P" 1] $res];
202
lappend program $res;
209
# We just have the subprogram, optimize and remove
211
set program $flagsprg;
213
lappend program $flagsprg;
217
set OptDesc($key) $program;
223
# Free the storage for that given key
225
proc ::tcl::OptKeyDelete {key} {
230
# Get the parsed description stored under the given key.
231
proc OptKeyGetDesc {descKey} {
233
if {![info exists OptDesc($descKey)]} {
234
return -code error "Unknown option description key \"$descKey\"";
236
set OptDesc($descKey);
239
# Parse entry point for ppl who don't want to register with a key,
240
# for instance because the description changes dynamically.
241
# (otherwise one should really use OptKeyRegister once + OptKeyParse
242
# as it is way faster or simply OptProc which does it all)
243
# Assign a temporary key, call OptKeyParse and then free the storage
244
proc ::tcl::OptParse {desc arglist} {
245
set tempkey [OptKeyRegister $desc];
246
set ret [catch {uplevel [list ::tcl::OptKeyParse $tempkey $arglist]} res];
247
OptKeyDelete $tempkey;
248
return -code $ret $res;
251
# Helper function, replacement for proc that both
252
# register the description under a key which is the name of the proc
253
# (and thus unique to that code)
254
# and add a first line to the code to call the OptKeyParse proc
255
# Stores the list of variables that have been actually given by the user
256
# (the other will be sets to their default value)
257
# into local variable named "Args".
258
proc ::tcl::OptProc {name desc body} {
259
set namespace [uplevel namespace current];
260
if { ([string match $name "::*"])
261
|| ([string compare $namespace "::"]==0)} {
262
# absolute name or global namespace, name is the key
265
# we are relative to some non top level namespace:
266
set key "${namespace}::${name}";
268
OptKeyRegister $desc $key;
269
uplevel [list proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"];
272
# Check that a argument has been given
273
# assumes that "OptProc" has been used as it will check in "Args" list
274
proc ::tcl::OptProcArgGiven {argname} {
276
expr {[lsearch $alist $argname] >=0}
280
# Programs/Descriptions manipulation
282
# Return the instruction word/list of a given step/(sub)program
283
proc OptInstr {lst} {
286
# Is a (sub) program or a plain instruction ?
287
proc OptIsPrg {lst} {
288
expr {[llength [OptInstr $lst]]>=2}
290
# Is this instruction a program counter or a real instr
291
proc OptIsCounter {item} {
292
expr {[Lfirst $item]=="P"}
294
# Current program counter (2nd word of first word)
295
proc OptGetPrgCounter {lst} {
298
# Current program counter (2nd word of first word)
299
proc OptSetPrgCounter {lstName newValue} {
301
set lst [lreplace $lst 0 0 [concat "P" $newValue]];
303
# returns a list of currently selected items.
304
proc OptSelection {lst} {
306
foreach idx [lrange [Lfirst $lst] 1 end] {
307
lappend res [Lget $lst $idx];
312
# Advance to next description
313
proc OptNextDesc {descName} {
314
uplevel [list Lvarincr $descName {0 1}];
317
# Get the current description, eventually descend
318
proc OptCurDesc {descriptions} {
319
lindex $descriptions [OptGetPrgCounter $descriptions];
321
# get the current description, eventually descend
322
# through sub programs as needed.
323
proc OptCurDescFinal {descriptions} {
324
set item [OptCurDesc $descriptions];
325
# Descend untill we get the actual item and not a sub program
326
while {[OptIsPrg $item]} {
327
set item [OptCurDesc $item];
331
# Current final instruction adress
332
proc OptCurAddr {descriptions {start {}}} {
333
set adress [OptGetPrgCounter $descriptions];
334
lappend start $adress;
335
set item [lindex $descriptions $adress];
336
if {[OptIsPrg $item]} {
337
return [OptCurAddr $item $start];
342
# Set the value field of the current instruction
343
proc OptCurSetValue {descriptionsName value} {
344
upvar $descriptionsName descriptions
345
# get the current item full adress
346
set adress [OptCurAddr $descriptions];
347
# use the 3th field of the item (see OptValue / OptNewInst)
349
Lvarset descriptions $adress [list 1 $value];
353
# empty state means done/paste the end of the program
354
proc OptState {item} {
359
proc OptCurState {descriptions} {
360
OptState [OptCurDesc $descriptions];
364
# Arguments manipulation
366
# Returns the argument that has to be processed now
367
proc OptCurrentArg {lst} {
370
# Advance to next argument
371
proc OptNextArg {argsName} {
372
uplevel [list Lvarpop $argsName];
380
# Loop over all descriptions, calling OptDoOne which will
381
# eventually eat all the arguments.
382
proc OptDoAll {descriptionsName argumentsName} {
383
upvar $descriptionsName descriptions
384
upvar $argumentsName arguments;
385
# puts "entered DoAll";
386
# Nb: the places where "state" can be set are tricky to figure
387
# because DoOne sets the state to flagsValue and return -continue
389
set state [OptCurState $descriptions];
390
# We'll exit the loop in "OptDoOne" or when state is empty.
392
set curitem [OptCurDesc $descriptions];
393
# Do subprograms if needed, call ourselves on the sub branch
394
while {[OptIsPrg $curitem]} {
395
OptDoAll curitem arguments
396
# puts "done DoAll sub";
397
# Insert back the results in current tree;
398
Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
400
OptNextDesc descriptions;
401
set curitem [OptCurDesc $descriptions];
402
set state [OptCurState $descriptions];
404
# puts "state = \"$state\" - arguments=($arguments)";
405
if {[Lempty $state]} {
406
# Nothing left to do, we are done in this branch:
409
# The following statement can make us terminate/continue
410
# as it use return -code {break, continue, return and error}
412
OptDoOne descriptions state arguments;
413
# If we are here, no special return code where issued,
414
# we'll step to next instruction :
415
# puts "new state = \"$state\"";
416
OptNextDesc descriptions;
417
set state [OptCurState $descriptions];
419
if {![Lempty $arguments]} {
420
return -code error [OptTooManyArgs $descriptions $arguments];
424
# Process one step for the state machine,
425
# eventually consuming the current argument.
426
proc OptDoOne {descriptionsName stateName argumentsName} {
427
upvar $argumentsName arguments;
428
upvar $descriptionsName descriptions;
429
upvar $stateName state;
431
# the special state/instruction "args" eats all
432
# the remaining args (if any)
433
if {($state == "args")} {
434
OptCurSetValue descriptions $arguments;
436
# puts "breaking out ('args' state: consuming every reminding args)"
440
if {[Lempty $arguments]} {
441
if {$state == "flags"} {
442
# no argument and no flags : we're done
443
# puts "returning to previous (sub)prg (no more args)";
445
} elseif {$state == "optValue"} {
446
set state next; # not used, for debug only
450
return -code error [OptMissingValue $descriptions];
453
set arg [OptCurrentArg $arguments];
458
# A non-dash argument terminates the options, as does --
461
if {![OptIsFlag $arg]} {
462
# don't consume the argument, return to previous prg
466
OptNextArg arguments;
467
if {[string compare "--" $arg] == 0} {
468
# return from 'flags' state
472
set hits [OptHits descriptions $arg];
474
return -code error [OptAmbigous $descriptions $arg]
475
} elseif {$hits == 0} {
476
return -code error [OptFlagUsage $descriptions $arg]
478
set item [OptCurDesc $descriptions];
479
if {[OptNeedValue $item]} {
480
# we need a value, next state is
483
OptCurSetValue descriptions 1;
486
return -code continue;
490
set item [OptCurDesc $descriptions];
491
# Test the values against their required type
492
if [catch {OptCheckType $arg\
493
[OptType $item] [OptTypeArgs $item]} val] {
494
return -code error [OptBadValue $item $arg $val]
497
OptNextArg arguments;
499
OptCurSetValue descriptions $val;
501
if {$state == "flagValue"} {
503
return -code continue;
505
set state next; # not used, for debug only
506
return ; # will go on next step
510
set item [OptCurDesc $descriptions];
511
# Test the values against their required type
512
if ![catch {OptCheckType $arg\
513
[OptType $item] [OptTypeArgs $item]} val] {
516
OptNextArg arguments;
518
OptCurSetValue descriptions $val;
521
set state next; # not used, for debug only
522
return ; # will go on next step
525
# If we reach this point: an unknown
526
# state as been entered !
527
return -code error "Bug! unknown state in DoOne \"$state\"\
528
(prg counter [OptGetPrgCounter $descriptions]:\
529
[OptCurDesc $descriptions])";
532
# Parse the options given the key to previously registered description
534
proc ::tcl::OptKeyParse {descKey arglist} {
536
set desc [OptKeyGetDesc $descKey];
538
# make sure -help always give usage
539
if {[string compare "-help" [string tolower $arglist]] == 0} {
540
return -code error [OptError "Usage information:" $desc 1];
543
OptDoAll desc arglist;
546
# Walk through the tree:
547
OptTreeVars $desc "#[expr [info level]-1]" ;
550
# determine string length for nice tabulated output
551
proc OptTreeVars {desc level {vnamesLst {}}} {
553
if {[OptIsCounter $item]} continue;
554
if {[OptIsPrg $item]} {
555
set vnamesLst [OptTreeVars $item $level $vnamesLst];
557
set vname [OptVarName $item];
558
upvar $level $vname var
559
if {[OptHasBeenSet $item]} {
560
# puts "adding $vname"
561
# lets use the input name for the returned list
562
# it is more usefull, for instance you can check that
563
# no flags at all was given with expr
564
# {![string match "*-*" $Args]}
565
lappend vnamesLst [OptName $item];
566
set var [OptValue $item];
568
set var [OptDefaultValue $item];
576
# Check the type of a value
577
# and emit an error if arg is not of the correct type
578
# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
579
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
580
# puts "checking '$arg' against '$type' ($typeArgs)";
582
# only types "any", "choice", and numbers can have leading "-"
584
switch -exact -- $type {
586
if ![regexp {^(-+)?[0-9]+$} $arg] {
587
error "not an integer"
592
return [expr double($arg)]
596
# if llength fail : malformed list
597
if {[llength $arg]==0} {
598
if {[OptIsFlag $arg]} {
599
error "no values with leading -"
605
if ![regexp -nocase {^(true|false|0|1)$} $arg] {
606
error "non canonic boolean"
608
# convert true/false because expr/if is broken with "!,...
616
if {[lsearch -exact $typeArgs $arg] < 0} {
617
error "invalid choice"
626
if {[OptIsFlag $arg]} {
627
error "no values with leading -"
637
# returns the number of flags matching the given arg
638
# sets the (local) prg counter to the list of matches
639
proc OptHits {descName arg} {
640
upvar $descName desc;
645
set larg [string tolower $arg];
646
set len [string length $larg];
647
set last [expr $len-1];
649
foreach item [lrange $desc 1 end] {
650
set flag [OptName $item]
651
# lets try to match case insensitively
652
# (string length ought to be cheap)
653
set lflag [string tolower $flag];
654
if {$len == [string length $lflag]} {
655
if {[string compare $larg $lflag]==0} {
657
OptSetPrgCounter desc $i;
661
if {[string compare $larg [string range $lflag 0 $last]]==0} {
669
OptSetPrgCounter desc $hitems;
674
# Extract fields from the list structure:
676
proc OptName {item} {
680
proc OptHasBeenSet {item} {
684
proc OptValue {item} {
688
proc OptIsFlag {name} {
689
string match "-*" $name;
691
proc OptIsOpt {name} {
692
string match {\?*} $name;
694
proc OptVarName {item} {
695
set name [OptName $item];
696
if {[OptIsFlag $name]} {
697
return [string range $name 1 end];
698
} elseif {[OptIsOpt $name]} {
699
return [string trim $name "?"];
704
proc OptType {item} {
707
proc OptTypeArgs {item} {
710
proc OptHelp {item} {
713
proc OptNeedValue {item} {
714
string compare [OptType $item] boolflag
716
proc OptDefaultValue {item} {
717
set val [OptTypeArgs $item]
718
switch -exact -- [OptType $item] {
719
choice {return [lindex $val 0]}
722
# convert back false/true to 0/1 because expr !$bool
734
# Description format error helper
735
proc OptOptUsage {item {what ""}} {
736
return -code error "invalid description format$what: $item\n\
737
should be a list of {varname|-flagname ?-type? ?defaultvalue?\
742
# Generate a canonical form single instruction
743
proc OptNewInst {state varname type typeArgs help} {
744
list $state $varname [list 0 {}] $type $typeArgs $help;
747
# hasBeenSet=+ +=currentValue
750
# Translate one item to canonical form
751
proc OptNormalizeOne {item} {
752
set lg [Lassign $item varname arg1 arg2 arg3];
753
# puts "called optnormalizeone '$item' v=($varname), lg=$lg";
754
set isflag [OptIsFlag $varname];
755
set isopt [OptIsOpt $varname];
759
set state "optValue";
760
} elseif {[string compare $varname "args"]} {
766
# apply 'smart' 'fuzzy' logic to try to make
767
# description writer's life easy, and our's difficult :
768
# let's guess the missing arguments :-)
773
return [OptNewInst $state $varname boolflag false ""];
775
return [OptNewInst $state $varname any "" ""];
781
set type [OptGuessType $arg1]
782
if {[string compare $type "string"] == 0} {
795
return [OptNewInst $state $varname $type $def $help];
799
# varname value comment
801
if [regexp {^-(.+)$} $arg1 x type] {
802
# flags/optValue as they are optional, need a "value",
803
# on the contrary, for a variable (non optional),
804
# default value is pointless, 'cept for choices :
805
if {$isflag || $isopt || ($type == "choice")} {
806
return [OptNewInst $state $varname $type $arg2 ""];
808
return [OptNewInst $state $varname $type "" $arg2];
811
return [OptNewInst $state $varname\
812
[OptGuessType $arg1] $arg1 $arg2]
816
if [regexp {^-(.+)$} $arg1 x type] {
817
return [OptNewInst $state $varname $type $arg2 $arg3];
819
return -code error [OptOptUsage $item];
823
return -code error [OptOptUsage $item];
828
# Auto magic lasy type determination
829
proc OptGuessType {arg} {
830
if [regexp -nocase {^(true|false)$} $arg] {
833
if [regexp {^(-+)?[0-9]+$} $arg] {
836
if ![catch {expr double($arg)}] {
842
# Error messages front ends
844
proc OptAmbigous {desc arg} {
845
OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
847
proc OptFlagUsage {desc arg} {
848
OptError "bad flag \"$arg\", must be one of" $desc;
850
proc OptTooManyArgs {desc arguments} {
851
OptError "too many arguments (unexpected argument(s): $arguments),\
855
proc OptParamType {item} {
856
if {[OptIsFlag $item]} {
862
proc OptBadValue {item arg {err {}}} {
863
# puts "bad val err = \"$err\"";
864
OptError "bad value \"$arg\" for [OptParamType $item]"\
867
proc OptMissingValue {descriptions} {
868
# set item [OptCurDescFinal $descriptions];
869
set item [OptCurDesc $descriptions];
870
OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
871
(use -help for full usage) :"\
875
proc ::tcl::OptKeyError {prefix descKey {header 0}} {
876
OptError $prefix [OptKeyGetDesc $descKey] $header;
879
# determine string length for nice tabulated output
880
proc OptLengths {desc nlName tlName dlName} {
885
if {[OptIsCounter $item]} continue;
886
if {[OptIsPrg $item]} {
887
OptLengths $item nl tl dl
889
SetMax nl [string length [OptName $item]]
890
SetMax tl [string length [OptType $item]]
891
set dv [OptTypeArgs $item];
892
if {[OptState $item] != "header"} {
895
set l [string length $dv];
896
# limit the space allocated to potentially big "choices"
897
if {([OptType $item] != "choice") || ($l<=12)} {
900
if {![info exists dl]} {
908
proc OptTree {desc nl tl dl} {
911
if {[OptIsCounter $item]} continue;
912
if {[OptIsPrg $item]} {
913
append res [OptTree $item $nl $tl $dl];
915
set dv [OptTypeArgs $item];
916
if {[OptState $item] != "header"} {
919
append res [format "\n %-*s %-*s %-*s %s" \
920
$nl [OptName $item] $tl [OptType $item] \
921
$dl $dv [OptHelp $item]]
927
# Give nice usage string
928
proc ::tcl::OptError {prefix desc {header 0}} {
931
# add faked instruction
932
set h [list [OptNewInst header Var/FlagName Type Value Help]];
933
lappend h [OptNewInst header ------------ ---- ----- ----];
934
lappend h [OptNewInst header {( -help} "" "" {gives this help )}]
935
set desc [concat $h $desc]
937
OptLengths $desc nl tl dl
939
return "$prefix[OptTree $desc $nl $tl $dl]"
943
################ General Utility functions #######################
946
# List utility functions
948
# "Lvarxxx" take the list VARiable name as argument
949
# "Lxxxx" take the list value as argument
950
# (which is not costly with Tcl8 objects system
951
# as it's still a reference and not a copy of the values)
954
# Is that list empty ?
955
proc ::tcl::Lempty {list} {
956
expr {[llength $list]==0}
959
# Gets the value of one leaf of a lists tree
960
proc ::tcl::Lget {list indexLst} {
961
if {[llength $indexLst] <= 1} {
962
return [lindex $list $indexLst];
964
Lget [lindex $list [Lfirst $indexLst]] [Lrest $indexLst];
966
# Sets the value of one leaf of a lists tree
967
# (we use the version that does not create the elements because
968
# it would be even slower... needs to be written in C !)
969
# (nb: there is a non trivial recursive problem with indexes 0,
970
# which appear because there is no difference between a list
971
# of 1 element and 1 element alone : [list "a"] == "a" while
972
# it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
973
# and [listp "a b"] maybe 0. listp does not exist either...)
974
proc ::tcl::Lvarset {listName indexLst newValue} {
975
upvar $listName list;
976
if {[llength $indexLst] <= 1} {
977
Lvarset1nc list $indexLst $newValue;
979
set idx [Lfirst $indexLst];
980
set targetList [lindex $list $idx];
981
# reduce refcount on targetList (not really usefull now,
982
# could be with optimizing compiler)
983
# Lvarset1 list $idx {};
984
# recursively replace in targetList
985
Lvarset targetList [Lrest $indexLst] $newValue;
986
# put updated sub list back in the tree
987
Lvarset1nc list $idx $targetList;
990
# Set one cell to a value, eventually create all the needed elements
991
# (on level-1 of lists)
992
variable emptyList {}
993
proc ::tcl::Lvarset1 {listName index newValue} {
994
upvar $listName list;
995
if {$index < 0} {return -code error "invalid negative index"}
996
set lg [llength $list];
999
for {set i $lg} {$i<$index} {incr i} {
1000
lappend list $emptyList;
1002
lappend list $newValue;
1004
set list [lreplace $list $index $index $newValue];
1007
# same as Lvarset1 but no bound checking / creation
1008
proc ::tcl::Lvarset1nc {listName index newValue} {
1009
upvar $listName list;
1010
set list [lreplace $list $index $index $newValue];
1012
# Increments the value of one leaf of a lists tree
1013
# (which must exists)
1014
proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
1015
upvar $listName list;
1016
if {[llength $indexLst] <= 1} {
1017
Lvarincr1 list $indexLst $howMuch;
1019
set idx [Lfirst $indexLst];
1020
set targetList [lindex $list $idx];
1021
# reduce refcount on targetList
1022
Lvarset1nc list $idx {};
1023
# recursively replace in targetList
1024
Lvarincr targetList [Lrest $indexLst] $howMuch;
1025
# put updated sub list back in the tree
1026
Lvarset1nc list $idx $targetList;
1029
# Increments the value of one cell of a list
1030
proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
1031
upvar $listName list;
1032
set newValue [expr [lindex $list $index]+$howMuch];
1033
set list [lreplace $list $index $index $newValue];
1036
# Returns the first element of a list
1037
proc ::tcl::Lfirst {list} {
1040
# Returns the rest of the list minus first element
1041
proc ::tcl::Lrest {list} {
1044
# Removes the first element of a list
1045
proc ::tcl::Lvarpop {listName} {
1046
upvar $listName list;
1047
set list [lrange $list 1 end];
1049
# Same but returns the removed element
1050
proc ::tcl::Lvarpop2 {listName} {
1051
upvar $listName list;
1052
set el [Lfirst $list];
1053
set list [lrange $list 1 end];
1056
# Assign list elements to variables and return the length of the list
1057
proc ::tcl::Lassign {list args} {
1058
# faster than direct blown foreach (which does not byte compile)
1060
set lg [llength $list];
1061
foreach vname $args {
1063
uplevel [list set $vname [lindex $list $i]];
1071
# Set the varname to value if value is greater than varname's current value
1072
# or if varname is undefined
1073
proc ::tcl::SetMax {varname value} {
1074
upvar 1 $varname var
1075
if {![info exists var] || $value > $var} {
1080
# Set the varname to value if value is smaller than varname's current value
1081
# or if varname is undefined
1082
proc ::tcl::SetMin {varname value} {
1083
upvar 1 $varname var
1084
if {![info exists var] || $value < $var} {
1090
# everything loaded fine, lets create the test proc:
1092
# Don't need the create temp proc anymore:
1093
rename OptCreateTestProc {}
added
removed
lib/tcl/opt0.1/optparse.tcl
