Index: tls.tcl
==================================================================
--- tls.tcl
+++ tls.tcl
@@ -15,10 +15,118 @@
# 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
@@ -44,92 +152,67 @@
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
- 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}
- }
+ variable socketOptionsNoServer
+ variable socketOptionsServer
+ variable socketOptionsSwitchBody
+
+ tls::_initsocketoptions
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\""
- }
-
- # 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
+ set options $socketOptionsNoServer
+ }
# Combine defaults with current options
set args [concat $defaults $args]
set argc [llength $args]
@@ -137,11 +220,11 @@
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
+ switch -glob -- $server,$arg $socketOptionsSwitchBody
}
if {$server} {
if {($idx + 1) != $argc} {
return -code error $usage