File Coverage

blib/lib/App/SimpleScan/TestSpec.pm

Criterion	Covered	Total	%
statement	12	102	11.7
branch	0	38	0.0
condition	0	11	0.0
subroutine	4	9	44.4
pod	4	4	100.0
total	20	164	12.2

package App::SimpleScan::TestSpec;
use strict;
use warnings;
use Regexp::Common;

use base qw(Class::Accessor::Fast);
our $VERSION = 0.24;

__PACKAGE__->mk_accessors(qw(raw uri regex delim kind comment metaquote syntax_error flags test_count));

my $app;     # Will store a reference to the parent App::Simplescan

my %test_type =
  (
    'Y' => <<"EOS",
page_like "",
          qr,
          qq( [] [ should match]);
EOS
    'N' => <<"EOS",
page_unlike "",
            qr,
            qq( [] [ shouldn't match]);
EOS
    'TY' => <<"EOS",
TODO: {
  local \$Test::WWW::Simple::TODO = "Doesn't match now but should later";
  page_like "",
            qr,
            qq( [] [ should match]);
}
EOS
    'TN' => <<"EOS",
TODO: {
  local \$Test::WWW::Simple::TODO = "Matches now but shouldn't later";
  page_unlike "",
              qr,
              qq( [] [ shouldn't match]);
}
EOS
    'SY' => <<"EOS",
SKIP: {
  skip 'Deliberately skipping test that should match', 1;
  page_like "",
            qr,
            qq( [] [ should match]);
}
EOS
    'SN' => <<"EOS",
SKIP: {
  skip "Deliberately skipping test that shouldn't match", 1;
  page_unlike "",
              qr,
              qq( [] [ shouldn't match]);
}
EOS
  );

sub app {
  my ($class_or_object, $appref) = @_;
  if (defined $appref) {
    $app = $appref;
  }
  return $app;
}

sub new {
  my ($class, $spec) = @_;
  my $self = {};
  bless $self, $class;

  # Store the test spec.
  $self->raw($spec);
  $self->test_count(0);
  $self->syntax_error(!$self->parse);

  return $self;
}

sub parse {
  my ($self, $line) = @_;
  if (!defined $line) {
    $line = $self->raw;
  }
  chomp $line;

  # Originally, we used Regex::Common to parse the URI and regex
  # off the test spec line, but that's not going to work now since
  # we've switched to keeping the text substitutions in place
  # until we're ready to expand the spec into tests.
  #
  # So we'll do it like this: remove everything up to the first
  # set of whitespace and call it the URI. *Reverse* the string,
  # and match everything up to the whitespace before the kind of
  # test; this grabs off the comment and the kind.
  #
  # We treat whatever is left at this point as the regex, in
  # three phases. First, is it a standard slash-delimited
  # regex? If not, is it an m-style regex (m| ...|, with
  # arbitrary quote characters)? If not, then we treat it as
  # a literal string to match (stripping off the slashes on
  # either end if they are there.

  # Remove URI portion.
  my ($URI, $rest) = ($line =~ /^(.*?)\s+(.*)$/mx);

  if (! defined $URI) {
    return 0;
  }

  # Pull the scheme from the URI and pass it explicitly to
  # Regexp::Common. Otherwise Regexp::Common::URI::http
  #  assumes 'HTTP', meaning that any other scheme won't match,
  #  causing this code to ignore (for instance) https: links.
  #
  # We also check for messed-up schemes here: a common error is
  # to have left off on % on a pragma, causing the line to be
  # passed into this code.
  my ($scheme) = $URI =~ /^(\w+)/mx;
  if (!defined $scheme) {
    $app->stack_test(<
fail "malformed pragma or URL scheme: '$URI'";
EOS
    return 0;
  }
  # Not the canonical single-precent error. See if it's a good scheme.
  return 0 if !($URI =~ /$RE{URI}{HTTP}{-scheme => $scheme }/mx);

  # Remove comment and kind.
  my ($comment, undef, $kind, $maybe_regex) =
    ((scalar reverse $rest) =~ /^(.*?)(\s+|\s*)\b(Y|N|YT|NT|YS|NS)\s+(.*)$/mx);
  $self->comment(scalar reverse $comment);
  $self->kind(scalar reverse $kind);
  $self->uri($URI);

  my($clean, $delim, $flags);

  # Clean up regex if needed.
  my $regex = reverse $maybe_regex;
  if ((undef, undef, $clean, undef, $flags) =
       ($regex =~ m|^$RE{delimited}{-delim=>'/'}{-keep}([ics]*)$|mx)) {
    # Standard slash-delimited regex.
    $self->regex($clean);
    $self->delim('/');
    $self->flags($flags);
  }
  elsif (($delim, $clean, $flags) = ($regex =~ /^m(.)(.*)\1([ics]*)$/mx)) {
    # m-something-regex-something pattern.
    $self->delim($1);
    $self->regex($clean);
    $self->flags($flags);
  }
  elsif (($clean, $flags) = ($regex =~ m|^/(.*)/([ics]*)$|mx)) {
    # slash-delimited, with flags.
    $self->delim('/');
    $self->regex($clean);
    $self->metaquote(1);
    $self->flags($flags);
  }
  else {
    # random string. We'll metaquote it and put slashes around it.
    $self->delim('/');
    $self->regex($regex);
    $self->metaquote(1);
  }

  if (! defined $self->flags) {
    $self->flags(q{});
  }

  # If we got this far, it's valid.
  return 1;
}

sub _render_regex {
  my ($self) = shift;
  my $regex = $self->regex;
  my $delim = $self->delim;
  my $flags = $self->flags;
  if (!defined $flags) {
    $self->flags(q{});
    $flags = q{};
  }

  if ($self->metaquote) {
    $regex = "\\Q$regex\\E";
  }
  if ($delim ne '/') {
    $regex = "m$delim$regex$delim";
  }
  else {
    $regex = "/$regex/";
  }
  if ($flags) {
    $regex .= $flags;
  }
  if ($regex =~ /\\/mx) {
    # Have to escape backslashes.
    $regex =~ s/\\/\\\\/mxg;
  }

  return $regex;
}

sub as_tests {
  my ($self) = @_;
  my @tests;
  my $current = 0;
  my $flags = $self->flags() || q{};
  my $uri = $self->uri;

  if (defined $uri and
      defined(my $regex =   $self->regex) and
      defined(my $delim =   $self->delim) and
      defined(my $comment = $self->comment)) {                  ##no critic
    if (defined($tests[$current] = $test_type{$self->kind})) {  ##no critic
       $self->test_count($self->test_count()+1);
       $tests[$current] =~ s//$uri/mxg;
       $tests[$current] =~ s//$delim/mxg;
       if ($self->metaquote) {
         $tests[$current] =~ s//\Q$regex\E/mxg;
       }
       else {
         $tests[$current] =~ s//$regex/mxg;
       }
       $tests[$current] =~ s//$flags/mxg;
       $tests[$current] =~ s//$comment/mx;
       my $qregex = $self->_render_regex();
       $tests[$current] =~ s//$qregex/emx;
    }
  }

  # Call any plugin per_test routines.
  for my $test_code (@tests) {
    $app->stack_test($test_code);
    for my $plugin ($app->plugins) {
      next if ! $plugin->can('per_test');

      my ($added_tests, @per_test_code) = $plugin->per_test($self);
      my $method = $added_tests ? 'stack_test' : 'stack_code';
      for my $code_line (@per_test_code) {
        $app->$method($code_line);
      }
    }
  }
  return;
}

1; # Magic true value required at end of module
__END__