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
|
# cmdline.tcl --
#
# This package provides a utility for parsing command line
# arguments that are processed by our various applications.
# It also includes a utility routine to determine the
# application name for use in command line errors.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2001-2015 by Andreas Kupries <andreas_kupries@users.sf.net>.
# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com>
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $
package require Tcl 8.2
package provide cmdline 1.5
namespace eval ::cmdline {
namespace export getArgv0 getopt getKnownOpt getfiles getoptions \
getKnownOptions usage
}
# ::cmdline::getopt --
#
# The cmdline::getopt works in a fashion like the standard
# C based getopt function. Given an option string and a
# pointer to an array or args this command will process the
# first argument and return info on how to proceed.
#
# Arguments:
# argvVar Name of the argv list that you
# want to process. If options are found the
# arg list is modified and the processed arguments
# are removed from the start of the list.
# optstring A list of command options that the application
# will accept. If the option ends in ".arg" the
# getopt routine will use the next argument as
# an argument to the option. Otherwise the option
# is a boolean that is set to 1 if present.
# optVar The variable pointed to by optVar
# contains the option that was found (without the
# leading '-' and without the .arg extension).
# valVar Upon success, the variable pointed to by valVar
# contains the value for the specified option.
# This value comes from the command line for .arg
# options, otherwise the value is 1.
# If getopt fails, the valVar is filled with an
# error message.
#
# Results:
# The getopt function returns 1 if an option was found, 0 if no more
# options were found, and -1 if an error occurred.
proc ::cmdline::getopt {argvVar optstring optVar valVar} {
upvar 1 $argvVar argsList
upvar 1 $optVar option
upvar 1 $valVar value
set result [getKnownOpt argsList $optstring option value]
if {$result < 0} {
# Collapse unknown-option error into any-other-error result.
set result -1
}
return $result
}
# ::cmdline::getKnownOpt --
#
# The cmdline::getKnownOpt works in a fashion like the standard
# C based getopt function. Given an option string and a
# pointer to an array or args this command will process the
# first argument and return info on how to proceed.
#
# Arguments:
# argvVar Name of the argv list that you
# want to process. If options are found the
# arg list is modified and the processed arguments
# are removed from the start of the list. Note that
# unknown options and the args that follow them are
# left in this list.
# optstring A list of command options that the application
# will accept. If the option ends in ".arg" the
# getopt routine will use the next argument as
# an argument to the option. Otherwise the option
# is a boolean that is set to 1 if present.
# optVar The variable pointed to by optVar
# contains the option that was found (without the
# leading '-' and without the .arg extension).
# valVar Upon success, the variable pointed to by valVar
# contains the value for the specified option.
# This value comes from the command line for .arg
# options, otherwise the value is 1.
# If getopt fails, the valVar is filled with an
# error message.
#
# Results:
# The getKnownOpt function returns 1 if an option was found,
# 0 if no more options were found, -1 if an unknown option was
# encountered, and -2 if any other error occurred.
proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} {
upvar 1 $argvVar argsList
upvar 1 $optVar option
upvar 1 $valVar value
# default settings for a normal return
set value ""
set option ""
set result 0
# check if we're past the end of the args list
if {[llength $argsList] != 0} {
# if we got -- or an option that doesn't begin with -, return (skipping
# the --). otherwise process the option arg.
switch -glob -- [set arg [lindex $argsList 0]] {
"--" {
set argsList [lrange $argsList 1 end]
}
"--*" -
"-*" {
set option [string range $arg 1 end]
if {[string equal [string range $option 0 0] "-"]} {
set option [string range $arg 2 end]
}
# support for format: [-]-option=value
set idx [string first "=" $option 1]
if {$idx != -1} {
set _val [string range $option [expr {$idx+1}] end]
set option [string range $option 0 [expr {$idx-1}]]
}
if {[lsearch -exact $optstring $option] != -1} {
# Booleans are set to 1 when present
set value 1
set result 1
set argsList [lrange $argsList 1 end]
} elseif {[lsearch -exact $optstring "$option.arg"] != -1} {
set result 1
set argsList [lrange $argsList 1 end]
if {[info exists _val]} {
set value $_val
} elseif {[llength $argsList]} {
set value [lindex $argsList 0]
set argsList [lrange $argsList 1 end]
} else {
set value "Option \"$option\" requires an argument"
set result -2
}
} else {
# Unknown option.
set value "Illegal option \"-$option\""
set result -1
}
}
default {
# Skip ahead
}
}
}
return $result
}
# ::cmdline::getoptions --
#
# Process a set of command line options, filling in defaults
# for those not specified. This also generates an error message
# that lists the allowed flags if an incorrect flag is specified.
#
# Arguments:
# arglistVar The name of the argument list, typically argv.
# We remove all known options and their args from it.
# optlist A list-of-lists where each element specifies an option
# in the form:
# (where flag takes no argument)
# flag comment
#
# (or where flag takes an argument)
# flag default comment
#
# If flag ends in ".arg" then the value is taken from the
# command line. Otherwise it is a boolean and appears in
# the result if present on the command line. If flag ends
# in ".secret", it will not be displayed in the usage.
# usage Text to include in the usage display. Defaults to
# "options:"
#
# Results
# Name value pairs suitable for using with array set.
proc ::cmdline::getoptions {arglistVar optlist {usage options:}} {
upvar 1 $arglistVar argv
set opts [GetOptionDefaults $optlist result]
set argc [llength $argv]
while {[set err [getopt argv $opts opt arg]]} {
if {$err < 0} {
set result(?) ""
break
}
set result($opt) $arg
}
if {[info exist result(?)] || [info exists result(help)]} {
Error [usage $optlist $usage] USAGE
}
return [array get result]
}
# ::cmdline::getKnownOptions --
#
# Process a set of command line options, filling in defaults
# for those not specified. This ignores unknown flags, but generates
# an error message that lists the correct usage if a known option
# is used incorrectly.
#
# Arguments:
# arglistVar The name of the argument list, typically argv. This
# We remove all known options and their args from it.
# optlist A list-of-lists where each element specifies an option
# in the form:
# flag default comment
# If flag ends in ".arg" then the value is taken from the
# command line. Otherwise it is a boolean and appears in
# the result if present on the command line. If flag ends
# in ".secret", it will not be displayed in the usage.
# usage Text to include in the usage display. Defaults to
# "options:"
#
# Results
# Name value pairs suitable for using with array set.
proc ::cmdline::getKnownOptions {arglistVar optlist {usage options:}} {
upvar 1 $arglistVar argv
set opts [GetOptionDefaults $optlist result]
# As we encounter them, keep the unknown options and their
# arguments in this list. Before we return from this procedure,
# we'll prepend these args to the argList so that the application
# doesn't lose them.
set unknownOptions [list]
set argc [llength $argv]
while {[set err [getKnownOpt argv $opts opt arg]]} {
if {$err == -1} {
# Unknown option.
# Skip over any non-option items that follow it.
# For now, add them to the list of unknownOptions.
lappend unknownOptions [lindex $argv 0]
set argv [lrange $argv 1 end]
while {([llength $argv] != 0) \
&& ![string match "-*" [lindex $argv 0]]} {
lappend unknownOptions [lindex $argv 0]
set argv [lrange $argv 1 end]
}
} elseif {$err == -2} {
set result(?) ""
break
} else {
set result($opt) $arg
}
}
# Before returning, prepend the any unknown args back onto the
# argList so that the application doesn't lose them.
set argv [concat $unknownOptions $argv]
if {[info exist result(?)] || [info exists result(help)]} {
Error [usage $optlist $usage] USAGE
}
return [array get result]
}
# ::cmdline::GetOptionDefaults --
#
# This internal procedure processes the option list (that was passed to
# the getopt or getKnownOpt procedure). The defaultArray gets an index
# for each option in the option list, the value of which is the option's
# default value.
#
# Arguments:
# optlist A list-of-lists where each element specifies an option
# in the form:
# flag default comment
# If flag ends in ".arg" then the value is taken from the
# command line. Otherwise it is a boolean and appears in
# the result if present on the command line. If flag ends
# in ".secret", it will not be displayed in the usage.
# defaultArrayVar The name of the array in which to put argument defaults.
#
# Results
# Name value pairs suitable for using with array set.
proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} {
upvar 1 $defaultArrayVar result
set opts {? help}
foreach opt $optlist {
set name [lindex $opt 0]
if {[regsub -- {\.secret$} $name {} name] == 1} {
# Need to hide this from the usage display and getopt
}
lappend opts $name
if {[regsub -- {\.arg$} $name {} name] == 1} {
# Set defaults for those that take values.
set default [lindex $opt 1]
set result($name) $default
} else {
# The default for booleans is false
set result($name) 0
}
}
return $opts
}
# ::cmdline::usage --
#
# Generate an error message that lists the allowed flags.
#
# Arguments:
# optlist As for cmdline::getoptions
# usage Text to include in the usage display. Defaults to
# "options:"
#
# Results
# A formatted usage message
proc ::cmdline::usage {optlist {usage {options:}}} {
set str "[getArgv0] $usage\n"
foreach opt [concat $optlist \
{{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] {
set name [lindex $opt 0]
if {[regsub -- {\.secret$} $name {} name] == 1} {
# Hidden option
continue
}
if {[regsub -- {\.arg$} $name {} name] == 1} {
set default [lindex $opt 1]
set comment [lindex $opt 2]
append str [format " %-20s %s <%s>\n" "-$name value" \
$comment $default]
} else {
set comment [lindex $opt 1]
append str [format " %-20s %s\n" "-$name" $comment]
}
}
return $str
}
# ::cmdline::getfiles --
#
# Given a list of file arguments from the command line, compute
# the set of valid files. On windows, file globbing is performed
# on each argument. On Unix, only file existence is tested. If
# a file argument produces no valid files, a warning is optionally
# generated.
#
# This code also uses the full path for each file. If not
# given it prepends [pwd] to the filename. This ensures that
# these files will never conflict with files in our zip file.
#
# Arguments:
# patterns The file patterns specified by the user.
# quiet If this flag is set, no warnings will be generated.
#
# Results:
# Returns the list of files that match the input patterns.
proc ::cmdline::getfiles {patterns quiet} {
set result {}
if {$::tcl_platform(platform) == "windows"} {
foreach pattern $patterns {
set pat [file join $pattern]
set files [glob -nocomplain -- $pat]
if {$files == {}} {
if {! $quiet} {
puts stdout "warning: no files match \"$pattern\""
}
} else {
foreach file $files {
lappend result $file
}
}
}
} else {
set result $patterns
}
set files {}
foreach file $result {
# Make file an absolute path so that we will never conflict
# with files that might be contained in our zip file.
set fullPath [file join [pwd] $file]
if {[file isfile $fullPath]} {
lappend files $fullPath
} elseif {! $quiet} {
puts stdout "warning: no files match \"$file\""
}
}
return $files
}
# ::cmdline::getArgv0 --
#
# This command returns the "sanitized" version of argv0. It will strip
# off the leading path and remove the ".bin" extensions that our apps
# use because they must be wrapped by a shell script.
#
# Arguments:
# None.
#
# Results:
# The application name that can be used in error messages.
proc ::cmdline::getArgv0 {} {
global argv0
set name [file tail $argv0]
return [file rootname $name]
}
##
# ### ### ### ######### ######### #########
##
# Now the typed versions of the above commands.
##
# ### ### ### ######### ######### #########
##
# typedCmdline.tcl --
#
# This package provides a utility for parsing typed command
# line arguments that may be processed by various applications.
#
# Copyright (c) 2000 by Ross Palmer Mohn.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $
namespace eval ::cmdline {
namespace export typedGetopt typedGetoptions typedUsage
# variable cmdline::charclasses --
#
# Create regexp list of allowable character classes
# from "string is" error message.
#
# Results:
# String of character class names separated by "|" characters.
variable charclasses
#checker exclude badKey
catch {string is . .} charclasses
variable dummy
regexp -- {must be (.+)$} $charclasses dummy charclasses
regsub -all -- {, (or )?} $charclasses {|} charclasses
unset dummy
}
# ::cmdline::typedGetopt --
#
# The cmdline::typedGetopt works in a fashion like the standard
# C based getopt function. Given an option string and a
# pointer to a list of args this command will process the
# first argument and return info on how to proceed. In addition,
# you may specify a type for the argument to each option.
#
# Arguments:
# argvVar Name of the argv list that you want to process.
# If options are found, the arg list is modified
# and the processed arguments are removed from the
# start of the list.
#
# optstring A list of command options that the application
# will accept. If the option ends in ".xxx", where
# xxx is any valid character class to the tcl
# command "string is", then typedGetopt routine will
# use the next argument as a typed argument to the
# option. The argument must match the specified
# character classes (e.g. integer, double, boolean,
# xdigit, etc.). Alternatively, you may specify
# ".arg" for an untyped argument.
#
# optVar Upon success, the variable pointed to by optVar
# contains the option that was found (without the
# leading '-' and without the .xxx extension). If
# typedGetopt fails the variable is set to the empty
# string. SOMETIMES! Different for each -value!
#
# argVar Upon success, the variable pointed to by argVar
# contains the argument for the specified option.
# If typedGetopt fails, the variable is filled with
# an error message.
#
# Argument type syntax:
# Option that takes no argument.
# foo
#
# Option that takes a typeless argument.
# foo.arg
#
# Option that takes a typed argument. Allowable types are all
# valid character classes to the tcl command "string is".
# Currently must be one of alnum, alpha, ascii, control,
# boolean, digit, double, false, graph, integer, lower, print,
# punct, space, true, upper, wordchar, or xdigit.
# foo.double
#
# Option that takes an argument from a list.
# foo.(bar|blat)
#
# Argument quantifier syntax:
# Option that takes an optional argument.
# foo.arg?
#
# Option that takes a list of arguments terminated by "--".
# foo.arg+
#
# Option that takes an optional list of arguments terminated by "--".
# foo.arg*
#
# Argument quantifiers work on all argument types, so, for
# example, the following is a valid option specification.
# foo.(bar|blat|blah)?
#
# Argument syntax miscellany:
# Options may be specified on the command line using a unique,
# shortened version of the option name. Given that program foo
# has an option list of {bar.alpha blah.arg blat.double},
# "foo -b fob" returns an error, but "foo -ba fob"
# successfully returns {bar fob}
#
# Results:
# The typedGetopt function returns one of the following:
# 1 a valid option was found
# 0 no more options found to process
# -1 invalid option
# -2 missing argument to a valid option
# -3 argument to a valid option does not match type
#
# Known Bugs:
# When using options which include special glob characters,
# you must use the exact option. Abbreviating it can cause
# an error in the "cmdline::prefixSearch" procedure.
proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} {
variable charclasses
upvar $argvVar argsList
upvar $optVar retvar
upvar $argVar optarg
# default settings for a normal return
set optarg ""
set retvar ""
set retval 0
# check if we're past the end of the args list
if {[llength $argsList] != 0} {
# if we got -- or an option that doesn't begin with -, return (skipping
# the --). otherwise process the option arg.
switch -glob -- [set arg [lindex $argsList 0]] {
"--" {
set argsList [lrange $argsList 1 end]
}
"-*" {
# Create list of options without their argument extensions
set optstr ""
foreach str $optstring {
lappend optstr [file rootname $str]
}
set _opt [string range $arg 1 end]
set i [prefixSearch $optstr [file rootname $_opt]]
if {$i != -1} {
set opt [lindex $optstring $i]
set quantifier "none"
if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} {
set opt [string range $opt 0 end-1]
}
if {[string first . $opt] == -1} {
set retval 1
set retvar $opt
set argsList [lrange $argsList 1 end]
} elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass]
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
if {[string equal arg $charclass]} {
set type arg
} elseif {[regexp -- "^($charclasses)\$" $charclass]} {
set type class
} else {
set type oneof
}
set argsList [lrange $argsList 1 end]
set opt [file rootname $opt]
while {1} {
if {[llength $argsList] == 0
|| [string equal "--" [lindex $argsList 0]]} {
if {[string equal "--" [lindex $argsList 0]]} {
set argsList [lrange $argsList 1 end]
}
set oneof ""
if {$type == "arg"} {
set charclass an
} elseif {$type == "oneof"} {
set oneof ", one of $charclass"
set charclass an
}
if {$quantifier == "?"} {
set retval 1
set retvar $opt
set optarg ""
} elseif {$quantifier == "+"} {
set retvar $opt
if {[llength $optarg] < 1} {
set retval -2
set optarg "Option requires at least one $charclass argument$oneof -- $opt"
} else {
set retval 1
}
} elseif {$quantifier == "*"} {
set retval 1
set retvar $opt
} else {
set optarg "Option requires $charclass argument$oneof -- $opt"
set retvar $opt
set retval -2
}
set quantifier ""
} elseif {($type == "arg")
|| (($type == "oneof")
&& [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1)
|| (($type == "class")
&& [string is $charclass [lindex $argsList 0]])} {
set retval 1
set retvar $opt
lappend optarg [lindex $argsList 0]
set argsList [lrange $argsList 1 end]
} else {
set oneof ""
if {$type == "arg"} {
set charclass an
} elseif {$type == "oneof"} {
set oneof ", one of $charclass"
set charclass an
}
set optarg "Option requires $charclass argument$oneof -- $opt"
set retvar $opt
set retval -3
if {$quantifier == "?"} {
set retval 1
set optarg ""
}
set quantifier ""
}
if {![regexp -- {[+*]} $quantifier]} {
break;
}
}
} else {
Error \
"Illegal option type specification: must be one of $charclasses" \
BAD OPTION TYPE
}
} else {
set optarg "Illegal option -- $_opt"
set retvar $_opt
set retval -1
}
}
default {
# Skip ahead
}
}
}
return $retval
}
# ::cmdline::typedGetoptions --
#
# Process a set of command line options, filling in defaults
# for those not specified. This also generates an error message
# that lists the allowed options if an incorrect option is
# specified.
#
# Arguments:
# arglistVar The name of the argument list, typically argv
# optlist A list-of-lists where each element specifies an option
# in the form:
#
# option default comment
#
# Options formatting is as described for the optstring
# argument of typedGetopt. Default is for optionally
# specifying a default value. Comment is for optionally
# specifying a comment for the usage display. The
# options "--", "-help", and "-?" are automatically included
# in optlist.
#
# Argument syntax miscellany:
# Options formatting and syntax is as described in typedGetopt.
# There are two additional suffixes that may be applied when
# passing options to typedGetoptions.
#
# You may add ".multi" as a suffix to any option. For options
# that take an argument, this means that the option may be used
# more than once on the command line and that each additional
# argument will be appended to a list, which is then returned
# to the application.
# foo.double.multi
#
# If a non-argument option is specified as ".multi", it is
# toggled on and off for each time it is used on the command
# line.
# foo.multi
#
# If an option specification does not contain the ".multi"
# suffix, it is not an error to use an option more than once.
# In this case, the behavior for options with arguments is that
# the last argument is the one that will be returned. For
# options that do not take arguments, using them more than once
# has no additional effect.
#
# Options may also be hidden from the usage display by
# appending the suffix ".secret" to any option specification.
# Please note that the ".secret" suffix must be the last suffix,
# after any argument type specification and ".multi" suffix.
# foo.xdigit.multi.secret
#
# Results
# Name value pairs suitable for using with array set.
proc ::cmdline::typedGetoptions {arglistVar optlist {usage options:}} {
variable charclasses
upvar 1 $arglistVar argv
set opts {? help}
foreach opt $optlist {
set name [lindex $opt 0]
if {[regsub -- {\.secret$} $name {} name] == 1} {
# Remove this extension before passing to typedGetopt.
}
if {[regsub -- {\.multi$} $name {} name] == 1} {
# Remove this extension before passing to typedGetopt.
regsub -- {\..*$} $name {} temp
set multi($temp) 1
}
lappend opts $name
if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} {
# Set defaults for those that take values.
# Booleans are set just by being present, or not
set dflt [lindex $opt 1]
if {$dflt != {}} {
set defaults($name) $dflt
}
}
}
set argc [llength $argv]
while {[set err [typedGetopt argv $opts opt arg]]} {
if {$err == 1} {
if {[info exists result($opt)]
&& [info exists multi($opt)]} {
# Toggle boolean options or append new arguments
if {$arg == ""} {
unset result($opt)
} else {
set result($opt) "$result($opt) $arg"
}
} else {
set result($opt) "$arg"
}
} elseif {($err == -1) || ($err == -3)} {
Error [typedUsage $optlist $usage] USAGE
} elseif {$err == -2 && ![info exists defaults($opt)]} {
Error [typedUsage $optlist $usage] USAGE
}
}
if {[info exists result(?)] || [info exists result(help)]} {
Error [typedUsage $optlist $usage] USAGE
}
foreach {opt dflt} [array get defaults] {
if {![info exists result($opt)]} {
set result($opt) $dflt
}
}
return [array get result]
}
# ::cmdline::typedUsage --
#
# Generate an error message that lists the allowed flags,
# type of argument taken (if any), default value (if any),
# and an optional description.
#
# Arguments:
# optlist As for cmdline::typedGetoptions
#
# Results
# A formatted usage message
proc ::cmdline::typedUsage {optlist {usage {options:}}} {
variable charclasses
set str "[getArgv0] $usage\n"
foreach opt [concat $optlist \
{{help "Print this message"} {? "Print this message"}}] {
set name [lindex $opt 0]
if {[regsub -- {\.secret$} $name {} name] == 1} {
# Hidden option
} else {
if {[regsub -- {\.multi$} $name {} name] == 1} {
# Display something about multiple options
}
if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass]
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
regsub -- "\\..+\$" $name {} name
set comment [lindex $opt 2]
set default "<[lindex $opt 1]>"
if {$default == "<>"} {
set default ""
}
append str [format " %-20s %s %s\n" "-$name $charclass" \
$comment $default]
} else {
set comment [lindex $opt 1]
append str [format " %-20s %s\n" "-$name" $comment]
}
}
}
return $str
}
# ::cmdline::prefixSearch --
#
# Search a Tcl list for a pattern; searches first for an exact match,
# and if that fails, for a unique prefix that matches the pattern
# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*"
#
# Arguments:
# list list of words
# pattern word to search for
#
# Results:
# Index of found word is returned. If no exact match or
# unique short version is found then -1 is returned.
proc ::cmdline::prefixSearch {list pattern} {
# Check for an exact match
if {[set pos [::lsearch -exact $list $pattern]] > -1} {
return $pos
}
# Check for a unique short version
set slist [lsort $list]
if {[set pos [::lsearch -glob $slist $pattern*]] > -1} {
# What if there is nothing for the check variable?
set check [lindex $slist [expr {$pos + 1}]]
if {[string first $pattern $check] != 0} {
return [::lsearch -exact $list [lindex $slist $pos]]
}
}
return -1
}
# ::cmdline::Error --
#
# Internal helper to throw errors with a proper error-code attached.
#
# Arguments:
# message text of the error message to throw.
# args additional parts of the error code to use,
# with CMDLINE as basic prefix added by this command.
#
# Results:
# An error is thrown, always.
proc ::cmdline::Error {message args} {
return -code error -errorcode [linsert $args 0 CMDLINE] $message
}
|