1# soapinterop.tcl - Copyright (C) 2001 Pat Thoyts <Pat.Thoyts@bigfoot.com> 2# 3# Client implementation of the SOAP Interoperability lab Round 1 Test Suite 4# and Round 2 Proposal A. 5# 6# If you live behind a firewall and have an authenticating proxy web server 7# try executing SOAP::proxyconfig and filling in the fields. This sets 8# up the SOAP package to send the correct headers for the proxy to 9# forward the packets (provided it is using the `Basic' encoding scheme). 10# 11# ------------------------------------------------------------------------- 12# This software is distributed in the hope that it will be useful, but 13# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 14# or FITNESS FOR A PARTICULAR PURPOSE. See the accompanying file `LICENSE' 15# for more details. 16# ------------------------------------------------------------------------- 17# 18# @(#)$Id: soapinterop.tcl,v 1.6 2002/02/26 23:50:13 patthoyts Exp $ 19 20package provide soapinterop::base 1.0 21 22package require SOAP 23package require XMLRPC 24package require rpcvar 25package require SOAP::http 26 27namespace eval soapinterop { 28 variable uri "http://soapinterop.org/" 29 variable action "http://soapinterop.org/" 30 31 namespace export rand_string rand_int rand_float 32 33 rpcvar::typedef -namespace http://soapinterop.org/xsd { \ 34 varString string \ 35 varInt int \ 36 varFloat float} SOAPStruct 37 38} 39 40# ------------------------------------------------------------------------- 41# round 1 and the round 2 base tests are the same apart from the SOAPAction 42# ------------------------------------------------------------------------- 43 44proc soapinterop::round1 {{proxy {}}} { 45 set soapinterop::action urn:soapinterop 46 return [validate:base $proxy] 47} 48 49proc soapinterop::round2 {{proxy {}}} { 50 set soapinterop::action http://soapinterop.org/ 51 return [validate:base $proxy] 52} 53 54# ---------------------------------------------------------------------- 55 56proc soapinterop::create:base {proxy args} { 57 variable uri 58 variable action 59 60 SOAP::create echoString -proxy $proxy -uri $uri -action $action \ 61 -params {inputString string} 62 SOAP::create echoInteger -proxy $proxy -uri $uri -action $action \ 63 -params {inputInteger int} 64 SOAP::create echoFloat -proxy $proxy -uri $uri -action $action \ 65 -params {inputFloat float} 66 SOAP::create echoStruct -proxy $proxy -uri $uri -action $action \ 67 -params {inputStruct SOAPStruct} 68 69 SOAP::create echoStringArray -proxy $proxy -uri $uri -action $action \ 70 -params {inputStringArray string()} 71 SOAP::create echoIntegerArray -proxy $proxy -uri $uri -action $action \ 72 -params {inputIntegerArray int()} 73 SOAP::create echoFloatArray -proxy $proxy -uri $uri -action $action \ 74 -params {inputFloatArray float()} 75 SOAP::create echoStructArray -proxy $proxy -uri $uri -action $action \ 76 -params {inputStructArray SOAPStruct()} 77 78 SOAP::create echoBase64 -proxy $proxy -uri $uri -action $action \ 79 -params {inputBase64 base64} 80 SOAP::create echoDate -proxy $proxy -uri $uri -action $action \ 81 -params {inputDate timeInstant} 82 SOAP::create echoVoid -proxy $proxy -uri $uri -action $action \ 83 -params {} 84 85 if {$args != {}} { 86 foreach method [list echoVoid echoDate echoBase64 \ 87 echoString echoInteger echoFloat echoStruct \ 88 echoStringArray echoIntegerArray echoFloatArray \ 89 echoStructArray] { 90 eval SOAP::configure $method $args 91 } 92 } 93} 94 95proc soapinterop::validate:base {proxy args} { 96 set soapinterop::action urn:soapinterop 97 98 if {$proxy != {}} { 99 eval create:base [list $proxy] $args 100 } 101 102 catch {validate.echoVoid} msg ; puts "$msg" 103 catch {validate.echoDate} msg ; puts "$msg" 104 catch {validate.echoBase64} msg ; puts "$msg" 105 catch {validate.echoInteger} msg ; puts "$msg" 106 catch {validate.echoFloat} msg ; puts "$msg" 107 catch {validate.echoString} msg ; puts "$msg" 108 catch {validate.echoIntegerArray} msg; puts "$msg" 109 catch {validate.echoFloatArray} msg ; puts "$msg" 110 catch {validate.echoStringArray} msg ; puts "$msg" 111 catch {validate.echoStruct} msg ; puts "$msg" 112 catch {validate.echoStructArray} msg ; puts "$msg" 113} 114 115# ------------------------------------------------------------------------- 116# Helper methods 117# ------------------------------------------------------------------------- 118 119proc soapinterop::rand_float {} { 120 set r [expr rand() * 200 - 100] 121 set p [string first . $r] 122 incr p 4 123 return [string range $r 0 $p] 124} 125 126proc soapinterop::rand_int {} { 127 return [expr int(rand() * 200 - 100) ] 128} 129 130proc soapinterop::rand_string {} { 131 set cmds [info commands] 132 set ndx [expr int(rand() * [llength $cmds])] 133 return [lindex $cmds $ndx] 134} 135 136proc soapinterop::float=? {lhs rhs {dp 4}} { 137 set lhs [format %0.${dp}f $lhs] 138 set rhs [format %0.${dp}f $rhs] 139 return [expr {$lhs == $rhs}] 140} 141 142proc soapinterop::list=? {lhs rhs} { 143 if {[llength $lhs] != [llength $rhs]} { 144 return false 145 } 146 for {set n 0} {$n < $max} {incr n} { 147 if {[lindex $q $n] != [lindex $r $n]} { 148 return false 149 } 150 } 151 return true 152} 153 154# ------------------------------------------------------------------------- 155# Round 1 and Round 2 Base Tests 156# ------------------------------------------------------------------------- 157 158proc soapinterop::validate.echoVoid {} { 159 set r [echoVoid] 160 if {$r != {}} { error "echoVoid failed" } 161 return "echoVoid" 162} 163 164proc soapinterop::validate.echoDate {} { 165 set d [clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%S}] 166 set r [echoDate $d] 167 if {! [string match "$d*" $r]} { 168 error "echoDate failed: $d != $r" 169 } 170 return "echoDate" 171} 172 173proc soapinterop::validate.echoBase64 {} { 174 package require base64 175 set check [array get ::tcl_platform] 176 set q [join [base64::encode $check] {}] 177 set result [echoBase64 $q] 178 set r [base64::decode $result] 179 if {![string match $check $r]} { 180 error "echoBase64 failed: strings do not match" 181 } 182 return "echoBase64" 183} 184 185proc soapinterop::validate.echoInteger {} { 186 set i [rand_int] 187 set r [echoInteger $i] 188 if {$i != $r} { error "echoInteger failed: $i != $r" } 189 return "echoInteger" 190} 191 192# Tend to loose some decimal places. Check to ?? dp ?? 193proc soapinterop::validate.echoFloat {} { 194 set f [rand_float] 195 set r [echoFloat $f] 196 if {! [float=? $f $r]} { 197 error "echoFloat failed: $f != $r" 198 } 199 return "echoFloat" 200} 201 202proc soapinterop::validate.echoString {} { 203 set s [array get ::tcl_platform] 204 set r [echoString $s] 205 if {! [string match $s $r]} { 206 error "echoString failed simple string test: $s != $r" 207 } 208 return "echoString" 209} 210 211proc soapinterop::validate.echoIntegerArray {} { 212 set max [expr int(rand() * 19 + 2)] 213 for {set n 0} {$n < $max} {incr n} { 214 lappend q [rand_int] 215 } 216 set r [echoIntegerArray $q] 217 if {[llength $r] != [llength $q]} { 218 error "echoIntegerArray failed: lists are different: $q != $r" 219 } 220 for {set n 0} {$n < $max} {incr n} { 221 if {[lindex $q $n] != [lindex $r $n]} { 222 error "echoIntegerArray failed: element $n is different: $q != $r" 223 } 224 } 225 return "echoIntegerArray" 226} 227 228proc soapinterop::validate.echoFloatArray {} { 229 set max [expr int(rand() * 19 + 2)] 230 for {set n 0} {$n < $max} {incr n} { 231 lappend q [rand_float] 232 } 233 set r [echoFloatArray $q] 234 if {[llength $r] != [llength $q]} { 235 error "echoFloatArray failed: lists are different: $q != $r" 236 } 237 for {set n 0} {$n < $max} {incr n} { 238 if {![float=? [lindex $q $n] [lindex $r $n]]} { 239 error "echoFloatArray failed: element $n is different: $q != $r" 240 } 241 } 242 return "echoFloatArray" 243} 244 245proc soapinterop::validate.echoStringArray {} { 246 set q [array get ::tcl_platform] 247 set r [echoStringArray $q] 248 if {[llength $r] != [llength $q]} { 249 error "echoStringArray failed: lists are different: $q != $r" 250 } 251 set max [llength $q] 252 for {set n 0} {$n < $max} {incr n} { 253 if {! [string match [lindex $q $n] [lindex $r $n]]} { 254 error "echoStringArray failed: element $n is different: $q != $r" 255 } 256 } 257 return "echoStringArray" 258} 259 260proc soapinterop::validateSOAPStruct {first second} { 261 set r 0 262 array set f $first 263 array set s $second 264 foreach key [array names f] { 265 set type [rpcvar::rpctype $f($key)] 266 switch -- $type { 267 double { set r [float=? $f($key) $s($key)] } 268 float { set r [float=? $f($key) $s($key)] } 269 int { set r [expr $f($key) == $s($key)] } 270 default { 271 if {[string match "varStruct" $key]} { 272 set r [validateSOAPStruct $f($key) $s($key)] 273 } else { 274 set r [string match $f($key) $s($key)] 275 } 276 } 277 } 278 if {! $r} { 279 error "failed: mismatching \"$key\" element\ 280 $f($key) != $s($key)" 281 } 282 } 283 return $r 284} 285 286proc soapinterop::validate.echoStruct {} { 287 set q [list \ 288 varInt [rand_int] \ 289 varFloat [rand_float] \ 290 varString [rand_string]] 291 set r [echoStruct $q] 292 if {[catch {validateSOAPStruct $q $r} err]} { 293 error "echoStruct $err" 294 } 295 return "echoStruct" 296} 297 298proc soapinterop::validate.echoStructArray {} { 299 300 set max [expr int(rand() * 19 + 2)] 301 for {set n 0} {$n < $max} {incr n} { 302 lappend q [list \ 303 varInt [rand_int] \ 304 varFloat [rand_float] \ 305 varString [rand_string]] 306 } 307 308 set r [echoStructArray $q] 309 for {set n 0} {$n < $max} {incr n} { 310 if {[catch {validateSOAPStruct [lindex $q $n] [lindex $r $n]} err]} { 311 error "echoStructArray $err" 312 } 313 } 314 return "echoStructArray" 315} 316 317# ------------------------------------------------------------------------- 318 319# 320# Local variables: 321# mode: tcl 322# indent-tabs-mode: nil 323# End: 324