1#!/usr/bin/env perl 2 3# Test the RPC::XML::Server class 4 5## no critic(RequireInterpolationOfMetachars) 6 7use strict; 8use warnings; 9use subs qw(start_server stop_server find_port_in_use); 10 11use Carp qw(croak); 12use IO::Socket; 13use File::Spec; 14use List::Util 'none'; 15use Scalar::Util 'blessed'; 16use Socket (); 17 18use Test::More; 19use LWP::UserAgent; 20use HTTP::Request; 21 22use RPC::XML 'RPC_BASE64'; 23use RPC::XML::Server; 24use RPC::XML::ParserFactory; 25 26plan tests => 90; 27 28my ($srv, $res, $bucket, $child, $parser, $xml, $req, $port, $UA, @API_METHODS, 29 $list, $meth, %seen, $dir, $vol, $oldtable, $newtable, $value); 30 31@API_METHODS = qw(system.identity system.introspection system.listMethods 32 system.methodHelp system.methodSignature system.multicall 33 system.status); 34 35($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0)); 36$dir = File::Spec->catpath($vol, $dir, q{}); 37require File::Spec->catfile($dir, 'util.pl'); 38 39sub failmsg { 40 my ($msg, $line) = @_; 41 42 return sprintf '%s at line %d', $msg, $line; 43} 44 45# The organization of the test suites is such that we assume anything that 46# runs before the current suite is 100%. Thus, no consistency checks on 47# any other classes are done, only on the data and return values of this 48# class under consideration, RPC::XML::Server. In this particular case, this 49# also means that we cannot use RPC::XML::Client to test it. 50 51# Start with some very basic things, without actually firing up a live server. 52$srv = RPC::XML::Server->new(no_http => 1, no_default => 1); 53isa_ok($srv, 'RPC::XML::Server', '$srv<1>'); 54 55# This assignment is just to suppress "used only once" warnings 56$value = $RPC::XML::Server::VERSION; 57is($srv->version, $RPC::XML::Server::VERSION, 58 'RPC::XML::Server::version method'); 59ok(! $srv->started, 'RPC::XML::Server::started method'); 60like($srv->product_tokens, qr{/}, 'RPC::XML::Server::product_tokens method'); 61ok(! $srv->url, 'RPC::XML::Server::url method (empty)'); 62ok(! $srv->requests, 'RPC::XML::Server::requests method (0)'); 63ok($srv->response->isa('HTTP::Response'), 64 'RPC::XML::Server::response method returns HTTP::Response'); 65# Some negative tests: 66$res = $srv->new(); 67like($res, qr/Must be called as a static method/, 68 'Calling new() as an instance method fails'); 69$meth = $srv->method_from_file('does_not_exist.xpl'); 70ok(! ref $meth, 'Bad file did not result in method reference'); 71like($meth, qr/Error opening.*does_not_exist/, 'Correct error message'); 72 73# Test the functionality of manipulating the fault table. First get the vanilla 74# table from a simple server object. Then create a new server object with both 75# a fault-base offset and some user-defined faults. We use the existing $srv to 76# get the "plain" table. 77$oldtable = $srv->{__fault_table}; 78# Now re-assign $srv 79$srv = RPC::XML::Server->new( 80 no_http => 1, 81 no_default => 1, 82 fault_code_base => 1000, 83 fault_table => { 84 myfault1 => [ 2000, 'test' ], 85 myfault2 => 2001, 86 } 87); 88$newtable = $srv->{__fault_table}; 89# Compare number of faults, the values of the fault codes, and the presence of 90# the user-defined faults: 91ok((scalar(keys %{$oldtable}) + 2) == (scalar keys %{$newtable}), 92 'Proper number of relative keys'); 93$value = 1; 94for my $key (keys %{$oldtable}) { 95 if ($newtable->{$key}->[0] != ($oldtable->{$key}->[0] + 1000)) { 96 $value = 0; 97 last; 98 } 99} 100ok($value, 'Fault codes adjustment yielded correct new codes'); 101ok((exists $newtable->{myfault1} && exists $newtable->{myfault2} && 102 ref($newtable->{myfault1}) eq 'ARRAY' && $newtable->{myfault2} == 2001 && 103 $newtable->{myfault1}->[0] == 2000), 104 'User-supplied fault elements look OK'); 105 106# Done with this one, let it go 107undef $srv; 108 109# Test that the url() method behaves like we expect it for certain ports 110$srv = RPC::XML::Server->new( 111 no_default => 1, 112 no_http => 1, 113 host => 'localhost', 114 port => 80 115); 116SKIP: { 117 if (ref($srv) ne 'RPC::XML::Server') { 118 skip 'Failed to get port-80 server, cannot test', 1; 119 } 120 121 is($srv->url, 'http://localhost', 'Default URL for port-80 server'); 122} 123 124$srv = RPC::XML::Server->new( 125 no_default => 1, 126 no_http => 1, 127 host => 'localhost', 128 port => 443 129); 130SKIP: { 131 if (ref($srv) ne 'RPC::XML::Server') { 132 skip 'Failed to get port-443 server, cannot test', 1; 133 } 134 135 is($srv->url, 'https://localhost', 'Default URL for port-443 server'); 136} 137 138# Let's test that server creation properly fails if/when HTTP::Daemon fails. 139# First find a port in use, preferably under 1024: 140SKIP: { 141 if ($< == 0) { 142 skip 'Negative port-based test unreliable when run as root', 2; 143 } 144 $port = find_port_in_use; 145 if ($port == -1) { 146 skip 'No in-use port found for negative testing, skipped', 2; 147 } 148 149 $srv = RPC::XML::Server->new(port => $port); 150 is(ref($srv), q{}, 'Bad new return is not an object'); 151 like($srv, qr/Unable to create HTTP::Daemon/, 'Proper error message'); 152} 153 154# This one will have a HTTP::Daemon server, but still no default methods 155$srv = RPC::XML::Server->new(no_default => 1, host => 'localhost'); 156isa_ok($srv, 'RPC::XML::Server', '$srv<2>'); 157if (! ref $srv) { 158 croak "Server allocation failed, cannot continue. Message was: $srv"; 159} 160 161# Test some of the simpler cases of add_method and get_method 162$res = $srv->add_method({ name => 'perl.test.suite.test1', 163 signature => [ 'int' ], 164 code => sub { return 1; } }); 165ok($res eq $srv, 'add_method return value test'); 166$res = $srv->get_method('perl.test.suite.test1'); 167isa_ok($res, 'RPC::XML::Method', 'get_method return value'); 168$res = $srv->get_method('perl.test.suite.not.added.yet'); 169ok(! ref($res), 'get_method for non-existent method'); 170 171# Throw junk at add_method/add_procedure/add_function 172$res = $srv->add_method([]); 173like($res, qr/file name, a hash reference or an object/, 174 'add_method() fails on bad data'); 175$res = $srv->add_method('file does not exist'); 176like($res, qr/Error loading from file/, 177 'add_method() fails on non-existent file'); 178$res = $srv->add_procedure({ name => 'procedure1', 179 signature => [ 'int' ], 180 code => sub { return 1; } }); 181ok($res eq $srv, 'add_procedure return value test'); 182$res = $srv->get_procedure('procedure1'); 183is(ref($res), 'RPC::XML::Procedure', 'get_procedure(procedure1) return value'); 184$res = $srv->add_function({ name => 'function1', 185 code => sub { return 1; } }); 186ok($res eq $srv, 'add_function return value test'); 187$res = $srv->get_function('function1'); 188is(ref($res), 'RPC::XML::Function', 'get_function(function1) return value'); 189$res = $srv->add_method({ name => 'method1', 190 type => 'bad', 191 signature => [ 'int' ], 192 code => sub { return 1; } }); 193like($res, qr/Unknown type: bad/, 'add_method, bad type param'); 194 195# Here goes... 196$parser = RPC::XML::ParserFactory->new; 197$UA = LWP::UserAgent->new; 198$req = HTTP::Request->new(POST => $srv->url); 199$child = start_server $srv; 200 201$req->header(Content_Type => 'text/xml'); 202$req->content(RPC::XML::request->new('perl.test.suite.test1')->as_string); 203# Use alarm() to manage a resaonable time-out on the request 204$bucket = 0; 205local $SIG{ALRM} = sub { $bucket++ }; 206alarm 120; 207$res = $UA->request($req); 208alarm 0; 209ok(! $bucket, 'First live-request returned without timeout'); 210SKIP: { 211 if ($bucket) 212 { 213 skip 'Server failed to respond within 120 seconds!', 4; 214 } 215 216 ok(! $res->is_error, 'First live req: Check that $res is not an error'); 217 $xml = $res->content; 218 $res = $parser->parse($xml); 219 isa_ok($res, 'RPC::XML::response', 'First live req: parsed $res'); 220 SKIP: { 221 if (! (ref $res and $res->isa('RPC::XML::response'))) 222 { 223 skip 'Response content did not parse, cannot test', 2; 224 } 225 226 ok(! $res->is_fault, 'First live req: parsed $res is not a fault'); 227 is($res->value->value, 1, 'First live req: $res value test'); 228 } 229} 230stop_server $child; 231 232# Try deleting the method 233ok(ref $srv->delete_method('perl.test.suite.test1'), 234 'delete_method return value test'); 235 236# Start the server again 237# Add a method that echoes back socket-peer information 238$res = $srv->add_method({ name => 'perl.test.suite.peeraddr', 239 signature => [ 'array' ], 240 code => 241 sub { 242 my $server = shift; 243 244 my $peerfamily = RPC_BASE64 $server->{peerfamily}; 245 my $peeraddr = RPC_BASE64 $server->{peeraddr}; 246 my $packet = pack_sockaddr_any( 247 $server->{peerfamily}, 248 $server->{peerhost}, 249 $server->{peerport} 250 ); 251 $packet = RPC_BASE64 $packet; 252 253 [ $peerfamily, $peeraddr, $packet, 254 $server->{peerhost}, $server->{peerport} ]; 255 } }); 256$child = start_server $srv; 257$bucket = 0; 258alarm 120; 259$res = $UA->request($req); 260alarm 0; 261ok(! $bucket, 'Second live-request returned without timeout'); 262SKIP: { 263 if ($bucket) 264 { 265 skip 'Server failed to respond within 120 seconds!', 4; 266 } 267 268 ok(! $res->is_error, 'Second live req: Check that $res is not an error'); 269 $res = $parser->parse($res->content); 270 isa_ok($res, 'RPC::XML::response', 'Second live req: parsed $res'); 271 SKIP: { 272 if (! (ref $res and $res->isa('RPC::XML::response'))) 273 { 274 skip 'Response content did not parse, cannot test', 2; 275 } 276 277 ok($res->is_fault, 'Second live req: parsed $res is a fault'); 278 like($res->value->value->{faultString}, qr/Unknown method/, 279 'Second live request: correct faultString'); 280 } 281} 282stop_server $child; 283 284# Start the server again 285$child = start_server $srv; 286$bucket = 0; 287$req->content(RPC::XML::request->new('perl.test.suite.peeraddr')->as_string); 288alarm 120; 289$res = $UA->request($req); 290alarm 0; 291ok(! $bucket, 'Third live-request returned without timeout'); 292SKIP: { 293 if ($bucket) 294 { 295 skip 'Server failed to respond within 120 seconds!', 4; 296 } 297 298 ok(! $res->is_error, 'Third live req: Check that $res is not an error'); 299 $res = $parser->parse($res->content); 300 isa_ok($res, 'RPC::XML::response', 'Third live req: parsed $res'); 301 SKIP: { 302 if (! (ref $res and $res->isa('RPC::XML::response'))) 303 { 304 skip 'Response content did not parse, cannot test', 3; 305 } 306 307 $res = $res->value->value; 308 ok(grep({ $_ eq $res->[3]} resolve($res->[0], 'localhost')), 309 'Third live req: Correct IP addr from peerhost'); 310 is($res->[1], Socket::inet_pton($res->[0], $res->[3]), 311 'Third request: peeraddr packet matches converted peerhost'); 312 is($res->[2], pack_sockaddr_any($res->[0], $res->[3], $res->[4]), 313 'Third request: pack_sockaddr_any validates all'); 314 } 315} 316stop_server $child; 317 318# Start the server again 319# Add a method that echoes back info from the HTTP request object 320$res = $srv->add_method({ name => 'perl.test.suite.http_req', 321 signature => [ 'array' ], 322 code => 323 sub { 324 my $server = shift; 325 326 [ $server->{request}->content_type, 327 $server->{request}->header('X-Foobar') ] 328 } }); 329$child = start_server $srv; 330$bucket = 0; 331$req->content(RPC::XML::request->new('perl.test.suite.http_req')->as_string); 332$req->header('X-Foobar', 'Wibble'); 333alarm 120; 334$res = $UA->request($req); 335alarm 0; 336ok(! $bucket, 'Fourth live-request returned without timeout'); 337SKIP: { 338 if ($bucket) 339 { 340 skip 'Server failed to respond within 120 seconds!', 4; 341 } 342 343 ok(! $res->is_error, 'Fourth live req: Check that $res is not an error'); 344 $res = $parser->parse($res->content); 345 isa_ok($res, 'RPC::XML::response', 'Fourth live req: parsed $res'); 346 SKIP: { 347 if (! (ref $res and $res->isa('RPC::XML::response'))) 348 { 349 skip 'Response content did not parse, cannot test', 2; 350 } 351 352 $res = $res->value->value; 353 is($res->[0], 'text/xml', 354 'Fourth request: Content type returned correctly'); 355 is($res->[1], 'Wibble', 356 'Fourth live req: Correct value for request header X-Foobar'); 357 } 358} 359# Clean up after ourselves. 360$req->remove_header('X-Foobar'); 361stop_server $child; 362 363# Start the server again 364$child = start_server $srv; 365 366# Test the error-message-mixup problem reported in RT# 29351 367# (http://rt.cpan.org/Ticket/Display.html?id=29351) 368my $tmp = <<'EOX'; 369<?xml version="1.0" encoding="us-ascii"?> 370<methodCall> 371 <methodName>test.method</methodName> 372 <params> 373 <param> 374 <value><string>foo</string></value> 375 <value><string>bar</string></value> 376 </param> 377 </params> 378</methodCall> 379EOX 380$req->content($tmp); 381$bucket = 0; 382alarm 120; 383$res = $UA->request($req); 384alarm 0; 385ok(! $bucket, 'RT29351 live-request returned without timeout'); 386SKIP: { 387 if ($bucket) { 388 skip 'Server failed to respond within 120 seconds!', 4; 389 } 390 391 ok(! $res->is_error, 'RT29351 live req: $res is not an error'); 392 $res = $parser->parse($res->content); 393 isa_ok($res, 'RPC::XML::response', 'RT29351 live req: parsed $res'); 394 SKIP: { 395 if (! (ref $res and $res->isa('RPC::XML::response'))) { 396 skip 'Response content did not parse, cannot test', 2; 397 } 398 399 ok($res->is_fault, 'RT29351 live req: parsed $res is a fault'); 400 like( 401 $res->value->value->{faultString}, 402 qr/Illegal content in param tag/, 403 'RT29351 live request: correct faultString' 404 ); 405 } 406} 407stop_server $child; 408 409# OK-- At this point, basic server creation and accessors have been validated. 410# We've run a remote method and we've correctly failed to run an unknown remote 411# method. Before moving into the more esoteric XPL-file testing, we will test 412# the provided introspection API. 413undef $srv; 414undef $req; 415$srv = RPC::XML::Server->new(host => 'localhost'); 416 417# Did it create OK, with the requirement of loading the XPL code? 418isa_ok($srv, 'RPC::XML::Server', '$srv<3> (with default methods)'); 419# Assume $srv is defined for the rest of the tests 420if (! ref $srv) { 421 croak "Server allocation failed, cannot continue. Message was: $srv"; 422} 423 424# Did it get all of them? 425is($srv->list_methods(), scalar(@API_METHODS), 426 'Correct number of methods (defaults)'); 427$req = HTTP::Request->new(POST => $srv->url); 428 429$child = start_server $srv; 430 431$req->header(Content_Type => 'text/xml'); 432$req->content(RPC::XML::request->new('system.listMethods')->as_string); 433# Use alarm() to manage a reasonable time-out on the request 434$bucket = 0; 435undef $res; 436alarm 120; 437$res = $UA->request($req); 438alarm 0; 439SKIP: { 440 if ($bucket) { 441 skip 'Server failed to respond within 120 seconds!', 2; 442 } 443 444 $res = ($res->is_error) ? q{} : $parser->parse($res->content); 445 isa_ok($res, 'RPC::XML::response', 'system.listMethods response'); 446 SKIP: { 447 if (! (ref $res and $res->isa('RPC::XML::response'))) { 448 skip 'Response content did not parse, cannot test', 1; 449 } 450 451 $list = (ref $res) ? $res->value->value : []; 452 ok((ref($list) eq 'ARRAY') && 453 (join(q{} => sort @{$list}) eq join q{} => sort @API_METHODS), 454 'system.listMethods return list correct'); 455 } 456} 457 458stop_server $child; 459 460# Start the server again 461$child = start_server $srv; 462 463# Set the ALRM handler to something more serious, since we have passed that 464# hurdle already. 465local $SIG{ALRM} = sub { die "Server failed to respond within 120 seconds\n"; }; 466 467# Test the substring-parameter calling of system.listMethods 468$req->content(RPC::XML::request->new('system.listMethods', 469 'method')->as_string); 470alarm 120; 471$res = $UA->request($req); 472alarm 0; 473$res = ($res->is_error) ? q{} : $parser->parse($res->content); 474SKIP: { 475 if (! $res) { 476 skip 'Server response was error, cannot test', 1; 477 } 478 479 $list = $res->value->value; 480 if ($res->is_fault) { 481 fail(failmsg($res->value->string, __LINE__)); 482 } else { 483 is(join(q{,} => sort @{$list}), 484 'system.methodHelp,system.methodSignature', 485 'system.listMethods("method") return list correct'); 486 } 487} 488 489# If the response was any kind of error, kill and re-start the server, as 490# HTTP::Message::content might have killed it already via croak(). 491if (! $res) { 492 # $res was made null above if it was an error 493 stop_server $child; 494 495 # Start the server again 496 $child = start_server $srv; 497} 498 499# Run again, with a pattern that will produce no matches 500$req->content(RPC::XML::request->new('system.listMethods', 501 'nomatch')->as_string); 502alarm 120; 503$res = $UA->request($req); 504alarm 0; 505$res = ($res->is_error) ? q{} : $parser->parse($res->content); 506SKIP: { 507 if (! $res) { 508 skip 'Server response was error, cannot test', 1; 509 } 510 511 $list = $res->value->value; 512 if ($res->is_fault) { 513 fail(failmsg($res->value->string, __LINE__)); 514 } else { 515 is(scalar(@{$list}), 0, 516 'system.listMethods("nomatch") return list correct'); 517 } 518} 519 520# If the response was any kind of error, kill and re-start the server, as 521# HTTP::Message::content might have killed it already via croak(). 522if (! $res) { 523 # $res was made null above if it was an error 524 stop_server $child; 525 526 # Start the server again 527 $child = start_server $srv; 528} 529 530# system.identity 531$req->content(RPC::XML::request->new('system.identity')->as_string); 532alarm 120; 533$res = $UA->request($req); 534alarm 0; 535$res = ($res->is_error) ? q{} : $parser->parse($res->content); 536SKIP: { 537 if (! $res) { 538 skip 'Server response was error, cannot test', 1; 539 } 540 541 is($res->value->value, $srv->product_tokens, 'system.identity test'); 542} 543 544# If the response was any kind of error, kill and re-start the server, as 545# HTTP::Message::content might have killed it already via croak(). 546if (! $res) { 547 # $res was made null above if it was an error 548 stop_server $child; 549 550 # Start the server again 551 $child = start_server $srv; 552} 553 554# system.status 555$req->content(RPC::XML::request->new('system.status')->as_string); 556alarm 120; 557$res = $UA->request($req); 558alarm 0; 559$res = ($res->is_error) ? q{} : $parser->parse($res->content); 560SKIP: { 561 if (! $res) { 562 skip 'Server response was error, cannot test', 2; 563 } 564 565 $res = $res->value->value; 566 my @keys = qw(host port name version path date date_int started started_int 567 total_requests methods_known); 568 my @seen_keys = grep { defined $res->{$_} } @keys; 569 ok(@keys == @seen_keys, 'system.status hash has correct keys'); 570 is($res->{total_requests}, 4, 571 'system.status reports correct total_requests'); 572} 573 574# If the response was any kind of error, kill and re-start the server, as 575# HTTP::Message::content might have killed it already via croak(). 576if (! $res) { 577 # $res was made null above if it was an error 578 stop_server $child; 579 580 # Start the server again 581 $child = start_server $srv; 582} 583 584# Test again, with a 'true' value passed to the method, which should prevent 585# the 'total_requests' key from incrementing. 586$req->content(RPC::XML::request->new('system.status', 587 RPC::XML::boolean->new(1))->as_string); 588alarm 120; 589$res = $UA->request($req); 590alarm 0; 591$res = ($res->is_error) ? q{} : $parser->parse($res->content); 592SKIP: { 593 if (! $res) { 594 skip 'Server response was error, cannot test', 1; 595 } 596 597 $res = $res->value->value; 598 is($res->{total_requests}, 4, 599 'system.status reports correct total_requests ("true" call)'); 600} 601 602# If the response was any kind of error, kill and re-start the server, as 603# HTTP::Message::content might have killed it already via croak(). 604if (! $res) { 605 # $res was made null above if it was an error 606 stop_server $child; 607 608 # Start the server again 609 $child = start_server $srv; 610} 611 612# system.methodHelp 613$req->content(RPC::XML::request->new('system.methodHelp', 614 'system.identity')->as_string); 615alarm 120; 616$res = $UA->request($req); 617alarm 0; 618$res = ($res->is_error) ? q{} : $parser->parse($res->content); 619SKIP: { 620 if (! $res) { 621 skip 'Server response was error, cannot test', 1; 622 } 623 624 $meth = $srv->get_method('system.identity'); 625 if (! blessed $meth) { 626 fail(failmsg($meth, __LINE__)); 627 } else { 628 is($res->value->value, $meth->{help}, 629 'system.methodHelp("system.identity") test'); 630 } 631} 632 633# If the response was any kind of error, kill and re-start the server, as 634# HTTP::Message::content might have killed it already via croak(). 635if (! $res) { 636 # $res was made null above if it was an error 637 stop_server $child; 638 639 # Start the server again 640 $child = start_server $srv; 641} 642 643# system.methodHelp with multiple arguments 644$req->content(RPC::XML::request->new('system.methodHelp', 645 [ 'system.identity', 646 'system.status' ])->as_string); 647alarm 120; 648$res = $UA->request($req); 649alarm 0; 650$res = ($res->is_error) ? q{} : $parser->parse($res->content); 651SKIP: { 652 if (! $res) { 653 skip 'Server response was error, cannot test', 1; 654 } 655 656 if ($res->is_fault) { 657 fail(failmsg($res->value->string, __LINE__)); 658 } else { 659 is(join(q{}, @{ ref($res) ? $res->value->value : [] }), 660 $srv->get_method('system.identity')->{help} . 661 $srv->get_method('system.status')->{help}, 662 'system.methodHelp("system.identity", "system.status") test'); 663 } 664} 665 666# If the response was any kind of error, kill and re-start the server, as 667# HTTP::Message::content might have killed it already via croak(). 668if (! $res) { 669 # $res was made null above if it was an error 670 stop_server $child; 671 672 # Start the server again 673 $child = start_server $srv; 674} 675 676# system.methodHelp with an invalid argument 677$req->content(RPC::XML::request->new('system.methodHelp', 678 'system.bad')->as_string); 679alarm 120; 680$res = $UA->request($req); 681alarm 0; 682$res = ($res->is_error) ? q{} : $parser->parse($res->content); 683SKIP: { 684 if (! $res) { 685 skip 'Server response was error, cannot test', 2; 686 } 687 688 ok($res->value->is_fault(), 689 'system.methodHelp returned fault for unknown method'); 690 like($res->value->string, qr/Method.*unknown/, 691 'system.methodHelp("system.bad") correct faultString'); 692} 693 694# If the response was any kind of error, kill and re-start the server, as 695# HTTP::Message::content might have killed it already via croak(). 696if (! $res) { 697 # $res was made null above if it was an error 698 stop_server $child; 699 700 # Start the server again 701 $child = start_server $srv; 702} 703 704# system.methodSignature 705$req->content(RPC::XML::request->new('system.methodSignature', 706 'system.methodHelp')->as_string); 707alarm 120; 708$res = $UA->request($req); 709alarm 0; 710$res = ($res->is_error) ? q{} : $parser->parse($res->content); 711SKIP: { 712 if (! $res) { 713 skip 'Server response was error, cannot test', 1; 714 } 715 716 $meth = $srv->get_method('system.methodHelp'); 717 if (! blessed $meth) { 718 fail(failmsg($meth, __LINE__)); 719 } else { 720 is(join(q{}, 721 sort map { join q{ } => @{$_} } 722 @{ ref($res) ? $res->value->value : [] }), 723 join(q{} => sort @{$meth->{signature}}), 724 'system.methodSignature("system.methodHelp") test'); 725 } 726} 727 728# If the response was any kind of error, kill and re-start the server, as 729# HTTP::Message::content might have killed it already via croak(). 730if (! $res) { 731 # $res was made null above if it was an error 732 stop_server $child; 733 734 # Start the server again 735 $child = start_server $srv; 736} 737 738# system.methodSignature, with an invalid request 739$req->content(RPC::XML::request->new('system.methodSignature', 740 'system.bad')->as_string); 741alarm 120; 742$res = $UA->request($req); 743alarm 0; 744$res = ($res->is_error) ? q{} : $parser->parse($res->content); 745SKIP: { 746 if (! $res) { 747 skip 'Server response was error, cannot test', 2; 748 } 749 750 ok($res->value->is_fault(), 751 'system.methodSignature returned fault for unknown method'); 752 like($res->value->string, qr/Method.*unknown/, 753 'system.methodSignature("system.bad") correct faultString'); 754} 755 756# If the response was any kind of error, kill and re-start the server, as 757# HTTP::Message::content might have killed it already via croak(). 758if (! $res) { 759 # $res was made null above if it was an error 760 stop_server $child; 761 762 # Start the server again 763 $child = start_server $srv; 764} 765 766# system.introspection 767$req->content(RPC::XML::request->new('system.introspection')->as_string); 768alarm 120; 769$res = $UA->request($req); 770alarm 0; 771$res = ($res->is_error) ? q{} : $parser->parse($res->content); 772SKIP: { 773 if (! $res) { 774 skip 'Server response was error, cannot test', 1; 775 } 776 777 if ($res->is_fault) { 778 fail(failmsg($res->value->string, __LINE__)); 779 } else { 780 $list = $res->value->value; 781 $bucket = 0; 782 %seen = (); 783 for my $result (@{$list}) { 784 if ($seen{$result->{name}}++) { 785 # If we somehow get the same name twice, that is a point off 786 $bucket++; 787 next; 788 } 789 790 $meth = $srv->get_method($result->{name}); 791 if ($meth) { 792 my $result_sig = join q{} => sort @{$result->{signature}}; 793 my $method_sig = join q{} => sort @{$meth->{signature}}; 794 # A point off unless all three of these match 795 if (($meth->{help} ne $result->{help}) || 796 ($meth->{version} ne $result->{version}) || 797 ($result_sig ne $method_sig)) { 798 $bucket++; 799 } 800 } else { 801 # That is also a point 802 $bucket++; 803 } 804 } 805 ok(! $bucket, 'system.introspection passed with no errors'); 806 } 807} 808 809# If the response was any kind of error, kill and re-start the server, as 810# HTTP::Message::content might have killed it already via croak(). 811if (! $res) { 812 # $res was made null above if it was an error 813 stop_server $child; 814 815 # Start the server again 816 $child = start_server $srv; 817} 818 819# system.multicall 820$req->content(RPC::XML::request->new('system.multicall', 821 [ { methodName => 'system.identity' }, 822 { methodName => 'system.listMethods', 823 params => [ 'intro' ] } 824 ])->as_string); 825alarm 120; 826$res = $UA->request($req); 827alarm 0; 828$res = ($res->is_error) ? q{} : $parser->parse($res->content); 829SKIP: { 830 if (! $res) { 831 skip 'Server response was error, cannot test', 2; 832 } 833 834 if ($res->is_fault) { 835 fail(failmsg($res->value->string, __LINE__)); 836 fail(failmsg($res->value->string, __LINE__)); 837 } else { 838 $res = $res->value->value; 839 is($res->[0], $srv->product_tokens, 840 'system.multicall response elt [0] is correct'); 841 is((ref($res->[1]) eq 'ARRAY' ? $res->[1]->[0] : q{}), 842 'system.introspection', 843 'system.multicall response elt [1][0] is correct'); 844 } 845} 846 847# If the response was any kind of error, kill and re-start the server, as 848# HTTP::Message::content might have killed it already via croak(). 849if (! $res) { 850 # $res was made null above if it was an error 851 stop_server $child; 852 853 # Start the server again 854 $child = start_server $srv; 855} 856 857# system.multicall, with an attempt at illegal recursion 858$req->content(RPC::XML::request->new('system.multicall', 859 [ { methodName => 'system.identity' }, 860 { methodName => 'system.multicall', 861 params => [ 'intro' ] } 862 ])->as_string); 863alarm 120; 864$res = $UA->request($req); 865alarm 0; 866$res = ($res->is_error) ? q{} : $parser->parse($res->content); 867SKIP: { 868 if (! $res) { 869 skip 'Server response was error, cannot test', 2; 870 } 871 872 $res = $res->value; 873 ok($res->is_fault, 874 'system.multicall returned fault on attempt at recursion'); 875 like($res->string, qr/Recursive/, 876 'system.multicall recursion attempt set correct faultString'); 877} 878 879# If the response was any kind of error, kill and re-start the server, as 880# HTTP::Message::content might have killed it already via croak(). 881if (! $res) { 882 # $res was made null above if it was an error 883 stop_server $child; 884 885 # Start the server again 886 $child = start_server $srv; 887} 888 889# system.multicall, with bad data on one of the call specifications 890$req->content(RPC::XML::request->new('system.multicall', 891 [ { methodName => 'system.identity' }, 892 { methodName => 'system.status', 893 params => 'intro' } 894 ])->as_string); 895alarm 120; 896$res = $UA->request($req); 897alarm 0; 898$res = ($res->is_error) ? q{} : $parser->parse($res->content); 899SKIP: { 900 if (! $res) { 901 skip 'Server response was error, cannot test', 2; 902 } 903 904 $res = $res->value; 905 ok($res->is_fault, 906 'system.multicall returned fault when passed a bad param array'); 907 like($res->string, qr/value for.*params.*not an array/i, 908 'system.multicall bad param array set correct faultString'); 909} 910 911# If the response was any kind of error, kill and re-start the server, as 912# HTTP::Message::content might have killed it already via croak(). 913if (! $res) { 914 # $res was made null above if it was an error 915 stop_server $child; 916 917 # Start the server again 918 $child = start_server $srv; 919} 920 921# system.multicall, with bad data in the request itself 922$req->content(RPC::XML::request->new('system.multicall', 923 [ { methodName => 'system.identity' }, 924 'This is not acceptable data' 925 ])->as_string); 926alarm 120; 927$res = $UA->request($req); 928alarm 0; 929$res = ($res->is_error) ? q{} : $parser->parse($res->content); 930SKIP: { 931 if (! $res) { 932 skip 'Server response was error, cannot test', 2; 933 } 934 935 $res = $res->value; 936 ok($res->is_fault, 'system.multicall returned fault on bad input'); 937 like($res->string, qr/one.*array element.*not a struct/i, 938 'system.multicall bad input set correct faultString'); 939} 940 941# If the response was any kind of error, kill and re-start the server, as 942# HTTP::Message::content might have killed it already via croak(). 943if (! $res) { 944 # $res was made null above if it was an error 945 stop_server $child; 946 947 # Start the server again 948 $child = start_server $srv; 949} 950 951# system.status, once more, to check the total_requests value 952$req->content(RPC::XML::request->new('system.status')->as_string); 953alarm 120; 954$res = $UA->request($req); 955alarm 0; 956$res = ($res->is_error) ? q{} : $parser->parse($res->content); 957SKIP: { 958 if (! $res) { 959 skip 'Server response was error, cannot test', 1; 960 } 961 962 $res = $res->value->value; 963 is($res->{total_requests}, 20, 'system.status, final request tally'); 964} 965 966# This time we have to stop the server regardless of whether the response was 967# an error. We're going to add some more methods to test some of the error code 968# and other bits in RPC::XML::Procedure. 969stop_server $child; 970$srv->add_method({ 971 type => 'procedure', 972 name => 'argcount.p', 973 signature => [ 'int' ], 974 code => sub { return scalar @_; }, 975}); 976$srv->add_method({ 977 name => 'argcount.m', 978 signature => [ 'int' ], 979 code => sub { return scalar @_; }, 980}); 981$srv->add_method({ 982 type => 'function', 983 name => 'argcount.f', 984 code => sub { return scalar @_; }, 985}); 986$srv->add_method({ 987 name => 'die1', 988 signature => [ 'int' ], 989 code => sub { die "die\n"; }, 990}); 991{ 992 ## no critic(RequireCarping) 993 $srv->add_method({ 994 name => 'die2', 995 signature => [ 'int' ], 996 code => sub { die RPC::XML::fault->new(999, 'inner fault'); }, 997 }); 998} 999 1000# Start the server again, with the new methods 1001$child = start_server $srv; 1002 1003# First, call the argcount.? routines, to see that we are getting the correct 1004# number of args passed in. Up to now, everything running on $srv has been in 1005# the RPC::XML::Method class. This will test some of the other code. 1006my @returns = (); 1007local $SIG{ALRM} = sub { $bucket++ }; 1008for my $type (qw(p m f)) { 1009 $req->content(RPC::XML::request->new("argcount.$type")->as_string); 1010 $bucket = 0; 1011 alarm 120; 1012 $res = $UA->request($req); 1013 alarm 0; 1014 if ($bucket) { 1015 push @returns, 'timed-out'; 1016 } else { 1017 $res = $parser->parse($res->content); 1018 if (ref($res) ne 'RPC::XML::response') { 1019 push @returns, 'parse-error'; 1020 } else { 1021 push @returns, $res->value->value; 1022 } 1023 } 1024} 1025# Finally, test what we got from those three calls: 1026is(join(q{,} => @returns), '0,1,0', 'Arg-count testing of procedure types'); 1027 1028# While we're at it... test that a ::Function can take any args list 1029$req->content(RPC::XML::request->new('argcount.f', 1, 1, 1)->as_string); 1030$bucket = 0; 1031alarm 120; 1032$res = $UA->request($req); 1033alarm 0; 1034SKIP: { 1035 if ($bucket) { 1036 skip 'Second call to argcount.f timed out', 1; 1037 } else { 1038 $res = $parser->parse($res->content); 1039 if (ref($res) ne 'RPC::XML::response') { 1040 skip 'Second call to argcount.f failed to parse', 1; 1041 } else { 1042 is($res->value->value, 3, 'A function takes any argslist'); 1043 } 1044 } 1045} 1046 1047# And test that those that aren't ::Function recognize bad parameter lists 1048$req->content(RPC::XML::request->new('argcount.p', 1, 1, 1)->as_string); 1049$bucket = 0; 1050alarm 120; 1051$res = $UA->request($req); 1052alarm 0; 1053SKIP: { 1054 if ($bucket) { 1055 skip 'Second call to argcount.f timed out', 1; 1056 } else { 1057 $res = $parser->parse($res->content); 1058 if (ref($res) ne 'RPC::XML::response') { 1059 skip 'Second call to argcount.f failed to parse', 1; 1060 } else { 1061 if (! $res->is_fault) { 1062 skip 'Test did not return fault, cannot test', 2; 1063 } 1064 1065 is($res->value->code, 201, 1066 'Bad params list test: Correct faultCode'); 1067 like($res->value->string, 1068 qr/no matching signature for the argument list/, 1069 'Bad params list test: Correct faultString'); 1070 } 1071 } 1072} 1073 1074# Test behavior when the called function throws an exception 1075my %die_tests = ( 1076 die1 => { 1077 code => 300, 1078 string => "Code execution error: Method die1 returned error: die\n", 1079 }, 1080 die2 => { 1081 code => 999, 1082 string => 'inner fault', 1083 }, 1084); 1085for my $test (sort keys %die_tests) { 1086 $req->content(RPC::XML::request->new($test)->as_string); 1087 $bucket = 0; 1088 alarm 120; 1089 $res = $UA->request($req); 1090 alarm 0; 1091 SKIP: { 1092 if ($bucket) { 1093 skip "Test '$test' timed out, cannot test results", 2; 1094 } else { 1095 $res = $parser->parse($res->content); 1096 if (ref($res) ne 'RPC::XML::response') { 1097 skip "Test '$test' failed to parse, cannot test results", 2; 1098 } else { 1099 if (! $res->is_fault) { 1100 skip "Test '$test' did not return fault, cannot test", 2; 1101 } 1102 1103 is($res->value->code, $die_tests{$test}{code}, 1104 "Test $test: Correct faultCode"); 1105 is($res->value->string, $die_tests{$test}{string}, 1106 "Test $test: Correct faultString"); 1107 } 1108 } 1109 } 1110} 1111 1112# Don't leave any children laying around 1113stop_server $child, 'final'; 1114 1115exit; 1116 1117sub find_port_in_use { 1118 my $start_at = shift; 1119 $start_at ||= 80; 1120 1121 for my $port ($start_at .. ($start_at + 1000)) { 1122 my $sock = IO::Socket->new( 1123 Domain => AF_INET, 1124 PeerAddr => 'localhost', 1125 PeerPort => $port 1126 ); 1127 return $port if ref $sock; 1128 } 1129 1130 return -1; 1131} 1132