Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

file 484 lines (420 sloc) 17.987 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 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484
#!/usr/bin/perl

# Test the RPC::XML::Procedure class (and the ::Method and ::Function classes)

use strict;
use warnings;
use vars qw($obj $obj2 $flag $dir $vol $tmp $tmpfile $fh);

use File::Spec;
use Test::More;

use RPC::XML qw($ALLOW_NIL RPC_INT RPC_DATETIME_ISO8601 time2iso8601);
use RPC::XML::Procedure;

plan tests => 87;

($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
$tmpfile = File::Spec->catfile($dir, "tmp_xpl_$$.xpl");

# 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::Procedure. As such, we are not testing
# any part of the RPC::XML::Server class here. Only the code for managing
# methods.

# Basic new() success, simple accessors and successful calling
$obj = RPC::XML::Procedure->new({ name => 'test.test',
                                  signature => [ 'int' ],
                                  code => sub { $flag = 1; } });
isa_ok($obj, 'RPC::XML::Procedure', '$obj');
SKIP: {
    skip 'Cannot test without object', 15
        unless (ref($obj) eq 'RPC::XML::Procedure');

    # Arguments here don't matter, just testing that trying to call new() on a
    # referent fails:
    $obj2 = $obj->new();
    like($obj2, qr/Must be called as a static method/,
         'Correct error message from bad new()');

    ok(($obj->name() eq 'test.test') &&
       ($obj->namespace() eq '') &&
       (scalar(@{$obj->signature}) == 1) &&
       ($obj->signature->[0] eq 'int'),
       'Basic accessors');
    $flag = 0;
    eval { $obj->code->(); };
    ok((! $@) && $flag, 'Calling the code');

    # What about the missing values?
    is($obj->help(), '', 'Null value for help()');
    is($obj->namespace(), '', 'Null value for namespace()');
    is($obj->version(), 0, 'Zero value for version()');
    is($obj->hidden(), 0, 'Zero value for hidden()');

    # Try changing the attributes that can change:
    $obj->help('help');
    is($obj->help(), 'help', 'help() changes correctly');
    $obj->version('1.1.1');
    is($obj->version(), '1.1.1', 'version() changes correctly');
    $obj->hidden(1);
    is($obj->hidden(), 1, 'hidden() changes correctly');
    my $sub = sub { 'foo' };
    $obj->code($sub);
    is($obj->code(), $sub, 'code() changes correctly');
    # Try a value that should be rejected
    $obj->code([]);
    is($obj->code(), $sub, 'code() did not change to a bad value');
    # Changing signature() is tricky
    $obj->signature([ 'int int', 'string string', 'double double' ]);
    is(scalar(@{$obj->signature}), 3, 'signature() changes correctly');
    # This one should fail
    my $err = $obj->signature([ qw(int double) ]);
    like($err, qr/Cannot have two different return values/,
         'signature() failed correctly on ambiguous data');
    is(scalar(@{$obj->signature}), 3, 'signature() reverted to old value');
    # This should fail for a different reason
    $err = $obj->signature(1);
    like($err, qr/Bad value '1'/, 'signature() failed correctly on bad input');

    # What happens if I try reload() on it?
    $err = $obj->reload();
    like($err, qr/No file associated with method/, 'reload() fails OK');
}

# Basic new() using faux hash table input
$obj = RPC::XML::Procedure->new(
    name => 'test.test',
    hidden => 1,
    signature => 'int int',
    signature => [ qw(string string) ],
    code => sub { 1; }
);
isa_ok($obj, 'RPC::XML::Procedure', '$obj<2>');
SKIP: {
    skip 'Cannot test without object', 2
        unless (ref($obj) eq 'RPC::XML::Procedure');

    ok(($obj->name() eq 'test.test') &&
       ($obj->namespace() eq '') &&
       (scalar(@{$obj->signature}) == 2) &&
       ($obj->signature->[0] eq 'int int') &&
       ($obj->signature->[1] eq 'string string'),
       'Basic accessors <2>');
    $flag = eval { $obj->code->(); };
    ok((! $@) && $flag, 'Calling the code <2>');
}

# This should succeed, but "hidden" is false because the second overrides the
# first.
$obj = RPC::XML::Procedure->new(
    name => 'test.test',
    hidden => 1,
    hidden => 0,
    signature => 'int int',
    signature => [ qw(string string) ],
    code => sub { 1; }
);
isa_ok($obj, 'RPC::XML::Procedure', '$obj<3>');
is($obj->hidden(), 0, 'hidden() is correctly false');

# This should fail due to missing name
$obj = RPC::XML::Procedure->new({ code => sub { 1; } });
like($obj, qr/Missing required data \(name or code\)/,
     'Correct constructor failure [1]');

# This should fail due to missing code
$obj = RPC::XML::Procedure->new({ name => 'test.test1' });
like($obj, qr/Missing required data \(name or code\)/,
     'Correct constructor failure [2]');

# This should fail due to missing information (the signature)
$obj = RPC::XML::Method->new({ name => 'test.test2',
                               code => sub { $flag = 2; } });
like($obj, qr/Missing required data \(signatures\)/,
     'Correct constructor failure [3]');

# This one fails because the signatures have a collision
$obj = RPC::XML::Method->new({ name => 'test.test2',
                               signature => [ 'int int',
                                              'string int' ],
                               code => sub { $flag = 2; } });
like($obj, qr/two different return values for one set of params/,
     'Correct constructor failure [4]');

# Fails because of a null signature
$obj = RPC::XML::Method->new({ name => 'test.test2',
                               signature => [ '' ],
                               code => sub { $flag = 2; } });
like($obj, qr/Invalid signature, cannot be null/,
     'Correct constructor failure [5]');

# Fails because of an unknown type in the return value slot
$obj = RPC::XML::Method->new({ name => 'test.test2',
                               signature => [ 'frob int' ],
                               code => sub { $flag = 2; } });
like($obj, qr/Unknown return type 'frob'/,
     'Correct constructor failure [6]');

# Fails because of an unknown type in the args-list
$obj = RPC::XML::Method->new({ name => 'test.test2',
                               signature => [ 'int string frob int' ],
                               code => sub { $flag = 2; } });
like($obj, qr/One or more invalid types in signature/,
     'Correct constructor failure [7]');

# This file will not load due to missing required information
$obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_bad_1.xpl'));
like($obj, qr/missing/i, 'Bad XPL [1] not loaded');

# This file will not load due to an XML parsing error
$obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_bad_2.xpl'));
like($obj, qr/error parsing/i, 'Bad XPL [2] not loaded');

# And the third bowl of porridge was _just_ _right_...
$obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_good_1.xpl'));
isa_ok($obj, 'RPC::XML::Method', '$obj');

SKIP: {
    skip 'Cannot test without a value $obj', 20
        if (ref($obj) ne 'RPC::XML::Method');

    # Check the basics
    ok(ref($obj) && $obj->name() && scalar(@{$obj->signature}) &&
       $obj->hidden() && $obj->version() && $obj->help(),
       'Good XPL load, basic accessors');

    # Is code() the type of ref we expect?
    ok(ref($obj) && (ref($obj->code) eq 'CODE'),
       'Good XPL load, code() accessor');

    # This looks more complex than it is. The code returns this specific key,
    # but because this is a RPC::XML::Method, it expects a ref as the first
    # argument, representing a RPC::XML::Server (or derived) instance.
    is($obj->code->(undef, { method_name => $obj->name }), $obj->name(),
       'Good XPL load, code() invocation');

    # Time to test cloning
    $obj2 = $obj->clone;

    # Did it?
    isa_ok($obj2, ref($obj), '$obj2');
  SKIP: {
        skip 'Clone failed, cannot test without second object', 4
            if (ref($obj2) ne ref $obj);

        # Primary accessors/data
        ok(($obj->name() eq $obj2->name()) &&
           ($obj->version() eq $obj2->version()) &&
           ($obj->help() eq $obj2->help()),
           'Compare accessors of clone and source');
        # Are the actual listrefs of signatures different?
        isnt($obj->signature(), $obj2->signature(),
         'Clone signature() accessor has different listref');
        # And yet, the contents are the same?
        ok((@{$obj->signature} == @{$obj2->signature}) &&
           # There's only one signature in the list
           ($obj->signature->[0] eq $obj2->signature->[0]),
           'Clone signature() value is same despite this');
        # Lastly, and very importantly, the coderefs are still the same
        is($obj->code(), $obj2->code(),
           'Clone code() ref value is same as source');

        undef $obj2; # Don't need it anymore
    }

    # Now let's play around with signatures a bit

    # Basic test of match_signature()
    is($obj->match_signature(''), 'string', 'Test match_signature()');

    # Add a new signature, simple
    is($obj->add_signature('int int'), $obj,
       'Adding via add_signature() returns obj ref');
    # There should now be two
    is(scalar(@{$obj->{signature}}), 2,
       'Number of signatures after add_signature()');
    # Does the new one match OK?
    is($obj->match_signature('int'), 'int', 'New signature matches correctly');
    # Try matching it with an array-ref
    is($obj->match_signature([ 'int' ]), 'int', 'Signature matches arrayref');

    # This addition should fail due to ambiguity
    isnt($tmp = $obj->add_signature([ 'double', 'int' ]), $obj,
         'Correct failure of adding ambiguous signature');
    # But did it fail for the right reasons?
    like($tmp, qr/make_sig_table/,
         'Signature failure returned correct message');

    # Test deletion
    is($obj->delete_signature('int int'), $obj, 'Test delete_signature()');
    # Which means checking the count again
    is(scalar(@{$obj->{signature}}), 1,
       'Correct signature count after delete');
    # Try deleting the last signature
    my $err = $obj->delete_signature('string');
    like($err, qr/Cannot delete last signature/,
         'Deleting last signature fails');
    # Note that deleting a non-existent signature "succeeds"
    is($obj->delete_signature([ 'int' ]), $obj,
       'Attempt to delete non-existent signature');
    is(scalar(@{$obj->{signature}}), 1,
       'Correct signature count after useless delete');

    # We're done with this one for now.
    undef $obj;
}

# Check the other two proc-types being loaded from files:
$obj = RPC::XML::Procedure->new(File::Spec->catfile($dir, 'meth_good_2.xpl'));
isa_ok($obj, 'RPC::XML::Procedure', '$obj');

# This should return an RPC::XML::Function object, despite being called via
# RPC::XML::Procedure.
$obj = RPC::XML::Procedure->new(File::Spec->catfile($dir, 'meth_good_3.xpl'));
isa_ok($obj, 'RPC::XML::Function', '$obj');

# With this later object, test some of the routines that are overridden in
# RPC::XML::Function:
SKIP: {
    skip 'Cannot test without RPC::XML::Function object', 8
        if (ref($obj) ne 'RPC::XML::Function');

    ok((ref($obj->signature) eq 'ARRAY' && (@{$obj->signature} == 1)),
       'RPC::XML::Function valid return from signature() <1>');
    is($obj->add_signature('int int'), $obj,
       'RPC::XML::Function valid add_signature');
    ok((ref($obj->signature) eq 'ARRAY' && (@{$obj->signature} == 1)),
       'RPC::XML::Function valid return from signature() <2>');
    is($obj->match_signature('int'), 'scalar',
       'RPC::XML::Function correct signature match');
    is($obj->delete_signature('int int'), $obj,
       'RPC::XML::Function valid delete_signature');
    ok((ref($obj->signature) eq 'ARRAY' && (@{$obj->signature} == 1)),
       'RPC::XML::Function valid return from signature() <3>');
    # Can we clone it?
    $obj2 = $obj->clone();
    isa_ok($obj2, ref($obj), '$obj2');
    ok(($obj->name() eq $obj2->name()) &&
       ($obj->version() eq $obj2->version()) &&
       ($obj->help() eq $obj2->help()),
       'Compare accessors of clone and source');
    is($obj->code(), $obj2->code(),
       'Clone code() ref value is same as source');
}

# But this should fail, as only RPC::XML::Procedure is allowed to act as a
# factory constructor:
$obj = RPC::XML::Method->new(File::Spec->catfile($dir, 'meth_good_3.xpl'));
like($obj, qr/must match this calling class/,
     'Correct error message on bad constructor call');

# Test procedures that utilize nil data-types
$ALLOW_NIL = 1;

# First a simple nil-return
$obj = RPC::XML::Procedure->new({ name => 'test.test_nil',
                                  signature => [ 'nil' ],
                                  code => sub { return; } });
isa_ok($obj, 'RPC::XML::Procedure');
SKIP: {
    skip 'Cannot test without object', 2
        unless (ref($obj) eq 'RPC::XML::Procedure');

    my $val;
    eval { $val = $obj->call({}); };
    ok(! $@, 'Calling test.test_nil');
    isa_ok($val, 'RPC::XML::nil', 'Return value');
}

# Nil return from a proc with argument(s)
$obj = RPC::XML::Procedure->new({ name => 'test.test_nil2',
                                  signature => [ 'nil int' ],
                                  code =>
                                  sub { my $int = shift; return; } });
isa_ok($obj, 'RPC::XML::Procedure');
SKIP: {
    skip 'Cannot test without object', 2
        unless (ref($obj) eq 'RPC::XML::Procedure');

    my $val;
    eval { $val = $obj->call({}, RPC_INT 1); };
    ok(! $@, 'Calling test.test_nil2');
    isa_ok($val, 'RPC::XML::nil', 'Return value');
}

# Return value properly ignored when the signature types it as nil
$obj = RPC::XML::Procedure->new({ name => 'test.test_nil3',
                                  signature => [ 'nil' ],
                                  code => sub { 1; } });
isa_ok($obj, 'RPC::XML::Procedure');
SKIP: {
    skip 'Cannot test without object', 2
        unless (ref($obj) eq 'RPC::XML::Procedure');

    my $val;
    eval { $val = $obj->call({}); };
    ok(! $@, 'Calling test.test_nil3');
    isa_ok($val, 'RPC::XML::nil', 'Return value');
}

# Make sure that the presence of nil in a signature doesn't interfere with
# proper look-ups
$obj = RPC::XML::Procedure->new({ name => 'test.test_nil4',
                                  signature => [ 'nil int' ],
                                  code => sub { return; } });
isa_ok($obj, 'RPC::XML::Procedure');
SKIP: {
    skip 'Cannot test without object', 2
        unless (ref($obj) eq 'RPC::XML::Procedure');

    is($obj->match_signature('int'), 'nil', 'Test match_signature() with nil');
    ok(! $obj->match_signature('string'),
       'Test match_signature() with nil [2]');
}

# This one will be fun. To truly test the reload() method, I need a file to
# actually change. So create a file, load it as XPL, rewrite it and reload it.
if (! (open $fh, '>', $tmpfile))
{
    die "Error opening $tmpfile for writing: $!";
}
print {$fh} <<END;
<?xml version="1.0"?>
<!DOCTYPE proceduredef SYSTEM "rpc-method.dtd">
<proceduredef>
<name>test</name>
<version>1.0</version>
<signature>string</signature>
<help>Simple test method for RPC::XML::Procedure class</help>
<code language="perl">sub test { 'foo' }</code>
</proceduredef>
END
close $fh;
$obj = RPC::XML::Procedure->new($tmpfile);
isa_ok($obj, 'RPC::XML::Procedure', '$obj');
SKIP: {
    skip 'Cannot test without object', 3
        if (ref($obj) ne 'RPC::XML::Procedure');

    if (! (open $fh, '>', $tmpfile))
    {
        die "Error opening $tmpfile for writing: $!";
    }
    print {$fh} <<END;
<?xml version="1.0"?>
<!DOCTYPE proceduredef SYSTEM "rpc-method.dtd">
<proceduredef>
<name>test</name>
<version>1.0</version>
<signature>string</signature>
<help>Simple test method for RPC::XML::Procedure class</help>
<code language="perl">sub test { 'bar' }</code>
</proceduredef>
END
    close $fh;
    is($obj->reload(), $obj, 'reload() returns ok');
    my $val;
    eval { $val = $obj->call(); };
    is($val->value, 'bar', 'Reloaded method gave correct value');

    # Try to reload again, after unlinking the file
    unlink $tmpfile;
    $val = $obj->reload();
    like($val, qr/Error loading/, 'Correct error from reload() after unlink');
}

# Per RT#71452, I learned that I never tested dateTime.iso8601 in any of the
# signatures/calls, and that as of release 0.76, I may have bugs...

undef $obj;
$obj = RPC::XML::Procedure->new(
    name => 'test.iso8601',
    signature => 'string dateTime.iso8601',
    code => sub {
        my $date = shift;
        return substr($date, 0, 4);
    },
);
isa_ok($obj, 'RPC::XML::Procedure', '$obj');
SKIP: {
    skip 'Cannot test without object', 2
        unless (ref($obj) eq 'RPC::XML::Procedure');

    is($obj->match_signature('dateTime.iso8601'), 'string',
       'Test match_signature() with a dateTime.iso8601 input');
    my $time = time2iso8601;
    my $year = substr $time, 0, 4;
    is($obj->call({}, RPC_DATETIME_ISO8601 $time)->value, $year,
       'Test a call with a dateTime.iso8601 argument');
}

$obj = RPC::XML::Procedure->new(
    name => 'test.iso8601',
    signature => 'dateTime.iso8601 int',
    code => sub {
        my $time = shift;
        return time2iso8601($time);
    },
);
isa_ok($obj, 'RPC::XML::Procedure', '$obj');
SKIP: {
    skip 'Cannot test without object', 2
        unless (ref($obj) eq 'RPC::XML::Procedure');

    is($obj->match_signature('int'), 'dateTime.iso8601',
       'Test match_signature() with a dateTime.iso8601 output');
    my $time = time;
    is($obj->call({}, RPC_INT $time)->value, time2iso8601($time),
       'Test a call with a dateTime.iso8601 return value');
}

END
{
    # Just in case...
    if (-e $tmpfile)
    {
        unlink $tmpfile;
    }
}

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