File Coverage

blib/lib/Test/XMLElement.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Test::XMLElement;
use strict;
use warnings;

our $VERSION = '0.04';

use Test::Builder;
use XML::Twig;
use XML::XPath;
use XML::Twig::XPath;

my $Tst = Test::Builder->new();
my $XML;
my $LAST = '';

## Import subroutine is inspired by Test::Pod import method

sub import {
   my $self = shift;
   my $caller = caller;
   no strict 'refs';
   *{$caller.'::have_child'}         = \&have_child;
   *{$caller.'::have_child_name'}    = \&have_child_name;
   *{$caller.'::child_count_is'}     = \&child_count_is;
   *{$caller.'::is_empty'}           = \&is_empty;
   *{$caller.'::has_attributes'}     = \&has_attributes;
   *{$caller.'::has_no_attrib'}      = \&has_no_attrib;
   *{$caller.'::number_of_attribs'}  = \&number_of_attribs;
   *{$caller.'::attrib_value'}       = \&attrib_value;
   *{$caller.'::attrib_name'}        = \&attrib_name;
   *{$caller.'::nth_child_name'}     = \&nth_child_name;
   *{$caller.'::all_children_are'}   = \&all_children_are;
   *{$caller.'::child_has_cdata'}    = \&child_has_cdata;
   *{$caller.'::is_descendants'}     = \&is_descendants;
   *{$caller.'::is_xpath'}           = \&is_xpath;
   *{$caller.'::is_xpath_count'}     = \&is_xpath_count;

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



sub have_child {
  my ($elt, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  return
	  (
	     $Tst->ok(scalar(_child_elements($valid_elt)),$msg) ||
	     $Tst->diag("Element ",$valid_elt->name," do not have any children")
       );
}

sub have_child_name {
  my ($elt, $name, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  my @child = _child_elements($valid_elt);
  return
	  (
	     $Tst->ok(scalar(@child),$msg) ||
	     $Tst->diag("Element ",$valid_elt->name," do not have any children")
	  ) unless (@child);
  return
	  (
	     $Tst->ok(scalar(grep {$_->name eq $name} @child), $msg) ||
	     $Tst->diag("Element \'",$valid_elt->name,"\' do not have any child named $name")
      );
}

sub nth_child_name {
  my ($elt, $n, $name, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  my @child = _child_elements($valid_elt);
  return
	  (
	     $Tst->ok(scalar(@child),$msg) ||
	     $Tst->diag("Element ",$valid_elt->name," do not have any children")
	  ) unless (@child);
  return
	  (
	     $Tst->is_eq( $child[$n - 1]->name,$name, $msg) ||
	     $Tst->diag("Element \'",$valid_elt->name,"\' do not have ",$n - 1," child named $name")
      );
}

sub all_children_are {
  my ($elt, $name, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  my @child = _child_elements($valid_elt);
  return
	  (
	     $Tst->ok(scalar(@child),$msg) ||
	     $Tst->diag("Element ",$valid_elt->name," do not have any children")
	  ) unless (@child);
  return
	  (
	     $Tst->is_num( scalar (grep {$_->name eq $name} @child), scalar @child,  $msg) ||
	     $Tst->diag("Element \'",$valid_elt->name,"\' do not have all child named $name")
      );
}


sub child_count_is {
  my ($elt, $num, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  my @child = _child_elements($valid_elt);
  return
	  (
	     $Tst->is_num(scalar(@child), $num, $msg) ||
	     $Tst->diag("Element \'",$valid_elt->name,"\' do not have $num children")
      );
}

sub is_empty {
  my ($elt, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  return
	  (
	     $Tst->ok($valid_elt->is_empty, $msg) ||
	     $Tst->diag("Element ",$valid_elt->name," is not empty")
       );
}

sub has_attributes {
  my ($elt, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  return
	  (
	     $Tst->ok($valid_elt->has_atts, $msg) ||
	     $Tst->diag("Element ",$valid_elt->name," dont have attributes")
	  );
}

sub has_no_attrib {
  my ($elt, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  return
	  (
	     $Tst->ok($valid_elt->has_no_atts, $msg) ||
	     $Tst->diag("Element ",$valid_elt->name," have attributes")
	  );
}

sub number_of_attribs {
  my ($elt, $num, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  return
	  (
	     $Tst->is_num($valid_elt->att_nb, $num, $msg) ||
	     $Tst->diag("Element ",$valid_elt->name," have ",$valid_elt->att_nb," attributes")
	  );
}

sub attrib_name {
  my ($elt, $name, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  my @atts = $valid_elt->att_names;
  return
	  (
	     $Tst->ok(scalar(@atts),$msg) ||
	     $Tst->diag("Element ",$valid_elt->name," do not have any attributes")
	  ) unless (@atts);
  return
	  (
	     $Tst->ok(scalar(grep {$_ eq $name} @atts), $msg) ||
	     $Tst->diag("Element \'",$valid_elt->name,"\' do not have any attribute named $name")
      );
}


sub attrib_value {
  my ($elt, $name, $value, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  my @atts = $valid_elt->att_names;
  return
	  (
	     $Tst->ok(scalar(@atts),$msg) ||
	     $Tst->diag("Element ",$valid_elt->name," do not have any attributes")
	  ) unless (@atts);
  return
	  (
	     $Tst->is_eq($valid_elt->att($name), $value, $msg) ||
	     $Tst->diag("Element \'",$valid_elt->name,"\' do not have any attribute named $name")
      );
}

sub child_has_cdata {
  my ($elt, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  my @cdata = grep {$_->is_cdata} $valid_elt->children;
  return
	  (
	     $Tst->ok(scalar(@cdata),$msg) ||
	     $Tst->diag("Element ",$valid_elt->name," do not have any CDATA")
	  )
}

sub is_descendants {
  my ($elt, $name, $msg) = @_;
  my $valid_elt = _parse($elt,$msg);
  return 0 unless $valid_elt;
  return
	  (
	     $Tst->ok(scalar($valid_elt->descendants($name)),$msg) ||
	     $Tst->diag("Element ",$valid_elt->name," do not have any descendants for $name")
	  );
}

sub is_xpath {
    my ($elt, $xpath, $msg) = @_;
    my $valid_elt = _parse($elt,$msg,"xpath");
	my @xp_cnt;
    return 0 unless $valid_elt;
	eval {
     @xp_cnt = $valid_elt->findnodes($xpath,$valid_elt->root);
    };
	return
	  (
	     $Tst->ok(0,$msg) ||
	     $Tst->diag("Failed due to $@")
	  ) if $@;

	return
	  (
	     $Tst->ok(scalar(@xp_cnt),$msg) ||
	     $Tst->diag("Element ",$valid_elt->root->name," do not have elements matching $xpath")
	  );
}

sub is_xpath_count {
    my ($elt, $xpath, $count, $msg) = @_;
    my $valid_elt = _parse($elt,$msg,"xpath");
	my @xp_cnt;
    return 0 unless $valid_elt;
	eval {
     @xp_cnt = $valid_elt->findnodes($xpath,$valid_elt->root);
    };
	return
	  (
	     $Tst->ok(0,$msg) ||
	     $Tst->diag("Failed due to $@")
	  ) if $@;

	return
	  (
	     $Tst->is_num(scalar(@xp_cnt),$count,$msg) ||
	     $Tst->diag("XPath expression $xpath did not had same elements as required count $count")
	  );
}

### Private Subroutines ##

sub _parse {
  local $Test::Builder::Level += 2;
  my $string = shift or return $Tst->diag("XML String is not defined");
  my $msg    = shift;
  my $xp     = shift;
  return $XML if ($string eq $LAST);
  if (not $xp) {
    eval {
      $XML = parse XML::Twig::Elt($string);
    };
  }
  else {
   eval {
	   $XML = parse XML::Twig::XPath($string);
   };
  }
    $@ ? ($Tst->ok(0,$msg)||$Tst->diag($@)) : $XML;
}

sub _child_elements {
  my ($elt) = shift;
  return grep {$_->is_elt} $elt->children;
}

1;
__END__