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
|
--- foxTypedOpts.tcl.orig Sat Feb 19 19:46:50 1994
+++ foxTypedOpts.tcl Thu Mar 18 16:15:13 1999
@@ -80,9 +80,8 @@
# typedopts several times with different <arg-list>s without losing the
# information from previous calls.
#
-# if typedopts can't parse its options for any reason, it will print an
-# error message to stderr and return a -1 without modifying any other
-# variables.
+# if typedopts can't parse its options for any reason, it return an
+# error message without modifying any other variables.
#
# EXAMPLE:
#
@@ -157,8 +156,7 @@
# Initial revision
#
-proc typedopts { args } {
-
+namespace eval foxOpts {
proc abbr { s1 s2 } {
if { [ set len [ string length $s1 ]] } then {
if { ! [ string compare $s1 [ string range $s2 0 [ expr $len - 1 ]]] } then {
@@ -298,8 +296,7 @@
return 1
}
default {
- puts stderr "Eek! Option type <$otype> not supported yet!"
- set var "isn't a supported type."
+ set var "<$otype> isn't a supported type."
return 0
}
}
@@ -315,54 +312,52 @@
"floats" -
"strings" {
if { [ llength $optlist ] } then {
- puts stderr "typedopts: Type $type doesn't take arguments"
- return ""
+ return -code error "typedopts: Type $type doesn't take arguments"
}
return [ string index $type 0 ]
}
"one-of" {
if { ! [ llength $optlist ] } then {
- puts stderr "typedopts: No arguments given to type $type"
- return ""
+ return -code error "typedopts: No arguments given to type $type"
}
return [ concat [ string index $type 0 ] $optlist ]
}
"list-of" -
"multiple" {
if { ! [ llength $optlist ] } then {
- puts stderr "typedopts: No arguments given to type $type"
- return ""
- }
- if { ! [ string length [ set subtype [ parseOption $optlist ]]] } then {
- return ""
+ return -code error "typedopts: No arguments given to type $type"
}
+ if [catch {parseOption $optlist} subtype] {
+ return -code error $subtype
+ }
return [ concat [ string index $type 0 ] $subtype ]
}
default {
- puts stderr "typedopts: Unknown option type $type"
- return ""
+ return -code error "typedopts: Unknown option type $type"
}
}
}
+}
+
+proc typedopts { args } {
set doinit 1
if { [ llength $args ] < 5 } then {
- puts stderr "typedopts: bad number of arguments."
- return -1
+ return -code error "typedopts: bad number of arguments."
}
- set args [ extract $args arglist optlist optret argret restret ]
+ set args [ foxOpts::extract $args arglist optlist optret argret restret ]
while { [ llength $args ] } {
- set opt [ shift args ]
- switch -exact [ findabbr { -noinitialize } $opt ] {
+ set opt [ foxOpts::shift args ]
+ switch -exact [ foxOpts::findabbr { -noinitialize } $opt ] {
-noinitialize {
set doinit 0
}
default {
- puts stderr "typedopts: bad option \"$opt\": should be -noinitialize or --"
- return -1
+ return -code error \
+ "typedopts: bad option \"$opt\": should be -noinitialize or --"
}
}
}
@@ -380,16 +375,15 @@
if { [ string length $type ] } then {
foreach arg $word {
if { [ lsearch -exact $arg $allopts ] > -1 } then {
- puts stderr "typedopts: option -$arg multiply declared."
- return -1
+ return -code error "typedopts: option -$arg multiply declared."
}
lappend allopts $arg
set opttype($arg) $type
}
set type ""
} else {
- if { ! [ string length [ set type [ parseOption $word ]]] } then {
- return -1
+ if [catch {foxOpts::parseOption $word} type] then {
+ return -code error $type
}
}
}
@@ -408,7 +402,7 @@
while { [ llength $arglist ] } {
switch -glob -- $arglist {
-- {
- shift arglist
+ foxOpts::shift arglist
break
}
-* {
@@ -417,10 +411,10 @@
break
}
}
- set opt [ string range [ shift arglist ] 1 end ]
- if { [ string length [ set fnd [ findabbr $allopts $opt ]]] } then {
+ set opt [ string range [ foxOpts::shift arglist ] 1 end ]
+ if { [ string length [set fnd [foxOpts::findabbr $allopts $opt]]] } then {
set type $opttype($fnd)
- if { [ parseOptionType $opttype($fnd) arglist arg ] } then {
+ if { [ foxOpts::parseOptionType $opttype($fnd) arglist arg ] } then {
if { $_opts($fnd) && ! [ string match "m*" $type ] } then {
set _args(_ERROR_) "Found multiple occurrences of option -$fnd"
set retval 0
|
