Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Consolidated rules for parsing options and now verify them in tls::init as well |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | feature-0d4541b86d-autoservername |
| Files: | files | file ages | folders |
| SHA1: | 98b60c41b6a1d93e4473fbc5219f47db00e2f010 |
| User & Date: | rkeene 2016-12-14 14:07:51 |
Context
|
2016-12-14
| ||
| 16:03 | Updated error message to be consistent with "lsearch" output under similar failures check-in: 4e441206d6 user: rkeene tags: feature-0d4541b86d-autoservername | |
| 14:07 | Consolidated rules for parsing options and now verify them in tls::init as well check-in: 98b60c41b6 user: rkeene tags: feature-0d4541b86d-autoservername | |
| 06:27 | Updated example to include "-autoservername" check-in: 219e71c672 user: rkeene tags: feature-0d4541b86d-autoservername | |
Changes
Changes to tls.tcl.
13 13 variable srvuid 0 14 14 15 15 # Over-ride this if you are using a different socket command 16 16 variable socketCmd 17 17 if {![info exists socketCmd]} { 18 18 set socketCmd [info command ::socket] 19 19 } 20 + 21 + # This is the possible arguments to tls::socket and tls::init 22 + # The format of this is a list of lists 23 + ## Each inner list contains the following elements 24 + ### Server (matched against "string match" for 0/1) 25 + ### Option name 26 + ### Variable to add the option to: 27 + #### sopts: [socket] option 28 + #### iopts: [tls::import] option 29 + ### How many arguments the following the option to consume 30 + variable socketOptionRules { 31 + {0 -async sopts 0} 32 + {* -myaddr sopts 1} 33 + {0 -myport sopts 1} 34 + {* -type sopts 1} 35 + {* -cadir iopts 1} 36 + {* -cafile iopts 1} 37 + {* -certfile iopts 1} 38 + {* -cipher iopts 1} 39 + {* -command iopts 1} 40 + {* -dhparams iopts 1} 41 + {* -keyfile iopts 1} 42 + {* -password iopts 1} 43 + {* -request iopts 1} 44 + {* -require iopts 1} 45 + {* -autoservername discardOpts 1} 46 + {* -servername iopts 1} 47 + {* -ssl2 iopts 1} 48 + {* -ssl3 iopts 1} 49 + {* -tls1 iopts 1} 50 + {* -tls1.1 iopts 1} 51 + {* -tls1.2 iopts 1} 52 + } 53 + 54 + # tls::socket and tls::init options as a humane readable string 55 + variable socketOptionsNoServer 56 + variable socketOptionsServer 57 + 58 + # Internal [switch] body to validate options 59 + variable socketOptionsSwitchBody 60 +} 61 + 62 +proc tls::_initsocketoptions {} { 63 + variable socketOptionRules 64 + variable socketOptionsNoServer 65 + variable socketOptionsServer 66 + variable socketOptionsSwitchBody 67 + 68 + # Do not re-run if we have already been initialized 69 + if {[info exists socketOptionsSwitchBody]} { 70 + return 71 + } 72 + 73 + # Create several structures from our list of options 74 + ## 1. options: a text representation of the valid options for the current 75 + ## server type 76 + ## 2. argSwitchBody: Switch body for processing arguments 77 + set options(0) [list] 78 + set options(1) [list] 79 + set argSwitchBody [list] 80 + foreach optionRule $socketOptionRules { 81 + set ruleServer [lindex $optionRule 0] 82 + set ruleOption [lindex $optionRule 1] 83 + set ruleVarToUpdate [lindex $optionRule 2] 84 + set ruleVarArgsToConsume [lindex $optionRule 3] 85 + 86 + foreach server [list 0 1] { 87 + if {![string match $ruleServer $server]} { 88 + continue 89 + } 90 + 91 + lappend options($server) $ruleOption 92 + } 93 + 94 + switch -- $ruleVarArgsToConsume { 95 + 0 { 96 + set argToExecute { 97 + lappend @VAR@ $arg 98 + set argsArray($arg) true 99 + } 100 + } 101 + 1 { 102 + set argToExecute { 103 + incr idx 104 + if {$idx >= [llength $args]} { 105 + return -code error "incorrect usage: $arg requires an argument" 106 + } 107 + set argValue [lindex $args $idx] 108 + lappend @VAR@ $arg $argValue 109 + set argsArray($arg) $argValue 110 + } 111 + } 112 + default { 113 + return -code error "Internal argument construction error" 114 + } 115 + } 116 + 117 + lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute] 118 + } 119 + 120 + # Add in the final options 121 + lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"} 122 + lappend argSwitchBody default break 123 + 124 + # Set the final variables 125 + set socketOptionsNoServer [join $options(0) {, }] 126 + set socketOptionsServer [join $options(1) {, }] 127 + set socketOptionsSwitchBody $argSwitchBody 20 128 } 21 129 22 130 proc tls::initlib {dir dll} { 23 131 # Package index cd's into the package directory for loading. 24 132 # Irrelevant to unixoids, but for Windows this enables the OS to find 25 133 # the dependent DLL's in the CWD, where they may be. 26 134 set cwd [pwd] ................................................................................ 42 150 catch {cd $cwd} 43 151 if {$res} { 44 152 namespace eval [namespace parent] {namespace delete tls} 45 153 return -code $res $err 46 154 } 47 155 rename tls::initlib {} 48 156 } 157 + 49 158 50 159 # 51 160 # Backwards compatibility, also used to set the default 52 161 # context options 53 162 # 54 163 proc tls::init {args} { 55 164 variable defaults 165 + variable socketOptionsNoServer 166 + variable socketOptionsServer 167 + variable socketOptionsSwitchBody 56 168 57 - set defaults $args 169 + tls::_initsocketoptions 170 + 171 + # Technically a third option should be used here: Options that are valid 172 + # only a both servers and non-servers 173 + set server -1 174 + set options $socketOptionsServer 175 + 176 + # Validate arguments passed 177 + set initialArgs $args 178 + set argc [llength $args] 179 + 180 + array set argsArray [list] 181 + for {set idx 0} {$idx < $argc} {incr idx} { 182 + set arg [lindex $args $idx] 183 + switch -glob -- $server,$arg $socketOptionsSwitchBody 184 + } 185 + 186 + set defaults $initialArgs 58 187 } 59 188 # 60 189 # Helper function - behaves exactly as the native socket command. 61 190 # 62 191 proc tls::socket {args} { 63 192 variable socketCmd 64 193 variable defaults 194 + variable socketOptionsNoServer 195 + variable socketOptionsServer 196 + variable socketOptionsSwitchBody 65 197 66 - # server,option,variable,args 67 - set usageRules { 68 - {0 -async sopts 0} 69 - {* -myaddr sopts 1} 70 - {0 -myport sopts 1} 71 - {* -type sopts 1} 72 - {* -cadir iopts 1} 73 - {* -cafile iopts 1} 74 - {* -certfile iopts 1} 75 - {* -cipher iopts 1} 76 - {* -command iopts 1} 77 - {* -dhparams iopts 1} 78 - {* -keyfile iopts 1} 79 - {* -password iopts 1} 80 - {* -request iopts 1} 81 - {* -require iopts 1} 82 - {0 -autoservername discardOpts 1} 83 - {* -servername iopts 1} 84 - {* -ssl2 iopts 1} 85 - {* -ssl3 iopts 1} 86 - {* -tls1 iopts 1} 87 - {* -tls1.1 iopts 1} 88 - {* -tls1.2 iopts 1} 89 - } 198 + tls::_initsocketoptions 90 199 91 200 set idx [lsearch $args -server] 92 201 if {$idx != -1} { 93 202 set server 1 94 203 set callback [lindex $args [expr {$idx+1}]] 95 204 set args [lreplace $args $idx [expr {$idx+1}]] 96 205 97 206 set usage "wrong # args: should be \"tls::socket -server command ?options? port\"" 207 + set options $socketOptionsServer 98 208 } else { 99 209 set server 0 100 210 101 211 set usage "wrong # args: should be \"tls::socket ?options? host port\"" 212 + set options $socketOptionsNoServer 102 213 } 103 214 104 - # Create several structures from our list of options 105 - ## 1. options: a text representation of the valid options for the current 106 - ## server type 107 - ## 2. argSwitchBody: Switch body for processing arguments 108 - set options [list] 109 - set argSwitchBody [list] 110 - foreach usageRule $usageRules { 111 - set ruleServer [lindex $usageRule 0] 112 - set ruleOption [lindex $usageRule 1] 113 - set ruleVarToUpdate [lindex $usageRule 2] 114 - set ruleVarArgsToConsume [lindex $usageRule 3] 115 - 116 - if {![string match $ruleServer $server]} { 117 - continue 118 - } 119 - 120 - lappend options $ruleOption 121 - switch -- $ruleVarArgsToConsume { 122 - 0 { set argToExecute {lappend @VAR@ $arg; set argsArray($arg) true} } 123 - 1 { set argToExecute {set argValue [lindex $args [incr idx]]; lappend @VAR@ $arg $argValue; set argsArray($arg) $argValue} } 124 - default { return -code error "Internal argument construction error" } 125 - } 126 - lappend argSwitchBody $ruleServer,$ruleOption [string map [list @VAR@ $ruleVarToUpdate] $argToExecute] 127 - } 128 - set options [join $options {, }] 129 - lappend argSwitchBody {*,-*} {return -code error "bad option \"$arg\": must be one of $options"} 130 - lappend argSwitchBody default break 131 - 132 215 # Combine defaults with current options 133 216 set args [concat $defaults $args] 134 217 135 218 set argc [llength $args] 136 219 set sopts {} 137 220 set iopts [list -server $server] 138 221 139 222 array set argsArray [list] 140 223 for {set idx 0} {$idx < $argc} {incr idx} { 141 224 set arg [lindex $args $idx] 142 - switch -glob -- $server,$arg $argSwitchBody 225 + switch -glob -- $server,$arg $socketOptionsSwitchBody 143 226 } 144 227 145 228 if {$server} { 146 229 if {($idx + 1) != $argc} { 147 230 return -code error $usage 148 231 } 149 232 set uid [incr ::tls::srvuid]