Check-in [98b60c41b6]
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 on 2016-12-14 14:07:51
Other Links: branch diff | manifest | tags
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

Modified tls.tcl from [845877fe79] to [0371a07398].

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}
    variable socketOptionsSwitchBody
        {* -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}
    }

    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 options $socketOptionsNoServer
    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
	switch -glob -- $server,$arg $socketOptionsSwitchBody
    }

    if {$server} {
	if {($idx + 1) != $argc} {
	    return -code error $usage
	}
	set uid [incr ::tls::srvuid]