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