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