Skip to content

Commit

Permalink
Parser clean-ups/bug-fixes from better tests.
Browse files Browse the repository at this point in the history 
Statement-level coverage for both modules now at 100%.
  • Loading branch information
@rjray
rjray committed Jul 4, 2011
1 parent f82de55 commit a4a7135
Show file tree
Hide file tree
Showing 2 changed files with 212 additions and 126 deletions.
94 changes: 73 additions & 21 deletions lib/RPC/XML/Parser/XMLLibXML.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,7 +42,7 @@ use base 'RPC::XML::Parser';
use Scalar::Util 'reftype';
use XML::LibXML;

$VERSION = '1.17';
$VERSION = '1.18';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)

# This is to identify valid types that don't already have special handling
Expand Down Expand Up @@ -107,8 +107,8 @@ sub parse
return ($uri =~ m{^file:/}) ? 1 : 0;
},
sub {},
sub {},
sub {},
undef,
undef,
]);
$parser->input_callbacks($callbacks);

Expand Down Expand Up @@ -275,7 +275,9 @@ sub dom_request
my ($self, $dom) = @_;

my ($method_name, @args);
my @nodes = $dom->childNodes;
my @nodes = grep { ! ($_->isa('XML::LibXML::Text') &&
($_->textContent =~ /^\s*$/)) }
($dom->childNodes);

if (@nodes > 2)
{
Expand All @@ -288,7 +290,7 @@ sub dom_request
$method_name = $nodes[0]->textContent;
$method_name =~ s/^\s+//;
$method_name =~ s/\s+$//;
if ($method_name !~ m{[\w.:/]+})
if ($method_name !~ m{^[a-zA-Z0-9.:/]+$})
{
return qq{methodName value "$method_name" not a valid name};
}
Expand Down Expand Up @@ -329,7 +331,9 @@ sub dom_response

my $param;
my $me = __PACKAGE__ . '::dom_response';
my @children = $dom->childNodes;
my @children = grep { ! ($_->isa('XML::LibXML::Text') &&
($_->textContent =~ /^\s*$/)) }
($dom->childNodes);
if (1 != @children)
{
return "$me: Illegal content within methodResponse: " .
Expand All @@ -342,7 +346,9 @@ sub dom_response
# This is like delegating to dom_params() in the parsing of a request,
# but it is limited to a single value (which is why it has to be
# tested here).
@children = $node->childNodes;
@children = grep { ! ($_->isa('XML::LibXML::Text') &&
($_->textContent =~ /^\s*$/)) }
($node->childNodes);
if (1 != @children)
{
return
Expand All @@ -356,7 +362,9 @@ sub dom_response

# We know that $children[0] is the sole <param> tag. Look at its
# content to see that we have exactly one <value> tag.
@children = $children[0]->childNodes;
@children = grep { ! ($_->isa('XML::LibXML::Text') &&
($_->textContent =~ /^\s*$/)) }
($children[0]->childNodes);
if (1 != @children)
{
return
Expand All @@ -378,7 +386,9 @@ sub dom_response
elsif ($node->nodeName eq 'fault')
{
# Make sure that we have a single <value></value> container
my @sub_children = $node->childNodes;
my @sub_children = grep { ! ($_->isa('XML::LibXML::Text') &&
($_->textContent =~ /^\s*$/)) }
($node->childNodes);
if (1 != @sub_children)
{
return
Expand All @@ -399,7 +409,12 @@ sub dom_response
# Return if it was an error message
return $value;
}
$param = RPC::XML::fault->new($value->value);
if (! ref($param = RPC::XML::fault->new($value)))
{
# If it isn't a ref, then there was an error in creating the
# fault object from $value
return $RPC::XML::ERROR;
}
}
else
{
Expand All @@ -421,12 +436,19 @@ sub dom_params
# which contains a single <value> block.
for my $child ($node->childNodes)
{
if ($child->isa('XML::LibXML::Text') && $child->textContent =~ /^\s*$/)
{
next;
}

if ((my $tag = $child->nodeName) ne 'param')
{
return "$me: Unknown tag in params: $tag (expected 'param')";
}
# There should be exactly one child, named 'value'
my @children = $child->childNodes;
my @children = grep { ! ($_->isa('XML::LibXML::Text') &&
($_->textContent =~ /^\s*$/)) }
($child->childNodes);
if (1 != @children)
{
return "$me: Too many child-nodes for param tag";
Expand All @@ -451,7 +473,9 @@ sub dom_value ## no critic(ProhibitExcessComplexity)
my $me = __PACKAGE__ . '::dom_value';

# Make sure we have only one child-node
my @children = $node->childNodes;
my @children = grep { ! ($_->isa('XML::LibXML::Text') &&
($_->textContent =~ /^\s*$/)) }
($node->childNodes);
if (1 != @children)
{
return "$me: Too many child-nodes for value tag";
Expand Down Expand Up @@ -483,25 +507,49 @@ sub dom_value ## no critic(ProhibitExcessComplexity)
}
elsif (my $type = $VALIDTYPES{$nodename})
{
$value = $children[0]->textContent();
$value =~ s/^\s+//;
$value =~ s/\s+$//;
# Some minimal data-integrity checking
if ($type eq 'int' or $type eq 'i4' or $type eq 'i8')
{
if ($value !~ /^[-+]?\d+$/)
{
return "$me: Bad integer data read";
}
}
elsif ($type eq 'double')
{
if ($value !~
# Taken from perldata(1)
/^[+-]?(?=\d|[.]\d)\d*(?:[.]\d*)?(?:[Ee](?:[+-]?\d+))?$/x)
{
return "$me: Bad floating-point data read";
}
}
$type = 'RPC::XML::' . $type;
# The 'encoded' argument is only relevant for base64, ignored by all
# the others.
$value = $type->new($children[0]->textContent(), 'encoded');
$value = $type->new($value, 'encoded');
}
elsif ($nodename eq 'array')
{
@children = $children[0]->childNodes;
@children = grep { ! ($_->isa('XML::LibXML::Text') &&
($_->textContent =~ /^\s*$/)) }
($children[0]->childNodes);
if ((1 != @children) || ($children[0]->nodeName ne 'data'))
{
return "$me: array tag must have just one child element, 'data'";
}
@children = $children[0]->childNodes;
@children = grep { ! ($_->isa('XML::LibXML::Text') &&
($_->textContent =~ /^\s*$/)) }
($children[0]->childNodes);

# Make sure every child node is a <value> tag
if (my @bad = grep { $_->nodeName() ne 'value' } @children)
{
return qq($me: Bad tag within array: got "$bad[0]", expected ) .
'"value"';
return qq($me: Bad tag within array: got ") . $bad[0]->nodeName .
'", expected "value"';
}

# Take the easy way out and use recursion to fill out an array ref
Expand All @@ -525,20 +573,24 @@ sub dom_value ## no critic(ProhibitExcessComplexity)
}
elsif ($nodename eq 'struct')
{
@children = $children[0]->childNodes;
@children = grep { ! ($_->isa('XML::LibXML::Text') &&
($_->textContent =~ /^\s*$/)) }
($children[0]->childNodes);
# Make sure every child node is a <member> tag
if (my @bad = grep { $_->nodeName() ne 'member'} @children)
{
return qq($me: Bad tag within struct: got "$bad[0]", expected ) .
'"member"';
return qq($me: Bad tag within struct: got ") .
$bad[0]->nodeName . '", expected "member"';
}

# This is a little more work than <array>, as each <member> must have
# exactly one <name> and one <value> child-tag.
$value = {};
for my $member (@children)
{
my @mchildren = $member->childNodes;
my @mchildren = grep { ! ($_->isa('XML::LibXML::Text') &&
($_->textContent =~ /^\s*$/)) }
($member->childNodes);

if (2 != @mchildren)
{
Expand Down
Loading

0 comments on commit a4a7135

Please sign in to comment.