File Coverage

blib/lib/Test/XML/Simple.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Test::XML::Simple;

use strict;
use warnings;

our $VERSION = '1.05';

use Test::Builder;
use Test::More;
use Test::LongString;
use XML::LibXML;

my $Test = Test::Builder->new();
my $Xml;

sub import {
   my $self = shift;
   my $caller = caller;
   no strict 'refs';
   *{$caller.'::xml_valid'}          = \&xml_valid;
   *{$caller.'::xml_node'}           = \&xml_node;
   *{$caller.'::xml_is'}             = \&xml_is;
   *{$caller.'::xml_is_long'}        = \&xml_is_long;
   *{$caller.'::xml_is_deeply'}      = \&xml_is_deeply;
   *{$caller.'::xml_is_deeply_long'} = \&xml_is_deeply_long;
   *{$caller.'::xml_like'}           = \&xml_like;
   *{$caller.'::xml_like_long'}      = \&xml_like_long;

   $Test->exported_to($caller);
   $Test->plan(@_);
}

sub xml_valid($;$) {
  my ($xml, $comment) = @_;
  my $parsed_xml = _valid_xml($xml);
  return 0 unless $parsed_xml;

  ok $parsed_xml, $comment;
}

sub _valid_xml {
  my $xml = shift;

  local $Test::Builder::Level = $Test::Builder::Level + 2;
  return fail("XML is not defined") unless defined $xml;
  return fail("XML is missing")     unless $xml;
  if ( ref $xml ) {
      return fail("accept only 'XML::LibXML::Document' as object") unless ref $xml eq 'XML::LibXML::Document';
      $Xml = $xml;
  }
  else {
    return fail("string can't contain XML: no tags")
      unless ($xml =~ //);
    eval { $Xml = XML::LibXML->new->parse_string($xml); };
    do { chomp $@; return fail($@) } if $@;
  }
  return $Xml;
}

sub _find {
  my ($xml_xpath, $xpath) = @_;
  my @nodeset = $xml_xpath->findnodes($xpath);
  local $Test::Builder::Level = $Test::Builder::Level + 2;
  return fail("Couldn't find $xpath") unless @nodeset;
  wantarray ? @nodeset : \@nodeset;
}


sub xml_node($$;$) {
  my ($xml, $xpath, $comment) = @_;

  my $parsed_xml = _valid_xml($xml);
  return 0 unless $parsed_xml;

  my $nodeset = _find($parsed_xml, $xpath);
  return 0 if !$nodeset;

  ok(scalar @$nodeset, $comment);
}


sub xml_is($$$;$) {
  return _xml_is( \&is_string, @_ );
}

sub xml_is_long($$$;$) {
  _xml_is(\&is, @_);
}

sub _xml_is {
  my ($comp_sub, $xml, $xpath, $value, $comment) = @_;

  local $Test::Builder::Level = $Test::Builder::Level + 2;
  my $parsed_xml = _valid_xml($xml);
  return 0 unless $parsed_xml;

  my $nodeset = _find($parsed_xml, $xpath);
  return 0 if !$nodeset;

  my $ok = 1;
  foreach my $node (@$nodeset) {
    my @kids = $node->getChildNodes;
    my $node_ok;
    if (@kids) {
      $node_ok = $comp_sub->( $kids[0]->toString, $value, $comment );
    }
    else {
      my $got = $node->toString;
      $got =~ s/^.*="(.*)"/$1/;
      $node_ok = is $got, $value, $comment;
    }

    # returns NOT OK if even one of tests fails
    $ok = 0 unless $node_ok;
  }

  return $ok;
}

sub xml_is_deeply($$$;$) {
  _xml_is_deeply(\&is_string, @_);
}

sub xml_is_deeply_long($$$;$) {
  _xml_is_deeply(\&is, @_);
}

sub _xml_is_deeply {
  my ($is_sub, $xml, $xpath, $candidate, $comment) = @_;

  my $parsed_xml = _valid_xml($xml);
  return 0 unless $parsed_xml;

  my $candidate_xp;
  eval {$candidate_xp = XML::LibXML->new->parse_string($candidate) };
  return 0 unless $candidate_xp;

  my $parsed_thing    = $parsed_xml->findnodes($xpath)->[0];
  my $candidate_thing = $candidate_xp->findnodes('/')->[0];

  $candidate_thing = $candidate_thing->documentElement
    if $parsed_thing->isa('XML::LibXML::Element');

  $is_sub->($parsed_thing->toString,
            $candidate_thing->toString,
            $comment);
}

sub xml_like($$$;$) {
  _xml_like(\&like_string, @_);
}

sub xml_like_long($$$;$) {
  _xml_like(\&like, @_);
}

sub _xml_like {
  my ($like_sub, $xml, $xpath, $regex, $comment) = @_;

  my $parsed_xml = _valid_xml($xml);
  return 0 unless $parsed_xml;

  my $nodeset = _find($parsed_xml, $xpath);
  return 0 if !$nodeset;

  foreach my $node (@$nodeset) {
    my @kids = $node->getChildNodes;
    my $found;
    if (@kids) {
      foreach my $kid (@kids) {
        if ($kid->toString =~ /$regex/) {
          $found = 1;
          return $like_sub->($kid->toString, $regex, $comment);
        }
      }
      if (! $found) {
        $comment = "(no comment)" unless defined $comment;
	local $Test::Builder::Level = $Test::Builder::Level + 2;
        return ok(0, "$comment - no match in tag contents (including CDATA)");
      }
    }
    else {
      my $got =  $node->toString;
      $got =~ s/^.*="(.*)"/$1/;
      local $Test::Builder::Level = $Test::Builder::Level + 2;
      return $like_sub->( $got, $regex, $comment );
    }
  }
}

1;
__END__