Check-in [98b60c41b6]

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]