13
14
15
16
17
18
19
20
21
22
23
24
25
26
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
variable srvuid 0
# Over-ride this if you are using a different socket command
variable socketCmd
if {![info exists socketCmd]} {
set socketCmd [info command ::socket]
}
# This is the possible arguments to tls::socket and tls::init
# The format of this is a list of lists
## Each inner list contains the following elements
### Server (matched against "string match" for 0/1)
### Option name
### Variable to add the option to:
#### sopts: [socket] option
#### iopts: [tls::import] option
### How many arguments the following the option to consume
variable socketOptionRules {
{0 -async sopts 0}
{* -myaddr sopts 1}
{0 -myport sopts 1}
{* -type sopts 1}
{* -cadir iopts 1}
{* -cafile iopts 1}
{* -certfile iopts 1}
{* -cipher iopts 1}
{* -command iopts 1}
{* -dhparams iopts 1}
{* -keyfile iopts 1}
{* -password iopts 1}
{* -request iopts 1}
{* -require iopts 1}
{* -autoservername discardOpts 1}
{* -servername iopts 1}
{* -ssl2 iopts 1}
{* -ssl3 iopts 1}
{* -tls1 iopts 1}
{* -tls1.1 iopts 1}
{* -tls1.2 iopts 1}
}
# tls::socket and tls::init options as a humane readable string
variable socketOptionsNoServer
variable socketOptionsServer
# Internal [switch] body to validate options
variable socketOptionsSwitchBody
}
proc tls::_initsocketoptions {} {
variable socketOptionRules
variable socketOptionsNoServer
variable socketOptionsServer
variable socketOptionsSwitchBody
# Do not re-run if we have already been initialized
if {[info exists socketOptionsSwitchBody]} {
return
}
# Create several structures from our list of options
## 1. options: a text representation of the valid options for the current
## server type
## 2. argSwitchBody: Switch body for processing arguments
set options(0) [list]
set options(1) [list]
set argSwitchBody [list]
foreach optionRule $socketOptionRules {
set ruleServer [lindex $optionRule 0]
set ruleOption [lindex $optionRule 1]
set ruleVarToUpdate [lindex $optionRule 2]
set ruleVarArgsToConsume [lindex $optionRule 3]
foreach server [list 0 1] {
if {![string match $ruleServer $server]} {
continue
}
lappend options($server) $ruleOption
}
switch -- $ruleVarArgsToConsume {
0 {
set argToExecute {
lappend @VAR@ $arg
set argsArray($arg) true
}
}
1 {
set argToExecute {
incr idx
if {$idx >= [llength $args]} {
return -code error "incorrect usage: $arg requires an argument"
}
set argValue [lindex $args $idx]
lappend @VAR@ $arg $argValue
set argsArray($arg) $argValue
}
}
default {
return -code error "Internal argument construction error"
}
}
lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute]
}
# Add in the final options
lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
lappend argSwitchBody default break
# Set the final variables
set socketOptionsNoServer [join $options(0) {, }]
set socketOptionsServer [join $options(1) {, }]
set socketOptionsSwitchBody $argSwitchBody
}
proc tls::initlib {dir dll} {
# Package index cd's into the package directory for loading.
# Irrelevant to unixoids, but for Windows this enables the OS to find
# the dependent DLL's in the CWD, where they may be.
set cwd [pwd]
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
+
+
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
|
catch {cd $cwd}
if {$res} {
namespace eval [namespace parent] {namespace delete tls}
return -code $res $err
}
rename tls::initlib {}
}
#
# Backwards compatibility, also used to set the default
# context options
#
proc tls::init {args} {
variable defaults
variable socketOptionsNoServer
variable socketOptionsServer
variable socketOptionsSwitchBody
tls::_initsocketoptions
# Technically a third option should be used here: Options that are valid
# only a both servers and non-servers
set server -1
set options $socketOptionsServer
# Validate arguments passed
set initialArgs $args
set argc [llength $args]
array set argsArray [list]
for {set idx 0} {$idx < $argc} {incr idx} {
set arg [lindex $args $idx]
switch -glob -- $server,$arg $socketOptionsSwitchBody
}
set defaults $args
set defaults $initialArgs
}
#
# Helper function - behaves exactly as the native socket command.
#
proc tls::socket {args} {
variable socketCmd
variable defaults
# server,option,variable,args
variable socketOptionsNoServer
variable socketOptionsServer
set usageRules {
{0 -async sopts 0}
{* -myaddr sopts 1}
{0 -myport sopts 1}
{* -type sopts 1}
{* -cadir iopts 1}
{* -cafile iopts 1}
{* -certfile iopts 1}
{* -cipher iopts 1}
{* -command iopts 1}
{* -dhparams iopts 1}
{* -keyfile iopts 1}
{* -password iopts 1}
{* -request iopts 1}
{* -require iopts 1}
{0 -autoservername discardOpts 1}
{* -servername iopts 1}
{* -ssl2 iopts 1}
{* -ssl3 iopts 1}
{* -tls1 iopts 1}
{* -tls1.1 iopts 1}
{* -tls1.2 iopts 1}
}
}
# Create several structures from our list of options
## 1. options: a text representation of the valid options for the current
## server type
## 2. argSwitchBody: Switch body for processing arguments
set options [list]
set argSwitchBody [list]
foreach usageRule $usageRules {
set ruleServer [lindex $usageRule 0]
set ruleOption [lindex $usageRule 1]
set ruleVarToUpdate [lindex $usageRule 2]
set ruleVarArgsToConsume [lindex $usageRule 3]
if {![string match $ruleServer $server]} {
continue
}
lappend options $ruleOption
switch -- $ruleVarArgsToConsume {
0 { set argToExecute {lappend @VAR@ $arg; set argsArray($arg) true} }
1 { set argToExecute {set argValue [lindex $args [incr idx]]; lappend @VAR@ $arg $argValue; set argsArray($arg) $argValue} }
default { return -code error "Internal argument construction error" }
}
lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute]
}
set options [join $options {, }]
lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"}
lappend argSwitchBody default break
switch -glob -- $server,$arg $argSwitchBody
switch -glob -- $server,$arg $socketOptionsSwitchBody
}
if {$server} {
if {($idx + 1) != $argc} {
return -code error $usage
}
set uid [incr ::tls::srvuid]
|