File Coverage

blib/lib/Test/XML/Loy.pm

Criterion	Covered	Total	%
statement	65	65	100.0
branch	4	6	66.6
condition	2	5	40.0
subroutine	25	25	100.0
pod	16	16	100.0
total	112	117	95.7

package Test::XML::Loy;
use Mojo::Base -base;
use Mojo::Util 'encode';
use XML::Loy;
use Test::More;

has [qw!loy success!];

# Constructor
sub new {
  my $self = shift->SUPER::new;
  $self->loy(XML::Loy->new(shift));
  return $self
};


# Check for exact attribute match
sub attr_is {
  my ($self, $selector, $attr, $value, $desc) = @_;
  $desc = _desc(
    $desc,
    qq{exact match for attribute "$attr" at selector "$selector"}
  );
  return $self->_test(
    'is', $self->_attr($selector, $attr), $value, $desc
  );
};


# Check for attribute mismatch
sub attr_isnt {
  my ($self, $selector, $attr, $value, $desc) = @_;
  $desc = _desc(
    $desc,
    qq{no match for attribute "$attr" at selector "$selector"}
  );
  return $self->_test(
    'isnt', $self->_attr($selector, $attr), $value, $desc
  );
};


# Check for attribute similarity
sub attr_like {
  my ($self, $selector, $attr, $regex, $desc) = @_;
  $desc = _desc(
    $desc,
    qq{similar match for attribute "$attr" at selector "$selector"}
  );
  return $self->_test(
    'like', $self->_attr($selector, $attr), $regex, $desc
  );
};


# Check for attribute dissimilarity
sub attr_unlike {
  my ($self, $selector, $attr, $regex, $desc) = @_;
  $desc = _desc(
    $desc,
    qq{no similar match for attribute "$attr" at selector "$selector"}
  );
  return $self->_test(
    'unlike',
    $self->_attr($selector, $attr), $regex, $desc
  );
};


# Check for plain text match
sub content_is {
  my ($self, $value, $desc) = @_;
  return $self->_test(
    'is',
    $self->_loy_text,
    $value,
    _desc($desc, 'exact match for content')
  );
};


# Check for plain text mismatch
sub content_isnt {
  my ($self, $value, $desc) = @_;
  return $self->_test(
    'isnt',
    $self->_loy_text,
    $value,
    _desc($desc, 'no match for content')
  );
};


# Check for plain text similarity
sub content_like {
  my ($self, $regex, $desc) = @_;
  return $self->_test(
    'like',
    $self->_loy_text,
    $regex,
    _desc($desc, 'content is similar')
  );
};


# Check for plain text dissimilarity
sub content_unlike {
  my ($self, $regex, $desc) = @_;
  return $self->_test(
    'unlike',
    $self->_loy_text,
    $regex,
    _desc($desc, 'content is not similar')
  );
};


# Test for element occurrences
sub element_count_is {
  my ($self, $selector, $count, $desc) = @_;
  my $size = $self->loy->find($selector)->size;
  return $self->_test(
    'is',
    $size,
    $count,
    _desc($desc, qq{element count for selector "$selector"})
  );
};


# Test for element existence
sub element_exists {
  my ($self, $selector, $desc) = @_;
  $desc = _desc(
    $desc,
    qq{element for selector "$selector" exists}
  );
  return $self->_test(
    'ok',
    $self->loy->at($selector),
    $desc
  );
};


# Test for missing element
sub element_exists_not {
  my ($self, $selector, $desc) = @_;
  $desc = _desc(
    $desc,
    qq{no element for selector "$selector"}
  );
  return $self->_test(
    'ok',
    !$self->loy->at($selector),
    $desc
  );
};


# Test for exact pcdata match
sub text_is {
  my ($self, $selector, $value, $desc) = @_;
  return $self->_test(
    'is',
    $self->_text($selector),
    $value,
    _desc($desc, qq{exact match for selector "$selector"})
  );
};


# Test for pcdata mismatch
sub text_isnt {
  my ($self, $selector, $value, $desc) = @_;
  return $self->_test(
    'isnt',
    $self->_text($selector),
    $value,
    _desc($desc, qq{no match for selector "$selector"})
  );
};


# Test for pcdata similarity
sub text_like {
  my ($self, $selector, $regex, $desc) = @_;
  return $self->_test(
    'like',
    $self->_text($selector),
    $regex,
    _desc($desc, qq{similar match for selector "$selector"})
  );
};


# Test for pcdata dissimilarity
sub text_unlike {
  my ($self, $selector, $regex, $desc) = @_;
  return $self->_test(
    'unlike',
    $self->_text($selector),
    $regex,
    _desc($desc, qq{no similar match for selector "$selector"})
  );
};


sub _desc {
  encode 'UTF-8', shift || shift;
};


sub _attr {
  my ($self, $selector, $attr) = @_;
  return '' unless my $e = $self->loy->at($selector);
  return $e->attr($attr) || '';
};


sub _test {
  my ($self, $name, @args) = @_;
  local $Test::Builder::Level = $Test::Builder::Level + 2;
  return $self->success(!!Test::More->can($name)->(@args));
};


sub _text {
  return '' unless my $e = shift->loy->at(shift);
  return $e->text;
};


sub _loy_text {
  my $self = shift;
  return $self->{_data} if $self->{_data};
  $self->{_data} = $self->loy->to_pretty_xml;
  return $self->{_data};
};


1;


__END__