blob: c34baf6d9842ff15326f2698517bbdc3044c2b41 (
plain)
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
|
package provide opt_parser 0.1
namespace eval opt_parser {
# list of option vars (keys are long option names)
variable optlist
# option behavior <set|lappend>
variable optbehavior
variable optprefix {-}
}
proc opt_parser::init {optdata} {
variable optlist
variable optbehavior
array unset optlist ; array set optlist {}
array unset optbehavior ; array set optbehavior {}
foreach item $optdata {
foreach {optName behavior varlist} $item {
if {[llength $varlist] < 1 || [lsearch -exact {set lappend} $behavior] == -1} {
return -code error "usage: init { {optname <set|lappend> {var1 var2 ...}} ... }"
}
set optlist($optName) $varlist
set optbehavior($optName) $behavior
}
}
}
proc opt_parser::get_options {argv {opts {}}} {
# second argument are internal options
# (like 'ignore_unknown_flags <0|1>')
foreach {k v} $opts {set $k $v}
set ignore_unknown_flags 0
variable optlist
variable optbehavior
variable optprefix
# zero all the options 1st var
foreach optName [array names optlist] {
uplevel [list set [lindex $optlist($optName) 0] 0]
if {$optbehavior($optName) == {lappend}} {
for {set i 1} {$i < [llength $optlist($optName)]} {incr i} {
uplevel [list set [lindex $optlist($optName) $i] [list]]
}
}
}
# here will be appended non-options arguments
set residualArgs {}
set argc [llength $argv]
for {set i 0} {$i < $argc} {} {
# get i-th arg
set optName [lindex $argv $i]
incr i
# if it's not an option, stop here, and add to residualArgs
if {![regexp ^$optprefix $optName]} {
lappend residualArgs $optName
continue
}
if {[info exists optlist($optName)]} {
set varlist $optlist($optName)
uplevel [list set [lindex $optlist($optName) 0] 1]
set n_required_opt_args [expr {-1+[llength $varlist]}]
set j 1
while {$n_required_opt_args > 0} {
incr n_required_opt_args -1
if {$i >= $argc} {
return -code error "not enough arguments for option $optName"
}
uplevel [list $optbehavior($optName) [lindex $varlist $j] [lindex $argv $i]]
incr j
incr i
}
} else {
if {$ignore_unknown_flags} {
lappend residualArgs $argv_i
continue
} else {
return -code error "unknown option: $optName"
}
}
}
return $residualArgs
}
|
