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
|
# Maps UID to Server Socket
variable srvmap
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}
{* -alpn iopts 1}
{* -cadir iopts 1}
{* -cafile iopts 1}
{* -castore iopts 1}
{* -cert iopts 1}
{* -certfile iopts 1}
{* -cipher iopts 1}
{* -ciphersuites iopts 1}
{* -command iopts 1}
{* -dhparams iopts 1}
{* -key iopts 1}
{* -keyfile iopts 1}
{* -password iopts 1}
{* -post_handshake iopts 1}
{* -request iopts 1}
{* -require iopts 1}
{* -securitylevel iopts 1}
{* -autoservername discardOpts 1}
{* -server iopts 1}
{* -servername iopts 1}
{* -session_id iopts 1}
{* -ssl2 iopts 1}
{* -ssl3 iopts 1}
{* -tls1 iopts 1}
{* -tls1.1 iopts 1}
{* -tls1.2 iopts 1}
{* -tls1.3 iopts 1}
{* -validatecommand iopts 1}
{* -vcmd 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 "\"$arg\" option must be followed by value"
}
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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
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
|
# Maps UID to Server Socket
variable srvmap
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}
{* -alpn iopts 1}
{* -cadir iopts 1}
{* -cafile iopts 1}
{* -castore iopts 1}
{* -cert iopts 1}
{* -certfile iopts 1}
{* -cipher iopts 1}
{* -ciphersuites iopts 1}
{* -command iopts 1}
{* -dhparams iopts 1}
{* -key iopts 1}
{* -keyfile iopts 1}
{* -password iopts 1}
{* -post_handshake iopts 1}
{* -request iopts 1}
{* -require iopts 1}
{* -securitylevel iopts 1}
{* -autoservername discardOpts 1}
{* -server iopts 1}
{* -servername iopts 1}
{* -session_id iopts 1}
{* -ssl2 iopts 1}
{* -ssl3 iopts 1}
{* -tls1 iopts 1}
{* -tls1.1 iopts 1}
{* -tls1.2 iopts 1}
{* -tls1.3 iopts 1}
{* -validatecommand iopts 1}
{* -vcmd 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 "\"$arg\" option must be followed by value"
}
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
|
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
|
set idx [lsearch $args -server]
if {$idx != -1} {
set server 1
set callback [lindex $args [expr {$idx+1}]]
set args [lreplace $args $idx [expr {$idx+1}]]
set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
set options $socketOptionsServer
} else {
set server 0
set usage "wrong # args: should be \"tls::socket ?options? host port\""
set options $socketOptionsNoServer
}
# Combine defaults with current options
set args [concat $defaults $args]
set argc [llength $args]
set sopts {}
|
|
|
|
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
|
set idx [lsearch $args -server]
if {$idx != -1} {
set server 1
set callback [lindex $args [expr {$idx+1}]]
set args [lreplace $args $idx [expr {$idx+1}]]
set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
set options $socketOptionsServer
} else {
set server 0
set usage "wrong # args: should be \"tls::socket ?options? host port\""
set options $socketOptionsNoServer
}
# Combine defaults with current options
set args [concat $defaults $args]
set argc [llength $args]
set sopts {}
|
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
|
if {($idx + 2) != $argc} {
return -code error $usage
}
set host [lindex $args [expr {$argc-2}]]
set port [lindex $args [expr {$argc-1}]]
# If an "-autoservername" option is found, honor it
if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} {
if {![info exists argsArray(-servername)]} {
set argsArray(-servername) $host
lappend iopts -servername $host
}
}
lappend sopts $host $port
}
#
# Create TCP/IP socket
#
set chan [eval $socketCmd $sopts]
|
|
|
|
|
|
|
|
|
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
|
if {($idx + 2) != $argc} {
return -code error $usage
}
set host [lindex $args [expr {$argc-2}]]
set port [lindex $args [expr {$argc-1}]]
# If an "-autoservername" option is found, honor it
if {[info exists argsArray(-autoservername)] && $argsArray(-autoservername)} {
if {![info exists argsArray(-servername)]} {
set argsArray(-servername) $host
lappend iopts -servername $host
}
}
lappend sopts $host $port
}
#
# Create TCP/IP socket
#
set chan [eval $socketCmd $sopts]
|