Permalink
Browse files

Last round of RPC::XML::Procedure test coverage.

This is mostly in t/40_server.t, though some bugs were found and addressed
in the modules and in t/30_method.t.
  • Loading branch information...
1 parent ffb4ccf commit 105d7d2a5f38a208772f34ebf990bac428abf129 @rjray committed Jul 18, 2011
Showing with 266 additions and 60 deletions.
  1. +57 −54 lib/RPC/XML/Procedure.pm
  2. +8 −3 lib/RPC/XML/Server.pm
  3. +32 −2 t/30_method.t
  4. +169 −1 t/40_server.t
View
@@ -50,7 +50,7 @@ package RPC::XML::Procedure;
use 5.008008;
use strict;
use warnings;
-use vars qw($VERSION);
+use vars qw($VERSION %VALID_TYPES);
use subs qw(
new name code signature help version hidden add_signature
delete_signature make_sig_table match_signature reload load_xpl_file
@@ -64,9 +64,16 @@ use RPC::XML 'smart_encode';
# This module also provides RPC::XML::Method
## no critic (ProhibitMultiplePackages)
-$VERSION = '1.27';
+$VERSION = '1.28';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)
+# This should match the set of type-classes defined in RPC::XML.pm. Note that
+# we use "datetime_iso8601" instead of "dateTime.iso8601", because that is how
+# it has to be in the signature.
+%VALID_TYPES = map { $_ => 1 }
+ (qw(int i4 i8 double string boolean datetime_iso8601 nil array struct
+ base64));
+
###############################################################################
#
# Sub Name: new
@@ -98,13 +105,15 @@ sub new
if (ref $argz[0])
{
# 1. A hashref containing all the relevant keys
+
+ # Start wtih the defaults for the optional keys
$data = {
namespace => q{},
version => 0,
hidden => 0,
help => q{},
- signature => [],
};
+ # Copy everything from the hash, don't try to use it directly
for (keys %{$argz[0]}) { $data->{$_} = $argz[0]->{$_} }
}
elsif (@argz == 1)
@@ -189,6 +198,8 @@ sub new
# Arguments: NAME IN/OUT TYPE DESCRIPTION
# $self in ref Object of this class
#
+# Globals: %VALID_TYPES
+#
# Returns: Success: $self
# Failure: error message
#
@@ -197,23 +208,36 @@ sub make_sig_table
{
my $self = shift;
- my ($return, $rest);
+ my ($return, $rest, @rest);
+ my $me = ref($self) . '::make_sig_table';
delete $self->{sig_table};
for my $sig (@{$self->{signature}})
{
- ($return, $rest) = split / /, $sig, 2;
- if (! $rest)
+ ($return, @rest) = split / /, $sig;
+ if (! $return)
{
- $rest = q{};
+ return "$me: Invalid signature, cannot be null";
}
+ if (! $VALID_TYPES{$return})
+ {
+ return "$me: Unknown return type '$return'";
+ }
+ # Not going to add List::MoreUtils to my dependencies list, so suppress
+ # this ciritic flag:
+ ## no critic (ProhibitBooleanGrep)
+ if (grep { ! $VALID_TYPES{$_} } @rest)
+ {
+ return "$me: One or more invalid types in signature";
+ }
+
+ $rest = join q{ } => @rest;
# If the key $rest already exists, then this is a collision
if ($self->{sig_table}->{$rest})
{
return
- ref($self) . '::make_sig_table: Cannot have two different ' .
- "return values for one set of params ($return vs. " .
- "$self->{sig_table}->{$rest})";
+ "$me: Cannot have two different return values for one set " .
+ "of params ($return vs. $self->{sig_table}->{$rest})";
}
$self->{sig_table}->{$rest} = $return;
@@ -615,14 +639,14 @@ sub load_xpl_file
# Environment: None.
#
# Returns: Success: value
-# Failure: dies with RPC::XML::Fault object as message
+# Failure: RPC::XML::fault object
#
###############################################################################
sub call
{
my ($self, $srv, @data) = @_;
- my (@paramtypes, @params, $signature, $resptype, $response, $name, $noinc);
+ my (@paramtypes, @params, $signature, $resptype, $response, $name);
$name = $self->name;
# Create the param list.
@@ -642,25 +666,10 @@ sub call
);
}
- # Make sure that the response-type is a valid XML-RPC type
- if (($resptype ne 'scalar') && (! "RPC::XML::$resptype"->can('new')))
- {
- return $srv->server_fault(badsignature =>
- "Signature [$signature] for method $name has unknown " .
- "return-type '$resptype'");
- }
-
# Set these in case the server object is part of the param list
local $srv->{signature} = ## no critic (ProhibitLocalVars)
[ $resptype, @paramtypes ];
local $srv->{method_name} = $name; ## no critic (ProhibitLocalVars)
- # If the method being called is "system.status", check to see if we should
- # increment the server call-count.
- $noinc =
- (($name eq 'system.status') &&
- @data &&
- ($paramtypes[0] eq 'boolean') &&
- $params[0]) ? 1 : 0;
# For RPC::XML::Method (and derivatives), pass the server object
if ($self->isa('RPC::XML::Method'))
{
@@ -672,15 +681,24 @@ sub call
{
# On failure, propagate user-generated RPC::XML::fault exceptions, or
# transform Perl-level error/failure into such an object
- if ($@)
+ if (blessed $@ and $@->isa('RPC::XML::fault'))
+ {
+ return $@;
+ }
+ else
{
- return (blessed $@ and $@->isa('RPC::XML::fault')) ?
- $@ : $srv->server_fault(execerror =>
- "Method $name returned error: $@");
+ return $srv->server_fault(
+ execerror => "Method $name returned error: $@"
+ );
}
}
- if (! $noinc)
+ # Increment the 'called' key on the proc UNLESS the proc is named
+ # 'system.status' and has a boolean-true as the first param.
+ if (! (($name eq 'system.status') &&
+ @data &&
+ ($paramtypes[0] eq 'boolean') &&
+ $params[0]))
{
$self->{called}++;
}
@@ -744,35 +762,20 @@ package RPC::XML::Function;
use strict;
use warnings;
use vars qw(@ISA);
-use subs qw(new signature make_sig_table clone match_signature);
+use subs qw(
+ signature make_sig_table add_signature delete_signature match_signature
+);
@ISA = qw(RPC::XML::Procedure);
-# These two are only implemented here at all, because some of the logic in
-# other places call them
+# These are the bits that have to be different for RPC::XML::Function versus
+# the other procedure types. They are simple-enough that they don't need
+# dedicated comment-blocks for them.
sub signature { return [ 'scalar' ]; }
sub make_sig_table { return shift; }
sub add_signature { return shift; }
sub delete_signature { return shift; }
-
-###############################################################################
-#
-# Sub Name: match_signature
-#
-# Description: Noop. Needed for RPC::XML::Server.
-#
-# Arguments: NAME IN/OUT TYPE DESCRIPTION
-# $self in ref Object of this class
-# $sig in scalar Signature to check for
-#
-# Returns: Success: return type as a string
-# Failure: 0
-#
-###############################################################################
-sub match_signature
-{
- return 'scalar';
-}
+sub match_signature { return 'scalar'; }
1;
View
@@ -111,7 +111,7 @@ BEGIN
);
}
-$VERSION = '1.62';
+$VERSION = '1.63';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)
###############################################################################
@@ -419,7 +419,10 @@ sub add_method
}
elsif (ref $meth eq 'HASH')
{
- my $class = 'RPC::XML::' . ucfirst($meth->{type} || 'method');
+ # If the type of this method is not set, default to "method". The
+ # add_procedure and add_function calls should set this as needed.
+ $meth->{type} ||= 'method';
+ my $class = 'RPC::XML::' . ucfirst $meth->{type};
$meth = $class->new($meth);
}
elsif (! (blessed $meth and $meth->isa('RPC::XML::Procedure')))
@@ -2106,7 +2109,9 @@ sub dispatch
}
else
{
- $response = $self->server_fault(badmethod => $meth);
+ $response = $self->server_fault(
+ badmethod => "No method '$meth' on server"
+ );
}
# All the eval'ing and error-trapping happened within the method class
View
@@ -12,7 +12,7 @@ use Test::More;
use RPC::XML qw($ALLOW_NIL RPC_INT);
use RPC::XML::Procedure;
-plan tests => 75;
+plan tests => 81;
($vol, $dir, undef) = File::Spec->splitpath(File::Spec->rel2abs($0));
$dir = File::Spec->catpath($vol, $dir, '');
@@ -145,6 +145,27 @@ $obj = RPC::XML::Method->new({ name => 'test.test2',
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');
@@ -259,7 +280,7 @@ 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', 5
+ 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)),
@@ -274,6 +295,15 @@ SKIP: {
'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
Oops, something went wrong.

0 comments on commit 105d7d2

Please sign in to comment.