Skip to content
Browse files

Checkpoint refactoring and additional tests.

Work is not complete here, but the Net::Server changes demand immediate
attention.
  • Loading branch information...
1 parent 64e3409 commit 865cf9a319d12b950c148289ee5577de7d63642f @rjray committed Aug 25, 2012
Showing with 62 additions and 11 deletions.
  1. +37 −9 lib/RPC/XML/Server.pm
  2. +25 −2 t/40_server.t
View
46 lib/RPC/XML/Server.pm
@@ -67,7 +67,7 @@ package RPC::XML::Server;
use 5.008008;
use strict;
use warnings;
-use vars qw($VERSION $INSTALL_DIR %FAULT_TABLE @XPL_PATH
+use vars qw($VERSION $INSTALL_DIR %FAULT_TABLE @XPL_PATH %CLASS_MAP
$IO_SOCKET_SSL_HACK_NEEDED $COMPRESSION_AVAILABLE);
use Carp qw(carp croak);
@@ -109,9 +109,16 @@ BEGIN
badsignature => [ 201 => 'Method signature error: %s' ],
execerror => [ 300 => 'Code execution error: %s' ],
);
+
+ # This is used by add_method to map "types" to instantiation classes
+ %CLASS_MAP = (
+ method => 'RPC::XML::Method',
+ procedure => 'RPC::XML::Procedure',
+ function => 'RPC::XML::Function',
+ );
}
-$VERSION = '1.69';
+$VERSION = '1.70';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)
###############################################################################
@@ -139,7 +146,12 @@ sub new ## no critic (ProhibitExcessComplexity)
$srv_name
);
- $class = ref($class) || $class;
+ # Don't accept a blessed value for $class
+ if (ref $class)
+ {
+ return __PACKAGE__ . '::new: Must be called as a static method';
+ }
+
$self = bless {}, $class;
$srv_version = delete $args{server_version} || $self->version;
@@ -205,6 +217,9 @@ sub new ## no critic (ProhibitExcessComplexity)
$args{parser} ? @{delete $args{parser}} : ()
);
+ # Add the basic paths (content of @XPL_PATH) to our local XPL path
+ push @{$self->{__xpl_path}}, @XPL_PATH;
+
# Set up the default methods unless requested not to
if (! delete $args{no_default})
{
@@ -393,6 +408,8 @@ sub xpl_path
# $self in ref Object to add to
# $meth in scalar Hash ref of data or file name
#
+# Globals: %CLASS_MAP
+#
# Returns: Success: $self
# Failure: error string
#
@@ -417,11 +434,22 @@ sub add_method
}
elsif (ref $meth eq 'HASH')
{
+ # Make a copy of the contents of $meth, so we don't make permanent
+ # changes:
+ my %meth_copy = map { $_ => $meth->{$_} } (keys %{$meth});
+
# 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);
+ my $type = delete $meth_copy{type} || 'method';
+
+ if (! (my $class = $CLASS_MAP{lc $type}))
+ {
+ return "$me: Unknown type: $type";
+ }
+ else
+ {
+ $meth = $class->new(\%meth_copy);
+ }
}
elsif (! (blessed $meth and $meth->isa('RPC::XML::Procedure')))
{
@@ -464,7 +492,7 @@ sub add_procedure
###############################################################################
#
-# Sub Name: add_procedure
+# Sub Name: add_function
#
# Description: This filters through to add_method, but if the passed-in
# value is a hash reference forces the "type" to be
@@ -513,10 +541,10 @@ sub method_from_file
if (! File::Spec->file_name_is_absolute($file))
{
my $path;
- for my $dir (@{$self->xpl_path}, @XPL_PATH)
+ for my $dir (@{$self->xpl_path})
{
$path = File::Spec->catfile($dir, $file);
- if (-e $path)
+ if (-f $path)
{
$file = File::Spec->canonpath($path);
last;
View
27 t/40_server.t
@@ -12,7 +12,7 @@ use Carp qw(croak);
use Socket;
use File::Spec;
-use Test::More tests => 84;
+use Test::More tests => 91;
use LWP::UserAgent;
use HTTP::Request;
use Scalar::Util 'blessed';
@@ -57,6 +57,9 @@ ok(! $srv->requests, 'RPC::XML::Server::requests method (0)');
ok($srv->response->isa('HTTP::Response'),
'RPC::XML::Server::response method returns HTTP::Response');
# Some negative tests:
+$res = $srv->new();
+like($res, qr/Must be called as a static method/,
+ 'Calling new() as an instance method fails');
$meth = $srv->method_from_file('does_not_exist.xpl');
ok(! ref $meth, 'Bad file did not result in method reference');
like($meth, qr/Error opening.*does_not_exist/, 'Correct error message');
@@ -181,10 +184,30 @@ $res = $srv->get_method('perl.test.suite.test1');
isa_ok($res, 'RPC::XML::Method', 'get_method return value');
$res = $srv->get_method('perl.test.suite.not.added.yet');
ok(! ref($res), 'get_method for non-existent method');
-# Throw junk at add_method
+
+# Throw junk at add_method/add_procedure/add_function
$res = $srv->add_method([]);
like($res, qr/file name, a hash reference or an object/,
'add_method() fails on bad data');
+$res = $srv->add_method('file does not exist');
+like($res, qr/Error loading from file/,
+ 'add_method() fails on non-existent file');
+$res = $srv->add_procedure({ name => 'procedure1',
+ signature => [ 'int' ],
+ code => sub { return 1; } });
+ok($res eq $srv, 'add_procedure return value test');
+$res = $srv->get_procedure('procedure1');
+is(ref($res), 'RPC::XML::Procedure', 'get_procedure(procedure1) return value');
+$res = $srv->add_function({ name => 'function1',
+ code => sub { return 1; } });
+ok($res eq $srv, 'add_function return value test');
+$res = $srv->get_function('function1');
+is(ref($res), 'RPC::XML::Function', 'get_function(function1) return value');
+$res = $srv->add_method({ name => 'method1',
+ type => 'bad',
+ signature => [ 'int' ],
+ code => sub { return 1; } });
+like($res, qr/Unknown type: bad/, 'add_method, bad type param');
# Here goes...
$parser = RPC::XML::ParserFactory->new;

0 comments on commit 865cf9a

Please sign in to comment.
Something went wrong with that request. Please try again.