view release on metacpan or  search on metacpan

lib/App/SimpleScan.pm  view on Meta::CPAN

# this lets them load that module so the
# tests actually work.)
#
# Also adds the test plan.
#
# Finally, initializes the user agent (unless
# we're specifically directed *not* to do so).
sub finalize_tests {
  my ($self) = @_;
  my @tests = @{$self->tests};
  my @prepends;
  foreach my $plugin (__PACKAGE__->plugins) {
    if ($plugin->can('test_modules')) {
      foreach my $module ($plugin->test_modules) {
        push @prepends, "use $module;\n";
      }
    }
  }
  # Handle conditional user agent initialization.
  # This was added because some servers (e.g., WAP
  # servers) refuse connections from known user agents,
  # but others (e.g., Yahoo!'s web servers) refuse
  # login attempts from non-browser user agents.
  #
  # Set the user agent unless --no-agent was given.

  if (!$self->no_agent) {
    push @prepends, qq(mech->agent_alias("Windows IE 6");\n);
  }

  # Add the boilerplate testing stuff.
  unshift @prepends,
    (
      "use Test::More tests=>@{[$self->test_count]};\n",
      "use Test::WWW::Simple;\n",
      "use strict;\n",
      "\n",
    );


  $self->tests( [ @prepends, @tests ] );
  return;
}

#######################
# External utility methods.

# Handle backticked values in substitutions.
sub expand_backticked {
  use re 'eval';

  my ($self, $text) = @_;

  # The state machine was a really cool idea, except it didn't work. :-P
  # A little reading in Mastering Regular Expressions gave me the patterns
  # shown below for matching quoted strings.

  # For an explanation of why this works, see Friedl, p. 262 ff.
  # It's called "unrolling" the regex there.

  #  Pattern: quote (nonspecial)*(escape anything (nonspecial)*)* quote
  my $qregex  = qr/'[^'\\]*(?:\\.[^'\\]*)*'/;
  my $qqregex = qr/"[^"\\]*(?:\\.[^"\\]*)*"/;
  my $qxregex = qr/`[^`\\]*(?:\\.[^`\\]*)*`/;

  # Plus we need the cleanup tokenizer: match anything nonblank. This
  # picks up tokens that are not properly-balanced quoted strings.
  # We'll trap those later, or not. We'll see.
  my $cleanup = qr/\S+/;

  # An item is a quoted string of any flavor, or the cleanup item.
  # We turn on the capturing parens here because it we match an item,
  # we want it.
  my $item = qr/($qqregex|$qregex|$qxregex|$cleanup)/;

  # So now, to extract the items, we just match this with /g against the
  # incoming text. We know already this is a single line, so we don't need
  # any other switches. Boy, that's simpler.
  my @data = ($text =~ /$item/g);

  # Evaluate the tokens.
  my @result;
  local $_;
  for (@data) {
    next unless defined;

    # Backticked: eval and process again.
    if (/^\`(.*)`$/mx) {
      push @result, $self->expand_backticked(eval $_);      ##no critic
    }
    # Double-quoted: eval it.
    elsif (/^"(.*)"$/mx) {
      my $to_be_evaled = $1;
      my @substituted = $self->sub_engine->expand($to_be_evaled);
      push @result, map { eval $_ } @substituted;          ##no critic
    }
    # Single-quoted: remove quotes.
    elsif (/^'(.*)'$/mx) {
      push @result, $1;
    }
    # Just an unquoted token. Save it.
    else {
      push @result, $_;
    }
  }
  return @result;
}

sub set_current_spec {
  my ($self, $testspec) = @_;
  $self->{CurrentTestSpec} = $testspec;
  return $testspec;
}

sub get_current_spec {
  my ($self) = @_;
  return $self->{CurrentTestSpec};
}

# If there are any substitutions, build them, stack them on the input,
# and return true. Otherwise, just return false so the line will be passed on.