Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Fixes for file-based method loading/reloading.

New tests in the suite, and re-working of the ugliest hacky part of this
package.
  • Loading branch information...
commit b8f94379ae4b01ae922e352a31b6150e0e3c7cbf 1 parent d04bd3c
Randy J. Ray authored
89 lib/RPC/XML/Procedure.pm
View
@@ -64,7 +64,7 @@ use RPC::XML 'smart_encode';
# This module also provides RPC::XML::Method
## no critic (ProhibitMultiplePackages)
-$VERSION = '1.25';
+$VERSION = '1.26';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)
###############################################################################
@@ -89,7 +89,10 @@ sub new
my $data; # This will be a hashref that eventually gets blessed
- $class = ref($class) || $class;
+ if (ref $class)
+ {
+ return __PACKAGE__ . '::new: Must be called as a static method';
+ }
# There are three things that @argz could be:
if (ref $argz[0])
@@ -108,35 +111,24 @@ sub new
{
# 2. Exactly one non-ref element, a file to load
- # And here is where I cheat in a way that makes even me uncomfortable.
- #
# Loading code from an XPL file, it can actually be of a type other
# than how this constructor was called. So what we are going to do is
- # this: If $class is undef, that can only mean that we were called
- # with the intent of letting the XPL file dictate the resulting object.
- # If $class is set, then we'll call load_xpl_file normally, as a
- # method, to allow for subclasses to tweak things.
- if (defined $class)
+ # this: If $class is RPC::XML::Procedure, act like a factory method
+ # and return whatever the file claims to be. Otherwise, the file has
+ # to match $class or it's an error.
+ ($data, my $pkg) = load_xpl_file($argz[0]);
+ if (! ref $data)
{
- $data = $class->load_xpl_file($argz[0]);
- if (! ref $data)
- {
- # load_xpl_path signalled an error
- return $data;
- }
+ # load_xpl_path signalled an error
+ return $data;
}
- else
+ if ($class ne 'RPC::XML::Procedure' && $pkg ne $class)
{
- # Spoofing the "class" argument to load_xpl_file makes me feel
- # even dirtier...
- $data = load_xpl_file(\$class, $argz[0]);
- if (! ref $data)
- {
- # load_xpl_path signalled an error
- return $data;
- }
- $class = "RPC::XML::$class";
+ return "${class}::new: File loaded ($argz[0]) must match " .
+ 'this calling class';
}
+
+ $class = $pkg;
}
else
{
@@ -486,13 +478,15 @@ sub reload
{
my $self = shift;
+ my $class = ref $self;
+ my $me = "${class}::reload";
+
if (! $self->{file})
{
- return sprintf '%s::reload: No file associated with method %s',
- ref $self, $self->{name};
+ return "$me: No file associated with method $self->{name}";
}
- my $tmp = $self->load_xpl_file($self->{file});
+ my ($tmp) = load_xpl_file($self->{file});
if (ref $tmp)
{
@@ -504,8 +498,10 @@ sub reload
# Re-calculate the signature table, in case that changed as well
return $self->make_sig_table;
}
-
- return $tmp;
+ else
+ {
+ return "$me: Error loading $self->{file}: $tmp";
+ }
}
###############################################################################
@@ -515,13 +511,10 @@ sub reload
# Description: Load a XML-encoded method description (generally denoted
# by a *.xpl suffix) and return the relevant information.
#
-# Note that this does not fill in $self if $self is a hash
-# or object reference. This routine is not a substitute for
-# calling new() (which is why it isn't part of the public
-# API).
+# Note that this is not a method, it does not take $self as
+# an argument.
#
# Arguments: NAME IN/OUT TYPE DESCRIPTION
-# $self in ref Object of this class
# $file in scalar File to load
#
# Returns: Success: hashref of values
@@ -530,23 +523,15 @@ sub reload
###############################################################################
sub load_xpl_file
{
- my $self = shift;
my $file = shift;
require XML::Parser;
my ($me, $data, $signature, $code, $codetext, $accum, $P, $fh, $eval_ret,
- %attr);
+ $class, %attr);
+
+ $me = __PACKAGE__ . '::load_xpl_file';
- if (ref($self) eq 'SCALAR')
- {
- $me = __PACKAGE__ . '::load_xpl_file';
- }
- else
- {
- $me = (ref $self) || $self || __PACKAGE__;
- $me .= '::load_xpl_file';
- }
$data = {};
# So these don't end up undef, since they're optional elements
$data->{hidden} = 0;
@@ -582,13 +567,7 @@ sub load_xpl_file
}
elsif ('def' eq substr $elem, -3)
{
- # Don't blindly store the container tag...
- # We may need it to tell the caller what
- # our type is
- if (ref $self eq 'SCALAR')
- {
- ${$self} = ucfirst substr $elem, 0, -3;
- }
+ $class = 'RPC::XML::' . ucfirst substr $elem, 0, -3;
}
else
{
@@ -633,7 +612,7 @@ sub load_xpl_file
$data->{file} = $file;
$data->{called} = 0;
- return $data;
+ return ($data, $class);
}
###############################################################################
@@ -791,7 +770,7 @@ use subs qw(new signature make_sig_table clone is_valid match_signature);
# These two are only implemented here at all, because some of the logic in
# other places call them
-sub signature { return; }
+sub signature { return [ 'scalar' ]; }
sub make_sig_table { return shift; }
sub add_signature { return shift; }
sub delete_signature { return shift; }
7 lib/RPC/XML/Server.pm
View
@@ -111,7 +111,7 @@ BEGIN
);
}
-$VERSION = '1.60';
+$VERSION = '1.61';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)
###############################################################################
@@ -1453,7 +1453,10 @@ sub method_from_file
$file = File::Spec->rel2abs($file);
}
- return RPC::XML::Procedure::new(undef, $file);
+ # When reading a XPL file, RPC::XML::Procedure->new() acts sort of like a
+ # factory constructor, returning the type of object the XPL file specifies
+ # even when that isn't RPC::XML::Procedure.
+ return RPC::XML::Procedure->new($file);
}
# Same as above, but for name-symmetry
121 t/30_method.t
View
@@ -4,7 +4,7 @@
use strict;
use warnings;
-use vars qw($obj $obj2 $flag $dir $vol $tmp);
+use vars qw($obj $obj2 $flag $dir $vol $tmp $tmpfile $fh);
use File::Spec;
use Test::More;
@@ -12,10 +12,11 @@ use Test::More;
use RPC::XML qw($ALLOW_NIL RPC_INT);
use RPC::XML::Procedure;
-plan tests => 60;
+plan tests => 76;
($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
@@ -33,6 +34,12 @@ SKIP: {
skip 'Cannot test without object', 16
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) &&
@@ -72,7 +79,11 @@ SKIP: {
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')
+ 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
@@ -134,7 +145,7 @@ 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');
+isa_ok($obj, 'RPC::XML::Method', '$obj');
SKIP: {
skip 'Cannot test without a value $obj', 20
@@ -149,8 +160,10 @@ SKIP: {
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:
- is($obj->code->({ method_name => $obj->name }), $obj->name(),
+ # 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
@@ -224,6 +237,42 @@ SKIP: {
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', 6
+ if (ref($obj) ne 'RPC::XML::Function');
+
+ ok($obj->is_valid, 'RPC::XML::Function passed is_valid test');
+ 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>');
+}
+
+# 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;
@@ -288,4 +337,64 @@ SKIP: {
'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;
6 t/meth_good_1.xpl
View
@@ -1,10 +1,10 @@
<?xml version="1.0"?>
<!DOCTYPE methoddef SYSTEM "rpc-method.dtd">
<methoddef>
-<name>test.test3</name>
+<name>test.rpc.xml.method</name>
<version>1.0</version>
<hidden />
<signature>string</signature>
-<help>Simple test method for RPC::XML::Method suite</help>
-<code language="perl">sub test { $_[0]->{method_name} }</code>
+<help>Simple test method for RPC::XML::Method class</help>
+<code language="perl">sub test { $_[1]->{method_name} }</code>
</methoddef>
9 t/meth_good_2.xpl
View
@@ -0,0 +1,9 @@
+<?xml version="1.0"?>
+<!DOCTYPE proceduredef SYSTEM "rpc-method.dtd">
+<proceduredef>
+<name>test.rpc.xml.procedure</name>
+<version>1.0</version>
+<signature>string</signature>
+<help>Simple test method for RPC::XML::Procedure class</help>
+<code language="perl">sub test { $_[0] }</code>
+</proceduredef>
9 t/meth_good_3.xpl
View
@@ -0,0 +1,9 @@
+<?xml version="1.0"?>
+<!DOCTYPE functiondef SYSTEM "rpc-method.dtd">
+<functiondef>
+<name>test.rpc.xml.function</name>
+<version>1.0</version>
+<signature>string</signature>
+<help>Simple test method for RPC::XML::Function class</help>
+<code language="perl">sub test { $_[0] }</code>
+</functiondef>
Please sign in to comment.
Something went wrong with that request. Please try again.