File Coverage

blib/lib/App/SimpleScan.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

package App::SimpleScan;

use warnings;
use strict;
use English qw(-no_match_vars);

our $VERSION = '3.01';

use Carp;
use Getopt::Long;
use Regexp::Common;
use Scalar::Util qw(blessed);
use WWW::Mechanize;
use WWW::Mechanize::Pluggable;
use Test::WWW::Simple;
use App::SimpleScan::TestSpec;
use App::SimpleScan::Substitution;
use Graph;

use Module::Pluggable search_path => [qw(App::SimpleScan::Plugin)];

use base qw(Class::Accessor::Fast);
__PACKAGE__->mk_accessors(qw(sub_engine tests test_count
                             next_line_callbacks _deps));

$|++;                                                   ##no critic

use App::SimpleScan::TestSpec;

my $reference_mech = new WWW::Mechanize::Pluggable;
my $sub_engine     = new App::SimpleScan::Substitution;

my @local_pragma_support =
  (
    ['agent'   => \&_do_agent],
    ['nocache'   => \&_do_nocache],
    ['cache'   => \&_do_cache],
  );

# Variables and setup for basic command-line options.
my($generate, $run, $warn, $override, $defer, $debug);
my($cache_from_cmdline, $no_agent);
my($run_status);

# Option-to-variable mappings for Getopt::Long
my %basic_options =
  ('generate'  => \$generate,
   'run'       => \$run,
   'warn'      => \$warn,
   'override'  => \$override,
   'defer'     => \$defer,
   'debug'     => \$debug,
   'autocache' => \$cache_from_cmdline,
   'no-agent'  => \$no_agent,
   'status'    => \$run_status,
  );

use base qw(Class::Accessor::Fast);

# Patterns to extract  or >variables< from a string.
my $out_angled;
$out_angled = qr/ < ( [^<>] | (??{$out_angled}) )* > /x;
                  # open angle-bracket then ...
                      # non-angle chars ...
                            # or ...
                               # another angle-bracketed item ...
                                                 # if there are any ...
                                                   # and a close angle-bracket
my $in_angled;
$in_angled  = qr/ > ( [^<>] | (??{$in_angled}) )* < /x;
                  # open angle-bracket then ...
                      # non-angle chars ...
                            # or ...
                               # another angle-bracketed item ...
                                                 # if there are any ...
                                                   # and a close angle-bracket
my $in_or_out_bracketed = qr/ ($out_angled) | ($in_angled) /x;

################################
# Basic class methods.

# Create the object.
# - load and install plugins
# - make object available to test specs for callbacks
# - clear the tests and test count
# - process the command-line options
# - return the object
sub new {
  my ($class) = @_;
  my $self = {};
  bless $self, $class;

  $self->_deps(Graph->new);
  $self->sub_engine($sub_engine);

  # initialize fields first; plugins may expect good values.
  $self->next_line_callbacks([]);
  $self->tests([]);
  $self->test_count(0);
  $self->{InputQueue} = [];

  # Load and install the plugins.
  $self->_load_plugins();
  $self->install_pragma_plugins;

  # TestSpec needs to be able to find the App object.
  App::SimpleScan::TestSpec->app($self);

  # Read the command line and process the options.
  $self->handle_options;

  return $self;
}

# Read the test specs and turn them into tests.
# Add any additional code from the plugins.
# Return the tests as a string.
sub create_tests {
  my ($self) = @_;

  $self->transform_test_specs;
  $self->finalize_tests;
  return join q{}, @{$self->tests};
}

# If the tests should be run, run them.
# Return any exceptions to the caller.
sub execute {
  my ($self, $code) = @_;
  eval $code if ${$self->run};                         ##no critic
  return $EVAL_ERROR;
}

# Actually use the object.
# - create tests from input
# - run them if we should
# - print them if we should
sub go {
  my($self) = @_;
  my $exit_code = 0;

  my $code = $self->create_tests;
  # Note the dereference of the scalars here.

  if ($self->test_count) {
    if (my $result = $self->execute($code)) {
       warn $result,"\n";
       $exit_code = 1;
    }
  }
  else {
    if (${$self->warn}) {
      $self->stack_test(qq(fail "No tests were found in your input file.\n"));
      $exit_code = 1;
    }
  }

  if (${$self->generate}) {
    print $code,"\n";
  }

  return $exit_code;
}

# Read files from command line or standard input.
# Turn these from test specs into test code.
sub transform_test_specs {
  my ($self) = @_;
  local $_;                                             ##no critic
  while(defined($_ = $self->next_line)) {               ##no critic
    chomp;
    # Discard comments.
    /^\#/mx and next;

    # Discard blank lines.
    /^\s*$/mx and next;

    # Handle pragmas.
    /^%%      # pragma signifier
     \s*      # optional space
     (.*?)    # arbitrary identifier
     (        # either ...
      (
       (:\s+|\s+)   # an optional colon, and whitespace
       (.*)$        # then a optional value
      )|            # ... or
      $             # nothing at all
     )/mx and do {
      if (my $code = $self->pragma($1)) {
        $code->($self,$5);
      }
      else {
        # It's a substitution if it has no other meaning.
        if (defined $5) {
          my $var = $1;
          # Check if the variable name needs to be substituted.
          if ($var =~ /$in_or_out_bracketed/) {
            next if $self->_queue_substituted_lines($_);
          }
          my @data = $self->expand_backticked($5);
          my ($status, $message) = $self->_check_dependencies($var, @data);
          if ($status) {
            $self->_substitution_data($var, @data);
          }
          else {
            my @items = split $message;
            my $between = (@items < 3) ? 'between' : 'among';
            $self->stack_test( qw(fail "Cannot add substitution for $var: dependency loop $between $message";\n));
          }
        }
      }
      next;
    };

    # Commit any substitutions.
    # We use 'next' because the substituted lines
    # will have been queued on the input if there
    # where any substitutions.
    #
    # We do this *after* pragma processing because
    # if we have this:
    #  %%foo bar baz
    #  %%quux  is the value
    #
    # and we expanded pragmas in place, we'd get
    #  %%foo bar baz
    #  %%quux bar
    #  %%quux baz
    #
    # which is probably *not* what is wanted.
    # Putting this here makes sure that we only
    # substitute into actual test specs.
    next if $self->_queue_substituted_lines($_);

    # No substitutions in this line, so just process it.
    my $item = App::SimpleScan::TestSpec->new($_);

    # Store it in case a plugin needs to look at the
    # test spec in an overriding method.
    $self->set_current_spec($item);

    if ($item->syntax_error) {
      $self->stack_code(<<"END_MSG");
# @{[$item->raw]}
# Possible syntax error in this test spec
END_MSG
    }
    else {
      $item->as_tests;
      local $_ = $item ->raw;                           ##no critic
      s/\n//mx;
    }
    # Drop the spec (there isn't one active now).
    $self->set_current_spec();
  }
  return;
}

# Calls each plugin's test_modules method
# to stack any other test modules needed to
# properly handle the test code. (Plugins may
# want to generate test code that needs
# something like Test::Differences, etc. -
# 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.
sub _queue_substituted_lines {
  my ($self, $line) = @_;
  my @results = $self->sub_engine->expand($line);

  if (@results != 1) {
    # substitutions definitely happened
    $self->queue_lines(@results);
    return 1;
  }
  elsif ($results[0] ne $line) {
    # single line is different, so substitution(s) happened
    $self->queue_lines(@results);
    return 1;
  }
  else {
    # nothing happened, just process it as is
    return 0;
  }
}

# Wrapper function for setter/getter that implements the
# override function (command-line substitutions override
# substitutions in the input).
sub _substitution_data {
  my ($self, $pragma_name, @pragma_values) = @_;
  if (! defined $pragma_name) {
    croak 'No pragma specified';
  }

  if (@pragma_values) {
    if (${$self->override} and
        $self->{Predefs}->{$pragma_name}) {
      if (${$self->debug}) {
        $self->stack_code(qq(diag "Substitution $pragma_name not altered to '@pragma_values'";\n));
      }
    }
    else {
      $self->sub_engine->substitution_value($pragma_name, @pragma_values);
    }
  }
  else {
    $self->sub_engine->substitution_value($pragma_name);
  }
  return
    wantarray ? @{$self->sub_engine->dictionary->{$pragma_name}}
              : $self->sub_engine->dictionary->{$pragma_name};
}

sub _delete_substitution {
  my ($self, $substitution) = @_;
  return $self->sub_engine->delete_substitution($substitution);
}

########################
# Options methods

sub handle_options {
  my ($self) = @_;

  # Handle options, including ones from the plugins.
  $self->install_options(%basic_options);

  # The --define option has to be handled slightly differently.
  # We set things up so that we have a hash of predefined variables
  # in the object; that way, we can set them up appropriately, and
  # know whether or not they should be checked for override/defer
  # when a definition is found in the simple_scan input file.
  $self->{Options}->{'define=s%'} = ($self->{Predefs} = {});

  foreach my $plugin (__PACKAGE__->plugins) {
    if ($plugin->can('options')) {
      $self->install_options($plugin->options);
    }
  }

  $self->parse_command_line;

  foreach my $plugin (__PACKAGE__->plugins) {
    if ($plugin->can('validate_options')) {
      $plugin->validate_options($self);
    }
  }

  # If anything was predefined, save it in the substitutions.
  for my $def (keys %{$self->{Predefs}}) {
    $self->sub_engine->substitution_value($def,
                            (split /\s+/mx, $self->{Predefs}->{$def}));
  }

  if (${$self->no_agent}) {
    $self->sub_engine->substitution_value('agent', 'WWW::Mechanize::Pluggable');
  }
  else {
    $self->sub_engine->substitution_value('agent', 'Windows IE 6');
    $self->stack_code("mech->agent_alias('Windows IE 6');\n");
  }

  $self->app_defaults;
  return;
}

# Set up application defaults.
sub app_defaults {
  my ($self) = @_;
  # Assume --run if neither --run nor --generate.
  if (!defined ${$self->generate()} and
      !defined ${$self->run()}) {
    $self->run(\1);
  }

  # Assume --defer if neither --defer nor --override.
  if (!defined ${$self->defer()} and
      !defined ${$self->override()}) {
    $self->defer(\1);
  }

  # if --cache was supplied, turn caching on.
  if (${$self->autocache}) {
    $self->stack_code(qq(cache;\n));
  }

  return;
}

# Transform the options specs (whether from here or
# from plugins) into methods that we can call to
# set/get the option values.
sub install_options {
  my ($self, @options) = @_;
  if (! defined $self->{Options}) {
    $self->{Options} = {};
  }

  # precompilation versions of the possible methods. These
  # get compiled right when we need them, causing $option
  # to be capturd as a closure.

  while (@options) {
    # This coding is deliberate.
    #
    # We want a separate copy of $option and
    # $receiver each time; we don't want a new
    # copy of @options, because we want to keep
    # effectively shifting two values off each
    # time around the loop.
    #
    # Note that the generated method returns a
    # reference to the variable that the option is
    # stored into; this makes it simpler to code
    # the accessor here. If you use an array or
    # hash to receive values in your Getopt spec,
    # you'll have to dereference it properly in
    # your code.
    (my($option, $receiver), @options) = @options;

    # Method names containing dashes are a no-no;
    # swap them to underscores. (This is okay because
    # no one outside this module should be trying to
    # call these methods directly.)
    $option =~ s/-/_/mxg;

    $self->{Options}->{$option} = $receiver;

    # Ensure that the variables have been cleared if we create another
    # App::SimpleScan object (normally we won't, but our tests do).
    ${ $receiver } = undef;

    # Create method if it doesn't exist.
    if (! $self->can($option)) {
      use Sub::Installer;
      __PACKAGE__->install_sub(
        { $option => sub {
                           my ($self, $value) = @_;
                           if (defined $value) {
                             $self->{Options}->{$option} = $value;
                           }
                           return $self->{Options}->{$option};
                         }
        }
      );
    }
  }
  return;
}

# Load all the plugins.
sub _load_plugins {
  my($self) = @_;

  # Load plugins.
  foreach my $plugin (__PACKAGE__->plugins) {
    eval "use $plugin";                                      ##no critic
    $EVAL_ERROR and die "Plugin $plugin failed to load: $EVAL_ERROR\n";
  }

  # Install source filters
  $self->{Filters} = [];
  foreach my $plugin (__PACKAGE__->plugins) {
    if ($plugin->can('filters')) {
      push @{$self->{Filters}}, $plugin->filters();
    }
    # Initialize plugin data if possible.
    if ($plugin->can('init')) {
      $plugin->init($self);
    }
  }

  return;
}

# Call Getopt::Long to parse the command line.
sub parse_command_line {
  my ($self) = @_;
  return GetOptions(%{$self->{Options}});
}

# Install any pragmas supplied by plugins.
# We reuse this same code to install all of
# the locally defined pragmas.
sub install_pragma_plugins {
  my ($self) = @_;

  foreach my $plugin (@local_pragma_support,
                      __PACKAGE__->plugins) {
    if (ref $plugin eq 'ARRAY') {
      $self->pragma(@{ $plugin });
    }
    elsif ($plugin->can('pragmas')) {
      foreach my $pragma_spec ($plugin->pragmas) {
        $self->pragma(@{ $pragma_spec });
      }
    }
  }
  return;
}

########################
# Pragma methods and handlers

# Find the pragma code associated with the name.
sub pragma {
  my ($self, $name, $pragma) = @_;
  die "You forgot the pragma name\n" if ! defined $name;
  if (defined $pragma) {
    $self->{Pragma}->{$name} = $pragma;
  }
  return $self->{Pragma}->{$name};
}

# %%agent pragma handler. Verify that the argument
# is a valid WW::Mechanize agent alias string, and
# stack code to change it as appropriate.
sub _do_agent {
  my ($self, $rest) = @_;
  $rest = reverse $rest;
  my ($maybe_agent) = ($rest =~/^\s*(.*)$/mx);

  $maybe_agent = reverse $maybe_agent;
  if (grep { $_ eq $maybe_agent } $reference_mech->known_agent_aliases) {
    $self->_substitution_data('agent', $maybe_agent)
  }
  $self->stack_code(qq(user_agent("$maybe_agent");\n));
  return;
}

# %%cache - turn on Test::WWW::Simple's cache.
sub _do_cache {
  my ($self,$rest) = @_;
  $self->stack_code("cache();\n");
  return;
}

# %%nocache - turn off Test::WWW::Simple's cache.
sub _do_nocache {
  my ($self,$rest) = @_;
  $self->stack_code("no_cache();\n");
  return;
}

##########################
# Input queueing

# Handle input queueing. If there's anything queued,
# return it first; otherwise, just read another line
# from the magic input filehandle.
sub next_line {
  my ($self) = shift;
  my $next_line;

  # Call and plugin-installed input callbacks.
  # These can do whatever they like to the line stack, the
  # object, etc.
  foreach my $callback (@ {$self->next_line_callbacks() }) {
    $callback->($self);
  }

  # If we have lines on the input queue, read from there.
  if (defined $self->{InputQueue}->[0] ) {
    $next_line = shift @{ $self->{InputQueue} };
  }

  # Else we read lines from the standard input.
  else {
    $next_line = <>;
    if (defined $next_line) {
      $next_line =~ s/\n//mx;
      if ($run_status) {
        print STDERR "# |Processing '$next_line' (line $.)\n";
      }
    }
  }

  # record the text of the last line read for plugins to access
  # if they need it.
  $self->last_line($next_line);

  return $next_line;
}

# Preserve current line so that plugins can look at it
# if they want to.
sub last_line {
  my ($self, $line) = @_;
  if (defined $line) {
    $self->{CurrentLine} = $line;
  }
  return $self->{CurrentLine};
}

# Handle input stacking by pragmas. Add any new lines
# to the head of the queue.
sub queue_lines {
  my ($self, @lines) = @_;
  $self->{InputQueue} = [ @lines, @{ $self->{InputQueue} } ];
  return;
}

###########################
# Output queueing

# stack_code just adds code to the array holding
# the generated program.
sub stack_code {
  my ($self, @code) = @_;
  my @old_code = @{$self->tests};
  $self->tests([@old_code, @code]);
  return
}

# stack_test adds code to the array holding
# the generated program, and bumps the test
# count so we can use the proper number of tests
# in our test plan.
sub stack_test {
  my($self, @code) = @_;
  for my $filter (@{$self->{Filters}}) {
    # Called with $self to make it appear
    # as if it's a method call from this package.
    @code = $filter->($self, @code);
  }
  $self->stack_code(@code);
  return $self->test_count($self->test_count()+1);
}

##################################
# Dependency checking

# It's necessary to make sure that the substitution pragmas
# don't have looping dependencies; these would cause the
# input stack to grow without limit as it tries to resolve
# all of the substitutions.
#
# All we have to do is make sure that the graph of variable
# relations is a directed acyclic graph. Since actually writing
# all that would be a pain, we use Graph.pm to manage it for us.

sub _check_dependencies {
  my ($self, $var, @dependencies) = @_;
  my $graph = $self->_deps;

  # drop anything that's not a variable definition.
  @dependencies = grep { /^<.*>$/mx } @dependencies;

  # No variables, no dependencies.
  if (! @dependencies) {
    return 1, 'no dependencies';
  }

  # Add the new dependencies.
  $self->_depend($var, @dependencies);

  # Run a topological sort to make sure that the
  # graph remains a DAG. If not, returns a cycle.
  # Note that it's possible that there's more than one
  # cycle, though not liekely, since we're checking
  # every time we add a new variable.
  unless ($graph->is_dag) {
    return (0, $graph->find_a_cycle);
  }

  return 1, "dependencies OK";
}

sub _depend {
  my($self, $item, @dependencies) = @_;

  if (!defined $item) {
    die "You don't want to do that anymore";
  }

  if (!@dependencies) {
    return ([ $self->_deps->successors($item) ]);
  }

  # Add these dependencies for the item.
  $self->_deps->add_edge($item, $_) for @dependencies;    ## no critic
  return;
}

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