App::SimpleScan::TestSpec - store a test spec, and transform it into test code

    use App::SimpleScan:TestSpec;
    App::SimpleScan::TestSpec->app($app_simplescan_object);
    my $spec = App::SimpleScan::TestSpec->new($test_spec_line);

    # Fetch the (raw) URI portion of the test spec.
    my $uri  = $spec->uri();

    # Fetch the (raw) regex portion of the spec.
    my $regex = $spec->regex();

    # Fetch the regex delimiter.
    my $delim = $spec->delim;

    # Fetch the kind of test this is.
    my $delim = $spec->kind;

    # Fetch the comment.
    my $comment = $spec->comment();

    # Expand the test spec into test code.
    # Substitutions should already have been done at this point
    my @tests = $spec->as_tests();

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 "<uri>",
          qr<delim><regex><delim><flags>,
          qq(<comment> [<uri>] [<qmregex> should match]);
EOS
    'N' => <<"EOS",
page_unlike "<uri>",
            qr<delim><regex><delim><flags>,
            qq(<comment> [<uri>] [<qmregex> shouldn't match]);
EOS
    'TY' => <<"EOS",
TODO: {
  local \$Test::WWW::Simple::TODO = "Doesn't match now but should later";
  page_like "<uri>",
            qr<delim><regex><delim><flags>,
            qq(<comment> [<uri>] [<qmregex> should match]);
}
EOS
    'TN' => <<"EOS",
TODO: {
  local \$Test::WWW::Simple::TODO = "Matches now but shouldn't later";
  page_unlike "<uri>",
              qr<delim><regex><delim><flags>,
              qq(<comment> [<uri>] [<qmregex> shouldn't match]);
}
EOS
    'SY' => <<"EOS",
SKIP: {
  skip 'Deliberately skipping test that should match', 1; 
  page_like "<uri>",
            qr<delim><regex><delim><flags>,
            qq(<comment> [<uri>] [<qmregex> should match]);
}
EOS
    'SN' => <<"EOS",
SKIP: {
  skip "Deliberately skipping test that shouldn't match", 1; 
  page_unlike "<uri>",
              qr<delim><regex><delim><flags>,
              qq(<comment> [<uri>] [<qmregex> 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(<<EOS);
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>/$uri/mxg;
       $tests[$current] =~ s/<delim>/$delim/mxg;
       if ($self->metaquote) {
         $tests[$current] =~ s/<regex>/\Q$regex\E/mxg;
       }
       else {
         $tests[$current] =~ s/<regex>/$regex/mxg;
       }
       $tests[$current] =~ s/<flags>/$flags/mxg;
       $tests[$current] =~ s/<comment>/$comment/mx;
       my $qregex = $self->_render_regex();
       $tests[$current] =~ s/<qmregex>/$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__