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