Test::XML::Easy - test XML with XML::Easy

    use Test::More tests => 2;
    use Test::XML::Easy;

    is_xml $some_xml, <<'ENDOFXML', "a test";
    <?xml version="1.0" encoding="latin-1">
    <foo>
       <bar/>
       <baz buzz="bizz">fuzz</baz>
    </foo>
    ENDOFXML

    is_xml $some_xml, <<'ENDOFXML', { ignore_whitespace => 1, description => "my test" };
    <foo>
       <bar/>
       <baz buzz="bizz">fuzz</baz>
    </foo>
    ENDOFXML

    isnt_xml $some_xml, $some_xml_it_must_not_be;

    is_well_formed_xml $some_xml;

package Test::XML::Easy;

use strict;
use warnings;

use vars qw(@EXPORT @ISA);
use Exporter;
@ISA = qw(Exporter);

our $VERSION = '0.01';

use Carp qw(croak);

use XML::Easy::Text qw(xml10_read_document xml10_write_document);
use XML::Easy::Classify qw(is_xml_element);
use XML::Easy::Syntax qw($xml10_s_rx);

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

sub is_xml($$;$) {
  my $got = shift;
  my $expected = shift;

  unless (defined $expected) {
    croak("expected argument must be defined");
  }

  # munge the options

  my $got_original      = $got;
  my $expected_original = $expected;

  my $options = shift;
  $options = { description => $options } unless ref $options eq "HASH";
  $options = { %{$options}, description => "xml test" } unless defined $options->{description};
  unless (is_xml_element($expected)) {
    # throws an exception if there isn't a problem.
    $expected = eval { xml10_read_document($expected) };
    if ($@) {
      croak "Couldn't parse expected XML document: $@";
    }
  }

  # convert into something useful if needed
  unless (is_xml_element($got)) {
    my $parsed = eval { xml10_read_document($got) };
    if ($@) {
      $tester->ok(0, $options->{description});
      $tester->diag("Couldn't parse submitted XML document:");
      $tester->diag("  $@");
      return;
    }

    $got = $parsed;
  }

  if(_is_xml($got,$expected,$options,"", {})) {
    $tester->ok(1,$options->{description});
    return 1;
  }

  if ($options->{show_xml}) {
    $tester->diag("The XML that we expected was:");
    if (is_xml_element($expected_original))
      { $tester->diag(xml10_write_document($expected_original)) }
    else
      { $tester->diag($expected_original) }

    $tester->diag("The XML that we received was:");
    if (is_xml_element($got_original))
      { $tester->diag(xml10_write_document($got_original)) }
    else
      { $tester->diag($got_original) }
  }

  return;
}
push @EXPORT, "is_xml";

sub _is_xml {
  my $got = shift;
  my $expected = shift;
  my $options  = shift;

  # this is the path
  my $path     = shift;

  # the index is used to keep track of how many of a particular
  # typename of a particular element we've seen as previous siblings
  # of the node that just got in.  It's a hashref with type_name and
  # the index.
  my $index    = shift;

  # change where the errors are reported from
  local $Test::Builder::Level = $Test::Builder::Level + 1;

  # work out the details of the node we're looking at
  # nb add one to the index because xpath is weirdly 1-index
  # not 0-indexed like most other modern languages
  my $got_name       = $got->type_name();
  my $got_index      = ($index->{ $got_name } || 0) + 1;

  ### check if we've got a node to compare to

  unless ($expected) {
    $tester->ok(0, $options->{description});
    $tester->diag("Element '$path/$got_name\[$got_index]' was not expected");
    return;
  }

  ### check the node name

  # work out the details of the node we're comparing with
  my $expected_name  = $expected->type_name();
  my $expected_index = ($index->{ $expected_name } || 0) + 1;

  # alter the index hashref to record we've seen another node
  # of this name
  $index->{$got_name}++;

  $tester->diag("comparing '$path/$got_name\[$expected_index]' to '$path/$expected_name\[$expected_index]'...") if $options->{verbose};

  if ($got_name ne $expected_name) {
    $tester->ok(0, $options->{description});
    $tester->diag("Element '$path/$got_name\[$got_index]' does not match '$path/$expected_name\[$expected_index]'");
    return;
  }
  $tester->diag("...matched name") if $options->{verbose};

  ### check the attributes

  # we're not looking at decendents, so burn the path of
  # this node into the path we got passed in
  $path .= "/$got_name\[$got_index]";

  # XML::Easy returns read only data structures
  # we want to modify these to keep track of what
  # we've processed, so we need to copy them
  my %got_attr      = %{ $got->attributes };
  my $expected_attr = $expected->attributes;

  foreach my $attr (keys %{ $expected_attr }) {
    $tester->diag("checking attribute '$path/\@$attr'...") if $options->{verbose};

    if (!exists($got_attr{$attr})) {
      $tester->ok(0, $options->{description});
      $tester->diag("expected attribute '$path/\@$attr' not found");
      return;
    }
    $tester->diag("...found attribute") if $options->{verbose};

    my $expected_string = $expected_attr->{$attr};
    my $got_string      = delete $got_attr{$attr};

    if ($expected_string ne $got_string) {
      $tester->ok(0, $options->{description});
      $tester->diag("attribute value for '$path/\@$attr' didn't match");
      $tester->diag("found value:\n");
      $tester->diag("  '$got_string'\n");
      $tester->diag("expected value:\n");
      $tester->diag("  '$expected_string'\n");
      return;
    }
    $tester->diag("...the attribute contents matched") if $options->{verbose};
  }
  if (keys %got_attr) {
    $tester->ok(0, $options->{description});
    $tester->diag("found extra unexpected attribute".(keys %got_attr>1 ? "s":"").":");
    $tester->diag("  '$path/\@$_'") foreach sort keys %got_attr;
    return;
  }
  $tester->diag("the attributes all matched") if $options->{verbose};

  ### check the child nodes

  # create a new index to pass to our children distint from
  # the index that was passed in to us (as that one was created
  # by our parent for me and my siblings)
  my $child_index = {};

  # grab the child text...element...text...element...text...
  my $got_content      = $got->content;
  my $expected_content = $expected->content;

  # step though the text/elements
  # nb this loop works in steps of two;  The other $i++
  # is half way through the loop below
  for (my $i = 0; $i < @{$got_content}; $i++) {

    ### check the text node

    # extract the text from the object
    my $got_text      = $got_content->[ $i ];
    my $expected_text = $expected_content->[ $i ];
    my $comp_got_text      = $got_text;
    my $comp_expected_text = $expected_text;

    if ($options->{ignore_whitespace} || $options->{ignore_leading_whitespace} || $options->{ignore_surrounding_whitespace}) {
      $comp_got_text =~ s/ \A (?:$xml10_s_rx)* //x;
      $comp_expected_text =~ s/ \A (?:$xml10_s_rx)* //x;
    }

    if ($options->{ignore_whitespace} || $options->{ignore_trailing_whitespace} || $options->{ignore_surrounding_whitespace}) {
      $comp_got_text =~ s/ (?:$xml10_s_rx)* \z//x;
      $comp_expected_text =~ s/ (?:$xml10_s_rx)* \z//x;
    }

    if ($options->{ignore_whitespace} || $options->{ignore_different_whitespace}) {
      $comp_got_text =~ s/ (?:$xml10_s_rx)+ / /gx;
      $comp_expected_text =~ s/ (?:$xml10_s_rx)+ / /gx;
    }

    if ($comp_got_text ne $comp_expected_text) {

      $tester->ok(0, $options->{description});

      # I don't like these error message not being specific with xpath but as
      # far as I know  there's no easy way to express in xpath the text immediatly following
      # a particular element.  The best I could come up with was this mouthful:
      # "$path/following-sibling::text()[ previous-sibling::*[1] == $path ]"

      if ($i == 0) {
        if (@{ $got_content } == 1 && @{ $expected_content } == 1) {
          $tester->diag("text inside '$path' didn't match");
        } else {
          $tester->diag("text immediately inside opening tag of '$path' didn't match");
        }
      } elsif ($i == @{ $got_content} - 1 && $i == @{ $expected_content } - 1 ) {
        $tester->diag("text immediately before closing tag of '$path' didn't match");
      } else {
        my $name = $got_content->[ $i - 1 ]->type_name;
        my $ind = $child_index->{ $name };
        $tester->diag("text immediately after '$path/$name\[$ind]' didn't match");
      }

      $tester->diag("found:\n");
      $tester->diag("  '$got_text'\n");
      $tester->diag("expected:\n");
      $tester->diag("  '$expected_text'\n");

      if ($options->{verbose}) {
        $tester->diag("compared found text:\n");
        $tester->diag("  '$comp_got_text'\n");
        $tester->diag("against text:\n");
        $tester->diag("  '$comp_expected_text'\n");
      }

      return;
    }

    # move onto the next (elemnent) node if we didn't reach the end
    $i++;
    last if $i >= @{$got_content};

    ### check the element node

    # simply recurse for that node
    # (don't bother checking if the expected node is defined or not, the case
    # where it isn't is handled at the start of _is_xml)
    return unless _is_xml(
      $got_content->[$i],
      $expected_content->[$i],
      $options,
      $path,
      $child_index
    );
  }

  # check if we expected more nodes
  if (@{ $expected_content } > @{ $got_content }) {
    my $expected_nom = $expected_content->[ scalar @{ $got_content } ]->type_name;
    my $expected_ind = $child_index->{ $expected_nom } + 1;
    $tester->diag("Couldn't find expected node '$path/$expected_nom\[$expected_ind]'");
    $tester->ok(0, $options->{description});
    return;
  }

  return 1;
}

sub isnt_xml($$;$) {
  my $got = shift;
  my $expected = shift;
  my $options = shift;

  $options = { description => $options } unless ref $options eq "HASH";
  $options = { %{$options}, description => "not xml test" }
    unless defined $options->{description};

  # temporarly ignore test output and just get the result of running
  # the is_xml function as normal
  $tester = bless {}, "Test::XML::Easy::Ignore";
  my $result = eval { is_xml($got, $expected, $options) ? 0 : 1 };
  $tester = Test::Builder->new();

  # did we get an error?  Note we don't check $@ directly incase
  # it's been reset by a weird DESTROY() eval...
  unless (defined($result) && length $result) { croak $@; }

  if ($result) {
    $tester->ok(1, $options->{description});
    return 1;
  }

  $tester->ok(0, $options->{description});
  $tester->diag("Unexpectedly matched the XML we didn't expect");
  if ($options->{show_xml}) {
    $tester->diag("The XML that we received was:");
    if (is_xml_element($got))
      { $tester->diag(xml10_write_document($got)) }
    else
      { $tester->diag($got) }
  }
  return;
}
push @EXPORT, "isnt_xml";

sub is_well_formed_xml($;$) {
  my $xml_string = shift;
  my $options = shift;

  $options = { description => $options } unless ref $options eq "HASH";
  $options = { %{$options}, description => "xml well formed test" }
    unless defined $options->{description};

  if(eval { xml10_read_document($xml_string); 1 }) {
    $tester->ok(1, $options->{description});
    return 1;
  }

  $tester->ok(0, $options->{description});
  $tester->diag($@);
  return;
}
push @EXPORT, "is_well_formed_xml";

sub isnt_well_formed_xml($;$) {
  my $xml_string = shift;
  my $options = shift;

  $options = { description => $options } unless ref $options eq "HASH";
  $options = { %{$options}, description => "xml not well formed test" }
    unless defined $options->{description};

  unless (eval { xml10_read_document($xml_string); 1 }) {
    $tester->ok(1, $options->{description});
    return 1;
  }

  $tester->ok(0, $options->{description});
  $tester->diag("Unexpectedly well formed XML");
  return;
}
push @EXPORT, "isnt_well_formed_xml";

1; # End of Test::XML::Easy

package Test::XML::Easy::Ignore;

# a handy class you can bless your tester into so we ignore all
# calls and don't actually produce any test output

sub ok { return }
sub diag { return }

1; # End of Test::XML::Easy::Ignore;