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
|
}
#
# Helper function - behaves exactly as the native socket command.
#
proc tls::socket {args} {
variable socketCmd
variable defaults
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 "-cadir, -cafile, -certfile, -cipher, -command, -dhparams, -keyfile, -myaddr, -password, -request, -require, -servername, -ssl2, -ssl3, -tls1, -tls1.1 or -tls1.2"
set options "-async, -cadir, -cafile, -certfile, -cipher, -command, -dhparams, -keyfile, -myaddr, -myport, -password, -request, -require, -servername, -ssl2, -ssl3, -tls1, -tls1.1 or -tls1.2"
}
set iopts [concat [list -server $server] $defaults] ;# Import options
for {set idx 0} {$idx < $argc} {incr idx} {
set arg [lindex $args $idx]
switch -glob -- $server,$arg {
0,-async {lappend sopts $arg}
0,-myport -
*,-type -
*,-myaddr {lappend sopts $arg [lindex $args [incr idx]]}
*,-cadir -
*,-cafile -
*,-certfile -
*,-cipher -
*,-command -
*,-dhparams -
*,-keyfile -
*,-password -
*,-request -
*,-require -
*,-servername -
*,-ssl2 -
*,-ssl3 -
*,-tls1 -
*,-tls1.1 -
*,-tls1.2 {lappend iopts $arg [lindex $args [incr idx]]}
-* {return -code error "bad option \"$arg\": must be one of $options"}
default {break}
}
}
if {$server} {
if {($idx + 1) != $argc} {
return -code error $usage
}
set uid [incr ::tls::srvuid]
set port [lindex $args [expr {$argc-1}]]
lappend sopts $port
#set sopts [linsert $sopts 0 -server $callback]
set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
#set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
} else {
if {($idx + 2) != $argc} {
return -code error $usage
}
set host [lindex $args [expr {$argc-2}]]
set port [lindex $args [expr {$argc-1}]]
lappend sopts $host $port
}
#
# Create TCP/IP socket
#
set chan [eval $socketCmd $sopts]
if {!$server && [catch {
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
<
>
|
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
>
>
>
>
>
>
>
>
>
>
|
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
|
}
#
# Helper function - behaves exactly as the native socket command.
#
proc tls::socket {args} {
variable socketCmd
variable defaults
# server,option,variable,args
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}
}
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\""
} else {
set server 0
set usage "wrong # args: should be \"tls::socket ?options? host port\""
}
# 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
# Combine defaults with current options
set args [concat $defaults $args]
set argc [llength $args]
set sopts {}
set iopts [list -server $server]
array set argsArray [list]
for {set idx 0} {$idx < $argc} {incr idx} {
set arg [lindex $args $idx]
switch -glob -- $server,$arg $argSwitchBody
}
if {$server} {
if {($idx + 1) != $argc} {
return -code error $usage
}
set uid [incr ::tls::srvuid]
set port [lindex $args [expr {$argc-1}]]
lappend sopts $port
#set sopts [linsert $sopts 0 -server $callback]
set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
#set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
} else {
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]
if {!$server && [catch {
|