Test::XML::Simple - easy testing for XML

  use Test::XML::Simple tests=>5;
  xml_valid $xml, "Is valid XML";
  xml_node $xml, "/xpath/expression", "specified xpath node is present";
  xml_is, $xml, '/xpath/expr', "expected value", "specified text present";
  xml_like, $xml, '/xpath/expr', qr/expected/, "regex text present";
  xml_is_deeply, $xml, '/xpath/expr', $xml2, "structure and contents match";

  # Not yet implemented:
  # xml_like_deeply would be nice too...

package Test::XML::Simple;

use strict;
use warnings;

our $VERSION = '1.00';

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

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

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;
  return $Xml if defined($xml) and $xml eq $last_xml_string;
 
  local $Test::Builder::Level = $Test::Builder::Level + 2; 
  return fail("XML is not defined") unless defined $xml;
  return fail("XML is missing")     unless $xml;
  return fail("string can't contain XML: no tags") 
    unless ($xml =~ /</ and $xml =~/>/);
  eval {$Xml = XML::LibXML->new->parse_string($xml)};
  $@ ? do { chomp $@; return fail($@) }
     : 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($$$;$) {
  _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;

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

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->(like $got, $regex, $comment);
    }
  }
}

1;
__END__