Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 245 lines (205 sloc) 8.683 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
#!/usr/bin/perl

# Test the RPC::XML::Client class

use strict;
use vars qw($dir $vol $srv $child $port $cli $res $flag);
use subs qw(start_server find_port);

use Test::More;

use LWP;
require File::Spec;

require RPC::XML::Server;
require RPC::XML::Client;

($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
require File::Spec->catfile($dir, 'util.pl');

plan tests => 33;

# The organization of the test suites is such that we assume anything that
# runs before the current suite is 100%. Thus, no consistency checks on
# any other classes are done, only on the data and return values of this
# class under consideration, RPC::XML::Client. In this particular case, this
# means that we can safely use RPC::XML::Server in creating a suitable test
# environment.

# Start with some very basic things, before actually firing up a live server.
$cli = RPC::XML::Client->new();
ok(! ref $cli, 'RPC::XML::Client::new without endpoint fails');
like($cli, qr/Missing location argument/, 'Correct error message set');

die "No usable port found between 9000 and 10000, skipping"
    if (($port = find_port) == -1);
$cli = RPC::XML::Client->new("http://localhost:$port");
$cli->timeout(5); #to prevent long waiting for non-existing server
isa_ok($cli, 'RPC::XML::Client', '$cli');

# With no server yet at that port, test the failure modes
ok((! $cli->simple_request('system.identity')) && $RPC::XML::ERROR,
   'Calling a server method without a server sets $RPC::XML::ERROR');
ok(! ref($cli->send_request('system.identity')),
   'send_request returns a non-ref value when there is no server');
$res = $cli->send_request();
ok(! ref $res, 'Call to send_request without a method name fails');
like($res, qr/No request object/, 'Correct error message set');
$res = $cli->send_request('bad^method');
ok(! ref $res, 'Call to send_request with a bad method name fails');
like($res, qr/Error creating RPC::XML::request object/,
     'Correct error message set');

# Test the error-handling callback
$cli->error_handler(sub { $res++ });
$res = 0;
$cli->simple_request('system.identity');
ok($res, 'error_handler callback system');

# Test clearing it
$cli->error_handler(undef);
$res = 0;
$cli->simple_request('system.identity');
ok(! $res, 'Clearing the error_handler callback system');

# Test setting and clearing both with combined_handler
$cli->combined_handler(sub { 1 });
ok($cli->error_handler() && ($cli->error_handler() eq $cli->fault_handler()),
   'combined_handler set both error_handler and fault_handler');

$cli->combined_handler(undef);
ok(! ($cli->error_handler() or $cli->fault_handler()),
   'combined_handler clears both error_handler and fault_handler');

# Check the getting/setting of the timeout() value on the underlying UA
is($cli->timeout(), $cli->useragent->timeout(),
   'Client timeout() method, fetching');
$cli->timeout(60);
is($cli->useragent->timeout(), 60, 'Client timeout() method, setting');

# Cool so far. Create and spawn the server.
$srv = RPC::XML::Server->new(host => 'localhost', port => $port);
die "Failed to create server: $srv, stopped" unless (ref $srv);
$child = start_server($srv);

# NOW, this should work. Also, set $RPC::XML::ERROR to see if it clears
$RPC::XML::ERROR = 'foo';
is($cli->simple_request('system.identity'), $srv->product_tokens,
   'simple_request/system.identity returns correct value');
ok(! $RPC::XML::ERROR,
   'simple_request/system.identity left $RPC::XML::ERROR empty');

# Using send_request should yield an RPC::XML::string object with that value
$res = $cli->send_request('system.identity');
isa_ok($res, 'RPC::XML::string', 'system.identity response');
SKIP: {
    skip 'Client response not a RPC::XML data object', 1
        unless ref $res;
    is($res->value, $srv->product_tokens,
       'system.identity response is correct');
}

unless (ref $res)
{
    # Assume that if an error occurred, the server might be in a confused
    # state. Kill and restart it.
    stop_server($child);
    $child = start_server($srv);
}

# See what comes back from bad (but successful) calls
$res = $cli->simple_request('system.bad');
isa_ok($res, 'HASH', 'simple_request/system.bad response');
SKIP: {
    skip 'Client response was not a RPC::XML data object', 2
        unless ref $res;
    is(join(';', sort keys %$res), 'faultCode;faultString',
       'simple_request/system.bad hashref has correct keys');
    like($res->{faultString}, qr/Unknown method/,
         'simple_request/system.bad set correct faultString');
}

unless (ref $res)
{
    # Assume that if an error occurred, the server might be in a confused
    # state. Kill and restart it.
    stop_server($child);
    $child = start_server($srv);
}

# As opposed to a fault object:
$res = $cli->send_request('system.bad');
isa_ok($res, 'RPC::XML::fault', 'send_request/system.bad response');
SKIP: {
    skip 'Client response not a RPC::XML data object', 1
        unless ref $res;
    like($res->string, qr/Unknown method/,
         'send_request/system.bad set correct string() property');
}

unless (ref $res)
{
    # Assume that if an error occurred, the server might be in a confused
    # state. Kill and restart it.
    stop_server($child);
    $child = start_server($srv);
}

# Give the fault handler a whirl -- note the return value is the fault object
$cli->fault_handler(sub { $flag++ if ((ref($_[0]) eq 'RPC::XML::fault') &&
                                      ($_[0]->string =~ /Unknown method/));
                          $_[0] });
$flag = 0;
$res = $cli->send_request('system.bad');
# Did the callback run correctly?
ok($flag, 'fault_handler correctly set $flag');
# Is the value returned correct?
isa_ok($res, 'RPC::XML::fault', 'fault_handler returned value');
SKIP: {
    skip 'Client response not a RPC::XML data object', 1
        unless ref $res;
    like($res->string, qr/Unknown method/,
         'fault_handler object has correct faultString');
}

unless (ref $res)
{
    # Assume that if an error occurred, the server might be in a confused
    # state. Kill and restart it.
    stop_server($child);
    $child = start_server($srv);
}

# Last tests-- is the url() method working?
like($cli->uri, qr|http://localhost(\.localdomain)?:$port/?|,
     'RPC::XML::Client::uri method return value is correct');

# does calling it as an accesor change it at all?
$cli->uri('http://www.oreilly.com/RPC');
is($cli->uri, 'http://www.oreilly.com/RPC',
   'RPC::XML::Client::uri changes as expected');

# Kill the server long enough to add a new method
stop_server($child);

use Digest::MD5;

$srv->add_method({ name => 'cmpImg',
                   signature => [ 'boolean base64 base64' ],
                   code => sub {
                       my ($self, $img1, $img2) = @_;

                       return (Digest::MD5::md5_hex($img1) eq
                               Digest::MD5::md5_hex($img2));
                   } });
$child = start_server($srv);

use Symbol;
my ($fh1, $fh2) = (gensym, gensym);

SKIP: {
    skip 'Message-to-file spooling broken with LWP < 5.801', 4
        unless ($LWP::VERSION > 5.800);

    open($fh1, '<' . File::Spec->catfile($dir, 'svsm_text.gif'));
    open($fh2, '<' . File::Spec->catfile($dir, 'svsm_text.gif'));
  SKIP: {
        skip "Error opening svsm_text.gif: $!", 4
            unless ($fh1 and $fh2);
        # Setting the size threshhold to the size of the GIF will guarantee a
        # file spool, since we're sending the GIF twice.
        $cli->message_file_thresh(-s $fh1);
        $cli->message_temp_dir($dir);

        $cli->uri("http://localhost:$port/");
        $res = $cli->send_request(cmpImg =>
                                  RPC::XML::base64->new($fh1),
                                  RPC::XML::base64->new($fh2));
        isa_ok($res, 'RPC::XML::boolean', 'cmpImg return value');
      SKIP: {
            skip 'Client response not a RPC::XML data object', 1
                unless ref($res);
            ok($res->value, 'cmpImg, file spooling, correct return');
        }

        # Force the compression threshhold down, to test that branch
        $cli->compress_requests(1);
        $cli->compress_thresh(-s $fh1);
        $res = $cli->send_request(cmpImg =>
                                  RPC::XML::base64->new($fh1),
                                  RPC::XML::base64->new($fh2));
        isa_ok($res, 'RPC::XML::boolean', 'cmpImg return value');
      SKIP: {
            skip 'Client response not a RPC::XML data object', 1
                unless ref($res);
            ok($res->value, 'cmpImg, file spooling, correct return');
        }
    }
}

# Kill the server before exiting
stop_server($child);

exit;
Something went wrong with that request. Please try again.