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