t/30_method.t - metacpan.org

#!/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);
use RPC::XML::Procedure;

plan tests => 81;

($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');
}

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

exit 0;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)