view release on metacpan or  search on metacpan

lib/Test/XML/Loy.pm  view on Meta::CPAN

    _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__

=pod

=encoding utf8

=head1 NAME

Test::XML::Loy - Test XML and XML::Loy objects


=head1 SYNOPSIS