Skip to content
Browse files

Fixes and such from Devel::Cover analysis.

  • Loading branch information...
1 parent 343e66b commit d04bd3c06a69b3885857fb85179458e2830db69c @rjray committed Jul 13, 2011
Showing with 171 additions and 121 deletions.
  1. +54 −21 lib/RPC/XML.pm
  2. +100 −73 lib/RPC/XML/Procedure.pm
  3. +17 −27 lib/RPC/XML/Server.pm
View
75 lib/RPC/XML.pm
@@ -1,6 +1,6 @@
###############################################################################
#
-# This file copyright (c) 2001-2010 Randy J. Ray, all rights reserved
+# This file copyright (c) 2001-2011 Randy J. Ray, all rights reserved
#
# Copying and distribution are permitted under the terms of the Artistic
# License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php) or
@@ -58,7 +58,7 @@ BEGIN
RPC_NIL) ],
all => [ @EXPORT_OK ]);
-$VERSION = '1.53';
+$VERSION = '1.54';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)
# Global error string
@@ -138,17 +138,10 @@ sub RPC_NIL ()
sub time2iso8601
{
my $time = shift || time;
- my $zone = shift || q{};
my @time = gmtime $time;
$time = sprintf '%4d%02d%02dT%02d:%02d:%02dZ',
$time[5] + 1900, $time[4] + 1, @time[3, 2, 1, 0];
- if ($zone)
- {
- my $char = $zone > 0 ? q{+} : q{-};
- chop $time; # Lose the Z if we're specifying a zone
- $time .= $char . sprintf '%02d:00', abs $zone;
- }
return $time;
}
@@ -340,6 +333,14 @@ sub new
$RPC::XML::ERROR = q{};
$class = ref($class) || $class;
+
+ if ($class eq 'RPC::XML::simple_type')
+ {
+ $RPC::XML::ERROR = 'RPC::XML::simple_type::new: Cannot instantiate ' .
+ 'this class directly';
+ return;
+ }
+
if (ref $value)
{
# If it is a scalar reference, just deref
@@ -352,6 +353,7 @@ sub new
# We can only manage scalar references (or blessed scalar refs)
$RPC::XML::ERROR = "${class}::new: Cannot instantiate from a " .
'reference not derived from scalar';
+ return;
}
}
@@ -363,6 +365,13 @@ sub value
{
my $self = shift;
+ if (! ref $self)
+ {
+ $RPC::XML::ERROR =
+ "{$self}::value: Cannot be called as a static method";
+ return;
+ }
+
return ${$self};
}
@@ -374,6 +383,8 @@ sub as_string
my $class = ref $self;
if (! $class)
{
+ $RPC::XML::ERROR =
+ "{$self}::as_string: Cannot be called as a static method";
return;
}
$class =~ s/^.*\://;
@@ -460,11 +471,13 @@ sub as_string
{
my $self = shift;
- my $class = $self->type;
- if (! $class)
+ if (! ref $self)
{
+ $RPC::XML::ERROR =
+ "{$self}::as_string: Cannot be called as a static method";
return;
}
+ my $class = $self->type;
(my $value = sprintf '%.20f', ${$self}) =~ s/([.]\d+?)0+$/$1/;
@@ -490,11 +503,13 @@ sub as_string
my ($class, $value);
- $class = $self->type;
- if (! $class)
+ if (! ref $self)
{
+ $RPC::XML::ERROR =
+ "{$self}::as_string: Cannot be called as a static method";
return;
}
+ $class = $self->type;
($value = defined ${$self} ? ${$self} : q{} )
=~ s/$RPC::XML::XMLRE/$RPC::XML::XMLMAP{$1}/ge;
@@ -1077,17 +1092,23 @@ sub to_file
my ($fh, $buf, $do_close, $count) = (undef, q{}, 0, 0);
- if (ref $file and reftype($file) eq 'GLOB')
+ if (ref $file)
{
- $fh = $file;
+ if (reftype($file) eq 'GLOB')
+ {
+ $fh = $file;
+ }
+ else
+ {
+ $RPC::XML::ERROR = 'Unusable reference type passed to to_file';
+ return -1;
+ }
}
else
{
- require Symbol;
- $fh = Symbol::gensym();
if (! open $fh, '>', $file) ## no critic (RequireBriefOpen)
{
- $RPC::XML::ERROR = $!;
+ $RPC::XML::ERROR = "Error opening $file for writing: $!";
return -1;
}
binmode $fh;
@@ -1124,21 +1145,25 @@ sub to_file
}
else
{
+ # If the data is already decoded in the filehandle, then just copy
+ # it over.
my $size;
while ($size = read $self->{value_fh}, $buf, 4096)
{
print {$fh} $buf;
$count += $size;
}
}
+
+ # Restore the position of the file-pointer for the internal FH
seek $self->{value_fh}, $self->{fh_pos}, 0;
}
if ($do_close)
{
if (! close $fh)
{
- $RPC::XML::ERROR = $!;
+ $RPC::XML::ERROR = "Error closing $file after writing: $!";
return -1;
}
}
@@ -1179,7 +1204,7 @@ sub new
# Take the keys and values from the struct object as our own
%args = %{$args[0]->value('shallow')};
}
- elsif (@args == 2)
+ elsif ((@args == 2) && ($args[0] =~ /^-?\d+$/) && length $args[1])
{
# This is a special convenience-case to make simple new() calls clearer
%args = (faultCode => RPC::XML::int->new($args[0]),
@@ -1299,6 +1324,14 @@ sub new
# This is the method name to be called
$name = shift @argz;
+ # Is it valid?
+ if ($name !~ m{^[\w.:/]+$})
+ {
+ $RPC::XML::ERROR =
+ 'RPC::XML::request::new: Invalid method name specified';
+ return;
+ }
+
# All the remaining args must be data.
@argz = RPC::XML::smart_encode(@argz);
@@ -1307,7 +1340,7 @@ sub new
# Accessor methods
sub name { return shift->{name}; }
-sub args { return shift->{args} || []; }
+sub args { return shift->{args}; }
###############################################################################
#
View
173 lib/RPC/XML/Procedure.pm
@@ -64,7 +64,7 @@ use RPC::XML 'smart_encode';
# This module also provides RPC::XML::Method
## no critic (ProhibitMultiplePackages)
-$VERSION = '1.24';
+$VERSION = '1.25';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)
###############################################################################
@@ -95,8 +95,14 @@ sub new
if (ref $argz[0])
{
# 1. A hashref containing all the relevant keys
- $data = {};
- %{$data} = %{$argz[0]};
+ $data = {
+ namespace => q{},
+ version => 0,
+ hidden => 0,
+ help => q{},
+ signature => [],
+ };
+ for (keys %{$argz[0]}) { $data->{$_} = $argz[0]->{$_} }
}
elsif (@argz == 1)
{
@@ -115,7 +121,7 @@ sub new
$data = $class->load_xpl_file($argz[0]);
if (! ref $data)
{
- # load_XPL_path signalled an error
+ # load_xpl_path signalled an error
return $data;
}
}
@@ -126,7 +132,7 @@ sub new
$data = load_xpl_file(\$class, $argz[0]);
if (! ref $data)
{
- # load_XPL_path signalled an error
+ # load_xpl_path signalled an error
return $data;
}
$class = "RPC::XML::$class";
@@ -137,8 +143,13 @@ sub new
# 3. If there is more than one arg, it's a sort-of-hash. That is, the
# key 'signature' is allowed to repeat.
my ($key, $val);
- $data = {};
- $data->{signature} = [];
+ $data = {
+ namespace => q{},
+ version => 0,
+ hidden => 0,
+ help => q{},
+ signature => [],
+ };
while (@argz)
{
($key, $val) = splice @argz, 0, 2;
@@ -150,18 +161,14 @@ sub new
push @{$data->{signature}},
ref $val ? join q{ } => @{$val} : $val;
}
- elsif (exists $data->{$key})
- {
- return "${class}::new: Key '$key' may not be repeated";
- }
else
{
$data->{$key} = $val;
}
}
}
- if (! (exists $data->{signature} &&
+ if (! ((exists $data->{signature}) &&
(ref($data->{signature}) eq 'ARRAY') &&
scalar(@{$data->{signature}}) &&
$data->{name} &&
@@ -228,7 +235,10 @@ sub help
{
my ($self, $value) = @_;
- $value and $self->{help} = $value;
+ if ($value)
+ {
+ $self->{help} = $value;
+ }
return $self->{help};
}
@@ -237,7 +247,10 @@ sub version
{
my ($self, $value) = @_;
- $value and $self->{version} = $value;
+ if ($value)
+ {
+ $self->{version} = $value;
+ }
return $self->{version};
}
@@ -246,7 +259,10 @@ sub hidden
{
my ($self, $value) = @_;
- $value and $self->{hidden} = $value;
+ if ($value)
+ {
+ $self->{hidden} = $value;
+ }
return $self->{hidden};
}
@@ -255,7 +271,10 @@ sub code
{
my ($self, $value) = @_;
- ref $value eq 'CODE' and $self->{code} = $value;
+ if ($value and ref $value eq 'CODE')
+ {
+ $self->{code} = $value;
+ }
return $self->{code};
}
@@ -264,17 +283,29 @@ sub signature
{
my ($self, $sig) = @_;
- if ($sig and ref $sig eq 'ARRAY')
+ if ($sig)
{
- my $old = $self->{signature};
- $self->{signature} = $sig;
- if (! ref $self->make_sig_table)
+ if (ref $sig eq 'ARRAY')
+ {
+ my $old = $self->{signature};
+ $self->{signature} = $sig;
+ my $tmp = $self->make_sig_table;
+ if (! ref $tmp)
+ {
+ # If it failed to re-init the table, restore the old list (and
+ # old table). We don't have to check this return, since it had
+ # worked before.
+ $self->{signature} = $old;
+ $self->make_sig_table;
+
+ # Return an error message, since this failed:
+ return ref($self) . "::signature: $tmp";
+ }
+ }
+ else
{
- # If it failed to re-init the table, restore the old list (and old
- # table). We don't have to check this return, since it had worked
- # before.
- $self->{signature} = $old;
- $self->make_sig_table;
+ # Anything not an array ref isn't useful
+ return ref($self) . "::signature: Bad value '$sig'";
}
}
@@ -334,9 +365,8 @@ sub is_valid
{
my $self = shift;
- return ( (ref($self->{code}) eq 'CODE')
- and $self->{name}
- and (ref($self->{signature}) && scalar(@{$self->{signature}})));
+ return ((ref($self->{code}) eq 'CODE') && $self->{name} &&
+ (ref($self->{signature}) && scalar(@{$self->{signature}})));
}
###############################################################################
@@ -387,29 +417,28 @@ sub delete_signature
{
my ($self, @args) = @_;
- my (%sigs, $tmp, $old);
+ my %sigs;
- # Preserve the original in case adding the new one causes a problem
- $old = $self->{signature};
+ my $old = $self->{signature};
%sigs = map { $_ => 1 } @{$self->{signature}};
for my $one_sig (@args)
{
- $tmp = (ref $one_sig) ? join q{ } => @{$one_sig} : $one_sig;
+ my $tmp = (ref $one_sig) ? join q{ } => @{$one_sig} : $one_sig;
delete $sigs{$tmp};
}
$self->{signature} = [ keys %sigs ];
- $tmp = $self->make_sig_table;
- if (! ref $tmp)
+
+ if (@{$self->{signature}} == 0)
{
- # Because this failed, we have to restore the old table and return
- # an error
+ # Don't have to re-run make_sig_table, because it's still valid for
+ # this set:
$self->{signature} = $old;
- $self->make_sig_table;
- return
- ref $self . '::delete_signature: Error re-hashing table: ' . $tmp;
+ return ref($self) . '::delete_signature: Cannot delete last signature';
}
- return $self;
+ # This can't fail, because deleting a signature will never cause an
+ # ambiguity in the table like adding one could.
+ return $self->make_sig_table;
}
###############################################################################
@@ -506,7 +535,8 @@ sub load_xpl_file
require XML::Parser;
- my ($me, $data, $signature, $code, $codetext, $accum, $P, %attr);
+ my ($me, $data, $signature, $code, $codetext, $accum, $P, $fh, $eval_ret,
+ %attr);
if (ref($self) eq 'SCALAR')
{
@@ -519,10 +549,10 @@ sub load_xpl_file
}
$data = {};
# So these don't end up undef, since they're optional elements
- $data->{hidden} = 0;
- $data->{version} = q{};
- $data->{help} = q{};
- $data->{called} = 0;
+ $data->{hidden} = 0;
+ $data->{version} = q{};
+ $data->{help} = q{};
+ $data->{namespace} = __PACKAGE__;
$P = XML::Parser->new(
ErrorContext => 1,
Handlers => {
@@ -531,13 +561,17 @@ sub load_xpl_file
End => sub {
my $elem = $_[1];
- $accum =~ s/^[\s\n]+//;
- $accum =~ s/[\s\n]+$//;
+ $accum =~ s/^\s+//;
+ $accum =~ s/\s+$//;
if ($elem eq 'signature')
{
$data->{signature} ||= [];
push @{$data->{signature}}, $accum;
}
+ elsif ($elem eq 'hidden')
+ {
+ $data->{hidden} = 1;
+ }
elsif ($elem eq 'code')
{
if (! ($attr{language} &&
@@ -570,31 +604,20 @@ sub load_xpl_file
{
return "$me: Error creating XML::Parser object";
}
- open my $fh, '<', $file or
- return "$me: Error opening $file for reading: $!";
+ open $fh, '<', $file or return "$me: Error opening $file for reading: $!";
# Trap any errors
- eval { $P->parse($fh); }; ## no critic (RequireCheckingReturnValueOfEval)
+ $eval_ret = eval { $P->parse($fh); 1; };
close $fh or return "$me: Error closing $file: $!";
- if ($@)
+ if (! $eval_ret)
{
return "$me: Error parsing $file: $@";
}
# Try to normalize $codetext before passing it to eval
- # First step is set the namespace the code will live in. The default is
- # the package that we're in (be it ::Procedure, ::Method, etc.). If they
- # specify one, use it instead.
- if ($data->{namespace})
- {
- # Fudge a little and let them use '.' as a synonym for '::' in the
- # namespace hierarchy.
- $data->{namespace} =~ s/[.]/::/g;
- }
- else
- {
- $data->{namespace} = __PACKAGE__;
- }
+ # Fudge a little and let them use '.' as a synonym for '::' in the
+ # namespace hierarchy.
+ $data->{namespace} =~ s/[.]/::/g;
# Next step is to munge away any actual subroutine name so that the eval
# yields an anonymous sub. Also insert the namespace declaration.
@@ -604,9 +627,11 @@ sub load_xpl_file
return "$me: Error creating anonymous sub: $@" if $@;
$data->{code} = $code;
- # Add the file's mtime for when we check for stat-based reloading
- $data->{mtime} = (stat $file)[9];
- $data->{file} = $file;
+ # Add the file's mtime for when we check for stat-based reloading, name
+ # for reloading, and init the "called" counter to 0.
+ $data->{mtime} = (stat $file)[9];
+ $data->{file} = $file;
+ $data->{called} = 0;
return $data;
}
@@ -887,8 +912,8 @@ when methods were implemented simply as hash references.
If there is more than one argument in the list, then the list is assumed to be
a sort of "ersatz" hash construct, in that one of the keys (C<signature>) is
-allowed to occur multiple times. Otherwise, each of the following is allowed,
-but may only occur once:
+allowed to "stack" if it occur multiple times. Otherwise, any keys that occur
+multiple times overwrite the previous value:
=over 12
@@ -903,8 +928,8 @@ calls for the method
=item signature
-(May appear more than once) Provides one calling-signature for the method, as
-either a space-separated string of types or a list-reference
+Provides one calling-signature for the method, as either a space-separated
+string of types or a list-reference
=item help
@@ -1104,6 +1129,8 @@ The lightweight DTD for the layout can be summarized as:
signature+, help?, code)>
<!ELEMENT methoddef (name, namespace?, version?, hidden?,
signature+, help?, code)>
+ <!ELEMENT functiondef (name, namespace?, version?, hidden?,
+ signature+, help?, code)>
<!ELEMENT name (#PCDATA)>
<!ELEMENT namespace (#PCDATA)>
<!ELEMENT version (#PCDATA)>
@@ -1113,8 +1140,8 @@ The lightweight DTD for the layout can be summarized as:
<!ELEMENT code (#PCDATA)>
<!ATTLIST code language (#PCDATA)>
-The containing tag is always one of C<< <methoddef> >> or
-C<< <proceduredef> >>. The tags that specify name, signatures and the code
+The containing tag is always one of C<< <methoddef> >>, C<< <proceduredef> >>
+or C<< <functiondef> >>. The tags that specify name, signatures and the code
itself must always be present. Some optional information may also be
supplied. The "help" text, or what an introspection API would expect to use to
document the method, is also marked as optional. Having some degree of
View
44 lib/RPC/XML/Server.pm
@@ -67,7 +67,7 @@ package RPC::XML::Server;
use 5.008008;
use strict;
use warnings;
-use vars qw($VERSION @ISA $INSTANCE $INSTALL_DIR %FAULT_TABLE @XPL_PATH
+use vars qw($VERSION $INSTALL_DIR %FAULT_TABLE @XPL_PATH
$IO_SOCKET_SSL_HACK_NEEDED $COMPRESSION_AVAILABLE);
use Carp qw(carp croak);
@@ -86,7 +86,8 @@ use RPC::XML::Procedure;
BEGIN
{
- $INSTALL_DIR = (File::Spec->splitpath(__FILE__))[1];
+ $INSTALL_DIR =
+ File::Spec->catpath((File::Spec->splitpath(__FILE__))[0, 1], q{});
@XPL_PATH = ($INSTALL_DIR, File::Spec->curdir);
# For now, I have an ugly hack in place to make the functionality that
@@ -110,7 +111,7 @@ BEGIN
);
}
-$VERSION = '1.59';
+$VERSION = '1.60';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)
###############################################################################
@@ -215,7 +216,6 @@ sub new ## no critic (ProhibitExcessComplexity)
}
# Compression support
- $self->{__compress} = q{};
if (delete $args{no_compress})
{
$self->{__compress} = q{};
@@ -247,22 +247,18 @@ sub new ## no critic (ProhibitExcessComplexity)
# Set up the table of response codes/messages that will be used when the
# server is sending a controlled error message to a client (as opposed to
# something HTTP-level that is less within our control).
- $self->{__fault_table} = {%FAULT_TABLE};
+ $self->{__fault_table} = {};
+ for my $fault (keys %FAULT_TABLE)
+ {
+ $self->{__fault_table}->{$fault} = [ @{$FAULT_TABLE{$fault}} ];
+ }
if ($args{fault_code_base})
{
my $base = delete $args{fault_code_base};
# Apply the numerical offset to all (current) error codes
for my $key (keys %{$self->{__fault_table}})
{
- if (ref($self->{__fault_table}->{$key}))
- {
- # A ref is a listref where the first element is the code
- $self->{__fault_table}->{$key}->[0] += $base;
- }
- else
- {
- $self->{__fault_table}->{$key} += $base;
- }
+ $self->{__fault_table}->{$key}->[0] += $base;
}
}
if ($args{fault_table})
@@ -1439,14 +1435,10 @@ sub method_from_file
if (! File::Spec->file_name_is_absolute($file))
{
- my ($path, @path);
- if (ref $self)
+ my $path;
+ for my $dir (@{$self->xpl_path}, @XPL_PATH)
{
- push @path, @{$self->xpl_path};
- }
- for (@path, @XPL_PATH)
- {
- $path = File::Spec->catfile($_, $file);
+ $path = File::Spec->catfile($dir, $file);
if (-e $path)
{
$file = File::Spec->canonpath($path);
@@ -1500,7 +1492,7 @@ sub get_method
{
# Try to load this dynamically on the fly, from any of the dirs
# that are in this object's @xpl_path
- (my $loadname = $name) =~ s/^system\.//;
+ (my $loadname = $name) =~ s/^system[.]//;
$self->add_method("$loadname.xpl");
}
# If method is still not in the table, we were unable to load it
@@ -2177,16 +2169,14 @@ sub call
# $self in ref Object reference/static class
# @details in ref Details of names to add or skip
#
-# Globals: $INSTALL_DIR
-#
# Returns: $self
#
###############################################################################
sub add_default_methods
{
my ($self, @details) = @_;
- return $self->add_methods_in_dir($INSTALL_DIR, @details);
+ return $self->add_methods_in_dir($self->INSTALL_DIR, @details);
}
###############################################################################
@@ -2223,7 +2213,7 @@ sub add_methods_in_dir
}
for (@details)
{
- if (! /\.xpl$/)
+ if (! /[.]xpl$/)
{
$_ .= '.xpl';
}
@@ -2236,7 +2226,7 @@ sub add_methods_in_dir
{
return "Error opening $dir for reading: $!";
}
- my @files = grep { $_ =~ /\.xpl$/ } readdir $dh;
+ my @files = grep { $_ =~ /[.]xpl$/ } readdir $dh;
closedir $dh;
for my $file (@files)

0 comments on commit d04bd3c

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