1# ======================================================================
2#
3# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
4# SOAP::Lite is free software; you can redistribute it
5# and/or modify it under the same terms as Perl itself.
6#
7# ======================================================================
8
9package SOAP::Test;
10
11use 5.006;
12our $VERSION = 1.11;
13
14our $TIMEOUT = 5;
15
16# ======================================================================
17
18package My::PingPong; # we'll use this package in our tests
19
20sub new {
21  my $self = shift;
22  my $class = ref($self) || $self;
23  bless {_num=>shift} => $class;
24}
25
26sub next {
27  my $self = shift;
28  $self->{_num}++;
29}
30
31sub value {
32  my $self = shift;
33  $self->{_num};
34}
35
36# ======================================================================
37
38package SOAP::Test::Server;
39
40use strict;
41use Test;
42use SOAP::Lite;
43
44sub run_for {
45  my $proxy = shift or die "Proxy/endpoint is not specified";
46
47  # ------------------------------------------------------
48  my $s = SOAP::Lite->uri('http://something/somewhere')->proxy($proxy)->on_fault(sub{});
49  eval { $s->transport->timeout($SOAP::Test::TIMEOUT) };
50  my $r = $s->test_connection;
51
52  unless (defined $r && defined $r->envelope) {
53    print "1..0 # Skip: ", $s->transport->status, "\n";
54    exit;
55  }
56  # ------------------------------------------------------
57
58  plan tests => 53;
59
60  eval q!use SOAP::Lite on_fault => sub{ref $_[1] ? $_[1] : new SOAP::SOM}; 1! or die;
61
62  print STDERR "Perl SOAP server test(s)...\n";
63
64  $s = SOAP::Lite
65    -> uri('urn:/My/Examples')
66      -> proxy($proxy);
67
68  ok($s->getStateName(1)->result eq 'Alabama');
69  ok($s->getStateNames(1,4,6,13)->result =~ /^Alabama\s+Arkansas\s+Colorado\s+Illinois\s*$/);
70
71  $r = $s->getStateList([1,2,3,4])->result;
72  ok(ref $r && $r->[0] eq 'Alabama');
73
74  $r = $s->getStateStruct({item1 => 1, item2 => 4})->result;
75  ok(ref $r && $r->{item2} eq 'Arkansas');
76print $s->transport->status, "\n";
77  {
78    my $autoresult = $s->autoresult;
79    $s->autoresult(1);
80    ok($s->getStateName(1) eq 'Alabama');
81    $s->autoresult($autoresult);
82  }
83
84  print STDERR "Autobinding of output parameters test(s)...\n";
85
86  $s->uri('urn:/My/Parameters');
87  my $param1 = 10;
88  my $param2 = SOAP::Data->name('myparam' => 12);
89  my $result = $s->autobind($param1, $param2)->result;
90  ok($result == $param1 && $param2->value == 24);
91
92  print STDERR "Header manipulation test(s)...\n";
93  $a = $s->addheader(2, SOAP::Header->name(my => 123));
94  ok(ref $a->header && $a->header->{my} eq '123123');
95  ok($a->headers eq '123123');
96
97  print STDERR "Echo untyped data test(s)...\n";
98  $a = $s->echotwo(11, 12);
99  ok($a->result == 11);
100
101  print STDERR "mustUnderstand test(s)...\n";
102  $s->echo(SOAP::Header->name(somethingelse => 123)
103                       ->mustUnderstand(1));
104  ok($s->call->faultstring =~ /[Hh]eader has mustUnderstand attribute/);
105
106  if ($proxy =~ /^http/) {
107    ok($s->transport->status =~ /^500/);
108  } else {
109    skip('No Status checks for non http protocols on server side' => undef);
110  }
111
112  $s->echo(SOAP::Header->name(somethingelse => 123)
113                       ->mustUnderstand(1)
114                       ->actor('http://notme/'));
115  ok(!defined $s->call->fault);
116
117  print STDERR "dispatch_from test(s)...\n";
118  eval "use SOAP::Lite
119    uri => 'http://my.own.site.com/My/Examples',
120    dispatch_from => ['A', 'B'],
121    proxy => '$proxy',
122  ; 1" or die;
123
124  eval { C->c };
125  ok($@ =~ /Can't locate object method "c"/);
126
127  eval { A->a };
128  ok(!$@ && SOAP::Lite->self->call->faultstring =~ /Failed to access class \(A\)/);
129
130  eval "use SOAP::Lite
131    dispatch_from => 'A',
132    uri => 'http://my.own.site.com/My/Examples',
133    proxy => '$proxy',
134  ; 1" or die;
135
136  eval { A->a };
137  ok(!$@ && SOAP::Lite->self->call->faultstring =~ /Failed to access class \(A\)/);
138
139  print STDERR "Object autobinding and SOAP:: prefix test(s)...\n";
140
141  eval "use SOAP::Lite +autodispatch =>
142    uri => 'urn:', proxy => '$proxy'; 1" or die;
143
144  ok(SOAP::Lite->autodispatched);
145
146  eval { SOAP->new(1) };
147  ok($@ =~ /^URI is not specified/);
148
149  eval "use SOAP::Lite +autodispatch =>
150    uri => 'urn:/A/B', proxy => '$proxy'; 1" or die;
151
152  # should call My::PingPong, not A::B
153  my $p = My::PingPong->SOAP::new(10);
154  ok(ref $p && $p->SOAP::next+1 == $p->value);
155
156  # forget everything
157  SOAP::Lite->self(undef);
158
159  $s = SOAP::Lite
160    -> uri('urn:/My/PingPong')
161    -> proxy($proxy)
162  ;
163
164  # should return object EXACTLY as after My::PingPong->SOAP::new(10)
165  $p = $s->SOAP::new(10);
166  ok(ref $p && $s->SOAP::next($p)+1 == $p->value);
167
168  print STDERR "VersionMismatch test(s)...\n";
169
170  {
171    local $SOAP::Constants::NS_ENV = 'http://schemas.xmlsoap.org/new/envelope/';
172    my $s = SOAP::Lite
173      -> uri('http://my.own.site.com/My/Examples')
174      -> proxy($proxy)
175      -> on_fault(sub{})
176    ;
177    $r = $s->dosomething;
178    ok(ref $r && $r->faultcode =~ /:VersionMismatch/);
179  }
180
181  print STDERR "Objects-by-reference test(s)...\n";
182
183  eval "use SOAP::Lite +autodispatch =>
184    uri => 'urn:', proxy => '$proxy'; 1" or die;
185
186  print STDERR "Session iterator\n";
187  $r = My::SessionIterator->new(10);
188  if (!ref $r || exists $r->{id}) {
189    ok(ref $r && $r->next && $r->next == 11);
190  } else {
191    skip('No persistent objects (o-b-r) supported on server side' => undef);
192  }
193
194  print STDERR "Persistent iterator\n";
195  $r = My::PersistentIterator->new(10);
196  if (!ref $r || exists $r->{id}) {
197    my $first = ($r->next, $r->next) if ref $r;
198
199    $r = My::PersistentIterator->new(10);
200    ok(ref $r && $r->next && $r->next == $first+2);
201  } else {
202    skip('No persistent objects (o-b-r) supported on server side' => undef);
203  }
204
205  { local $^W; # disable warnings about deprecated AUTOLOADing for nonmethods
206    print STDERR "Parameters-by-name test(s)...\n";
207    print STDERR "You can see warning about AUTOLOAD for non-method...\n" if $^W;
208
209    eval "use SOAP::Lite +autodispatch =>
210      uri => 'http://my.own.site.com/My/Parameters', proxy => '$proxy'; 1" or die;
211
212    my @parameters = (
213      SOAP::Data->name(b => 222),
214      SOAP::Data->name(c => 333),
215      SOAP::Data->name(a => 111)
216    );
217
218    # switch to 'main' package, because nonqualified methods should be there
219    ok(main::byname(@parameters) eq "a=111, b=222, c=333");
220
221    ok(main::bynameororder(@parameters) eq "a=111, b=222, c=333");
222
223    ok(main::bynameororder(111, 222, 333) eq "a=111, b=222, c=333");
224
225    print STDERR "Function call test(s)...\n";
226    print STDERR "You can see warning about AUTOLOAD for non-method...\n" if $^W;
227    ok(main::echo(11) == 11);
228  }
229
230  print STDERR "SOAPAction test(s)...\n";
231  if ($proxy =~ /^tcp:/) {
232    for (1..2) {skip('No SOAPAction checks for tcp: protocol on server side' => undef)}
233  } else {
234    my $s = SOAP::Lite
235      -> uri('http://my.own.site.com/My/Examples')
236      -> proxy($proxy)
237      -> on_action(sub{'""'})
238    ;
239    ok($s->getStateName(1)->result eq 'Alabama');
240
241    $s->on_action(sub{'"wrong_SOAPAction_here"'});
242    ok($s->getStateName(1)->faultstring =~ /SOAPAction shall match/);
243  }
244
245  print STDERR "UTF8 test(s)...\n";
246  if (!eval "pack('U*', 0)") {
247    for (1) {skip('No UTF8 test. No support for pack("U*") modifier' => undef)}
248  } else {
249    $s = SOAP::Lite
250      -> uri('http://my.own.site.com/My/Parameters')
251      -> proxy($proxy);
252
253     my $latin1 = '�ਢ��';
254     my $utf8 = pack('U*', unpack('C*', $latin1));
255     my $result = $s->echo(SOAP::Data->type(string => $utf8))->result;
256
257     ok(pack('U*', unpack('C*', $result)) eq $utf8                       # should work where XML::Parser marks resulting strings as UTF-8
258     || join('', unpack('C*', $result)) eq join('', unpack('C*', $utf8)) # should work where it doesn't
259     );
260  }
261
262  {
263    my $on_fault_was_called = 0;
264    print STDERR "Die in server method test(s)...\n";
265    my $s = SOAP::Lite
266      -> uri('http://my.own.site.com/My/Parameters')
267      -> proxy($proxy)
268      -> on_fault(sub{$on_fault_was_called++;return})
269    ;
270    ok($s->die_simply()->faultstring =~ /Something bad/);
271    ok($on_fault_was_called > 0);
272    my $detail = $s->die_with_object()->dataof(SOAP::SOM::faultdetail . '/[1]');
273    ok($on_fault_was_called > 1);
274    ok(ref $detail && $detail->name =~ /(^|:)something$/);
275
276    # get Fault as hash of subelements
277    my $fault = $s->die_with_fault()->fault;
278    ok($fault->{faultcode} =~ ':Server.Custom');
279    ok($fault->{faultstring} eq 'Died in server method');
280    ok(ref $fault->{detail}->{BadError} eq 'BadError');
281    ok($fault->{faultactor} eq 'http://www.soaplite.com/custom');
282  }
283
284  print STDERR "Method with attributes test(s)...\n";
285
286  $s = SOAP::Lite
287    -> uri('urn:/My/Examples')
288    -> proxy($proxy)
289  ;
290
291  ok($s->call(SOAP::Data->name('getStateName')->attr({xmlns => 'urn:/My/Examples'}), 1)->result eq 'Alabama');
292
293  print STDERR "Call with empty uri test(s)...\n";
294  $s = SOAP::Lite
295    -> uri('')
296    -> proxy($proxy)
297  ;
298
299  ok($s->getStateName(1)->faultstring =~ /Denied access to method \(getStateName\) in class \(main\)/);
300
301  ok($s->call('a:getStateName' => 1)->faultstring =~ /Denied access to method \(getStateName\) in class \(main\)/);
302
303  print STDERR "Number of parameters test(s)...\n";
304
305  $s = SOAP::Lite
306    -> uri('http://my.own.site.com/My/Parameters')
307    -> proxy($proxy)
308  ;
309  { my @all = $s->echo->paramsall; ok(@all == 0) }
310  { my @all = $s->echo(1)->paramsall; ok(@all == 1) }
311  { my @all = $s->echo((1) x 10)->paramsall; ok(@all == 10) }
312
313  print STDERR "Memory refresh test(s)...\n";
314
315  # Funny test.
316  # Let's forget about ALL settings we did before with 'use SOAP::Lite...'
317  SOAP::Lite->self(undef);
318  ok(!defined SOAP::Lite->self);
319
320  print STDERR "Call without uri test(s)...\n";
321  $s = SOAP::Lite
322    -> proxy($proxy)
323  ;
324
325  ok($s->getStateName(1)->faultstring =~ /Denied access to method \(getStateName\) in class \(main\)/);
326
327  print STDERR "Different settings for method and namespace test(s)...\n";
328
329  ok($s->call(SOAP::Data
330    ->name('getStateName')
331    ->attr({xmlns => 'urn:/My/Examples'}), 1)->result eq 'Alabama');
332
333  ok($s->call(SOAP::Data
334    ->name('a:getStateName')
335    ->uri('urn:/My/Examples'), 1)->result eq 'Alabama');
336
337  ok($s->call(SOAP::Data
338    ->name('getStateName')
339    ->uri('urn:/My/Examples'), 1)->result eq 'Alabama');
340
341  ok($s->call(SOAP::Data
342    ->name('a:getStateName')
343    ->attr({'xmlns:a' => 'urn:/My/Examples'}), 1)->result eq 'Alabama');
344
345  eval { $s->call(SOAP::Data->name('a:getStateName')) };
346
347  ok($@ =~ /Can't find namespace for method \(a:getStateName\)/);
348
349  $s->serializer->namespaces->{'urn:/My/Examples'} = '';
350
351  ok($s->getStateName(1)->result eq 'Alabama');
352
353  eval "use SOAP::Lite
354    uri => 'urn:/My/Examples', proxy => '$proxy'; 1" or die;
355
356  print STDERR "Global settings test(s)...\n";
357  $s = new SOAP::Lite;
358
359  ok($s->getStateName(1)->result eq 'Alabama');
360
361  SOAP::Trace->import(transport =>
362    sub {$_[0]->content_type('something/wrong') if UNIVERSAL::isa($_[0] => 'HTTP::Request')}
363  );
364
365  if ($proxy =~ /^tcp:/) {
366    skip('No Content-Type checks for tcp: protocol on server side' => undef);
367  } else {
368    ok($s->getStateName(1)->faultstring =~ /Content-Type must be/);
369  }
370}
371
372# ======================================================================
373
3741;
375
376__END__
377
378=head1 NAME
379
380SOAP::Test - Test framework for SOAP::Lite
381
382=head1 SYNOPSIS
383
384  use SOAP::Test;
385
386  SOAP::Test::Server::run_for('http://localhost/cgi-bin/soap.cgi');
387
388=head1 DESCRIPTION
389
390SOAP::Test provides simple framework for testing server implementations.
391Specify your address (endpoint) and run provided tests against your server.
392See t/1*.t for examples.
393
394=head1 COPYRIGHT
395
396Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved.
397
398This library is free software; you can redistribute it and/or modify
399it under the same terms as Perl itself.
400
401=head1 AUTHOR
402
403Paul Kulchenko (paulclinger@yahoo.com)
404
405=cut
406