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