1# UserLand Validator methods 2# The TclSOAP package provides an implementation of the UserLand 3# SOAP interoperability methods. This procedure provides the client side 4# for these methods. Either see validator.soapware.org or the notes in each 5# of the implementation files in the TclSOAP/cgi-bin/soap directory. 6# 7 8package require SOAP 9package require XMLRPC 10package require SOAP::http 11package require base64 12 13package require rpcvar 14namespace import -force rpcvar::* 15 16set help { 17 Call 'validator_soap_clients url' or 'validator_xmlrpc_clients url' to 18 define the methods for a given endpoint URL. 19 20 Call 'validate_soap url' or 'validate_xmlrpc url' to run the test suite 21 against an endpoint. 22} 23 24# The types for the nested type test... 25typedef { 26 larry int 27 curly int 28 moe int 29} Stooges 30 31typedef { 32 day01 Stooges 33 day02 Stooges 34 day03 Stooges 35} month 36 37typedef { 38 month03 month 39 month04 month 40} year 41 42typedef { 43 year2000 year 44} myStruct 45 46typedef { 47 substruct0 Stooges 48 substruct1 Stooges 49 substruct2 Stooges 50 substruct3 Stooges 51 substruct4 Stooges 52} StoogeSet 53 54# The XMLRPC nestedStructTest method uses different member names. Bah. 55typedef {01 Stooges 02 Stooges 03 Stooges} XMonth 56typedef {03 Xmonth 04 Xmonth} XYear 57typedef {2000 XYear} XMyStruct 58 59proc validator_soap_clients {{proxy http://localhost/cgi-bin/rpc}} { 60 SOAP::create countTheEntities \ 61 -proxy $proxy -params {s string} 62 SOAP::create easyStructTest \ 63 -proxy $proxy -params {stooges struct} 64 SOAP::create echoStructTest \ 65 -proxy $proxy -params {myStruct StoogeSet} 66 SOAP::create manyTypesTest \ 67 -proxy $proxy \ 68 -params {num int bool boolean state int doub double \ 69 dat timeInstant bin string} 70 SOAP::create moderateSizeArrayCheck \ 71 -proxy $proxy -params {myArray array} 72 SOAP::create nestedStructTest \ 73 -proxy $proxy -params {myStruct myStruct} 74 SOAP::create simpleStructReturnTest \ 75 -proxy $proxy -params {myNumber int} 76 SOAP::create whichToolkit \ 77 -uri http://www.soapware.org/ \ 78 -proxy $proxy -params {} 79} 80 81proc validator_xmlrpc_clients {{proxy http://localhost/cgi-bin/rpc}} { 82 XMLRPC::create countTheEntities \ 83 -name validator1.countTheEntities \ 84 -proxy $proxy -params {s string} 85 XMLRPC::create easyStructTest \ 86 -name validator1.easyStructTest \ 87 -proxy $proxy -params {stooges struct} 88 XMLRPC::create echoStructTest \ 89 -name validator1.echoStructTest \ 90 -proxy $proxy -params {myStruct StoogeSet} 91 XMLRPC::create manyTypesTest \ 92 -name validator1.manyTypesTest \ 93 -proxy $proxy \ 94 -params {num int bool boolean state int doub double \ 95 dat string bin string} 96 XMLRPC::create moderateSizeArrayCheck \ 97 -name validator1.moderateSizeArrayCheck\ 98 -proxy $proxy -params {myArray array} 99 XMLRPC::create arrayOfStructsTest \ 100 -name validator1.arrayOfStructsTest \ 101 -proxy $proxy -params {myArray Stooges()} 102 XMLRPC::create nestedStructTest \ 103 -name validator1.nestedStructTest \ 104 -proxy $proxy -params {myStruct XMyStruct} 105 XMLRPC::create simpleStructReturnTest \ 106 -name validator1.simpleStructReturnTest \ 107 -proxy $proxy -params {myNumber int} 108 XMLRPC::create whichToolkit \ 109 -name validator1.whichToolkit \ 110 -proxy $proxy -params {} 111} 112 113# ------------------------------------------------------------------------- 114 115proc validate_soap {{proxy http://localhost/cgi-bin/rpc}} { 116 validator_soap_clients $proxy 117 validate_protocol 118 catch {validate.nestedStructTest} msg ; puts "$msg" 119} 120 121proc validate_xmlrpc {{proxy http://localhost/cgi-bin/rpc}} { 122 validator_xmlrpc_clients $proxy 123 validate_protocol 124 catch {validate.arrayOfStructsTest} msg ; puts "$msg" 125 catch {validate.xnestedStructTest} msg ; puts "$msg" 126} 127 128proc validate_protocol {} { 129 catch {validate.countTheEntities} msg ; puts "$msg" 130 catch {validate.easyStructTest} msg ; puts "$msg" 131 catch {validate.moderateSizeArrayCheck} msg ; puts "$msg" 132 catch {validate.simpleStructReturnTest} msg ; puts "$msg" 133 catch {validate.echoStructTest} msg ; puts "$msg" 134 catch {validate.manyTypesTest} msg ; puts "$msg" 135} 136 137# ------------------------------------------------------------------------- 138# Helper methods used in generating data for the requests. 139 140# Get a random integer between -100 and +100 141proc randVal {} { 142 return [expr int(rand() * 200 - 100)] 143} 144 145# Create a struct list with three named elements and three random int values. 146proc stoogeStruct {} { 147 return [list larry [randVal] curly [randVal] moe [randVal]] 148} 149 150# ------------------------------------------------------------------------- 151 152proc validate.countTheEntities {} { 153 array set ents [countTheEntities {<""><&><'><}] 154 155 if {$ents(ctQuotes) != 2} { 156 error "ctQuotes is incorrect" 157 } 158 if {$ents(ctLeftAngleBrackets) != 4} { 159 error "ctLeftAngleBrackets is incorrent" 160 } 161 if {$ents(ctAmpersands) != 1} { 162 error "ctAmpersands is incorrect" 163 } 164 if {$ents(ctApostrophes) != 1} { 165 error "ctApostrophes is incorrent" 166 } 167 if {$ents(ctRightAngleBrackets) != 3} { 168 error "ctRightAngleBrackets is incorrent" 169 } 170 return "countTheEntities" 171} 172 173proc validate.easyStructTest {} { 174 array set stooges [stoogeStruct] 175 set check [expr $stooges(larry) + $stooges(curly) + $stooges(moe)] 176 177 set r [easyStructTest [array get stooges]] 178 if {$r != $check} { 179 error "easyStructTest failed: $r != $check" 180 } 181 return "easyStructTest" 182} 183 184proc validate.echoStructTest {} { 185 set q [list \ 186 substruct0 [stoogeStruct] \ 187 substruct1 [stoogeStruct] \ 188 substruct2 [stoogeStruct] \ 189 substruct3 [stoogeStruct] \ 190 substruct4 [stoogeStruct] ] 191 set r [echoStructTest $q] 192 if {[llength $q] != [llength $r]} { 193 error "echoStructTest failed: list lengths differ" 194 } 195 196 array set aq $q 197 array set ar $r 198 199 foreach substruct [array names aq] { 200 if {[llength $ar($substruct)] != [llength $aq($substruct)]} { 201 error "echoStructTest failed: $substruct lengths differ" 202 } 203 array set asq $aq($substruct) 204 array set asr $ar($substruct) 205 foreach stooge [array names asq] { 206 if {$asq($stooge) != $asr($stooge)} { 207 error "echoStructTest failed: $substruct.$stooge\ 208 $asq($stooge) != $asr($stooge)" 209 } 210 } 211 } 212 return "echoStructTest" 213} 214 215proc validate.manyTypesTest {} { 216 set i [randVal] 217 set b 1 ;#true 218 set st [expr int(rand() * 48) + 1] 219 set dbl [expr rand() * 200] 220 set secs [clock seconds] 221 set date [clock format $secs -format {%Y-%m-%dT%H:%M:%S}] 222 set bin [base64::encode [string repeat "HelloWorld!" 24]] 223 set r [manyTypesTest $i $b $st $dbl $date $bin] 224 225 if {[lindex $r 0] != $i} {error "manyTypesTest failed int"} 226 if {[lindex $r 1] && ! $b} {error "failed bool: [lindex $r 1] != $b"} 227 if {[lindex $r 2] != $st} {error "manyTypesTest failed state"} 228 if {! [expr [lindex $r 3] == $dbl]} {error "manyTypesTest failed double"} 229 set rsecs [clock scan [string range \ 230 [string map {- {}} [lindex $r 4]] \ 231 0 16]] 232 if {$rsecs != $secs} { 233 error "manyTypesTest failed date: [lindex $r 4] != $date" 234 } 235 if {[lindex $r 5] != $bin} {error "manyTypesTest failed bin"} 236 return "manyTypesTest" 237} 238 239proc validate.moderateSizeArrayCheck {} { 240 for {set n 12} {$n != 0} {incr n -1} { 241 lappend q [randVal] 242 } 243 set check "[lindex $q 0][lindex $q end]" 244 set r [moderateSizeArrayCheck $q] 245 if {! [string match $check $r]} { 246 error "moderateSizeArrayCheck failed: $check != $r"} 247 return "moderateSizeArrayCheck" 248} 249 250proc validate.simpleStructReturnTest {} { 251 set q [randVal] 252 array set r [simpleStructReturnTest $q] 253 if {$r(times10) != [expr $q * 10]} { 254 error "simpleStructReturnTest: $q * 10 is not $r(times10)" 255 } 256 if {$r(times100) != [expr $q * 100]} { 257 error "simpleStructReturnTest: $q * 100 is not $r(times100)" 258 } 259 if {$r(times1000) != [expr $q * 1000]} { 260 error "simpleStructReturnTest: $q * 1000 is not $r(times1000)" 261 } 262 return "simpleStructReturnTest" 263} 264 265proc validate.arrayOfStructsTest {} { 266 set max [expr int(rand() * 10) + 2] 267 set check 0 268 for {set n 0} {$n < $max} {incr n} { 269 array set s [stoogeStruct] 270 lappend arr [array get s] 271 incr check $s(curly) 272 } 273 set r [arrayOfStructsTest $arr] 274 if {$r != $check} { 275 error "arrayOfStructsTest failed: $r != $check" 276 } 277 return "arrayOfStructTest" 278} 279 280proc validate.nestedStructTest {} { 281 282 array set s [stoogeStruct] 283 set check [expr $s(larry) + $s(moe) + $s(curly)] 284 set q [list \ 285 year2000 [list \ 286 month03 [list \ 287 day01 [stoogeStruct] \ 288 day02 [stoogeStruct] \ 289 day03 [stoogeStruct]] \ 290 month04 [list \ 291 day01 [array get s] \ 292 day02 [stoogeStruct] \ 293 day03 [stoogeStruct]]]] 294 295 set r [nestedStructTest $q] 296 if {$r != $check} { error "nestedStructTest failed" } 297 return "nestedStructTest" 298} 299 300# Pestilentially the XMLRPC validator doesn't use the same member names 301# as the SOAP validator for this method. 302proc validate.xnestedStructTest {} { 303 304 array set s [stoogeStruct] 305 set check [expr $s(larry) + $s(moe) + $s(curly)] 306 set q [list \ 307 2000 [list \ 308 04 [list \ 309 01 [array get s] \ 310 ] \ 311 ] \ 312 ] 313 314 set r [nestedStructTest $q] 315 if {$r != $check} { error "nestedStructTest failed" } 316 return "nestedStructTest" 317} 318 319# ------------------------------------------------------------------------- 320 321if {$tcl_interactive} { 322 puts $help 323} 324 325