App::SimpleScan::Plugin::LinkCheck - Link counting/presence/absence plugin

    # After this plugin is installed:
    %%has_link 'My stuff'
    %%no_link  'Send email'

    # The has_link and no_link checks will run for every test spec.
    http://someplace.com /foo/ Y Got my page
    http://someplace.com/subpage /foo/ Y Got my subpage

    # Stop checking for the 'My stuff' link
    %%forget_link 'My stuff'

    # Now only the "no 'Send email' link' test will run.
    http://someplace.com/map  /foo/ Y Get map page

    # More specific tests can be done:
    # The page will have exactly one 'home' link
    %%has_link 'Home' == 1

    # The page will have a non-zero number of 'offsite' links.
    %%has_link 'offsite' > 0

    http://someplace.com/links /foo/ Y Get links page
    # Now both these tests and the 'send email' test will run.

  

  %%no_link 'Click here' 

  %%which bar baz quux
  http://<which>.foo.com  /foo.com/ Y   Fetch page

  %%has_link 'back'

  %%forget_link 'back'

  %%forget_all_links

  %%has_link 'beta' >= 0
  %%has_link 'up' == 2
  %%has_link 'report_problems' != 1

package App::SimpleScan::Plugin::LinkCheck;

$VERSION = '1.03';

use warnings;
use strict;
use Carp;

use Scalar::Util qw(looks_like_number);
use Text::Balanced qw(extract_quotelike extract_multiple);

sub import {
  no strict 'refs';
  *{caller() . '::_do_has_link'}   = \&_do_has_link;
  *{caller() . '::_do_no_link'}    = \&_do_no_link;
  *{caller() . '::link_condition'} = \&link_condition;
  *{caller() . '::_link_conditions'} = \&_link_conditions;
  *{caller() . '::_add_link_condition'} = \&_add_link_condition;

  *{caller() . '::_extract_quotelike_args'} = 
    \&_extract_quotelike_args;
}

sub pragmas {
  return ['has_link', \&_do_has_link],
         ['no_link',  \&_do_no_link],
         ['forget_link', \&_do_forget_link],
         ['forget_all_links', \&_do_forget_all];
}

sub init {
  my($class, $app) = @_;
  $app->{Link_conditions} = {};
}

sub _do_forget_all {
  my($self, $args) = @_;
  $self->{Link_conditions} = {};
}

sub _do_forget_link {
  my($self, $args) = @_;
  my @links = $self->_extract_quotelike_args($args);
  for my $link (@links) {
    delete $self->{Link_conditions}->{$link};
  }
}

sub _do_has_link {
  my($self, $args) = @_;
  my($name, $compare, $count);
  if (!defined $args) {
    $self->stack_code( qq(fail "No arguments for %%has_link";\n) );
    $self->test_count( $self->test_count() + 1 );
    return;
  }
  else {
    # Extract strings and backticked strings and just plain words.
    # We explicitly junk anything past the first three items.
    ($name, $compare, $count) = $self->_extract_quotelike_args($args);
  }
  $self->_add_link_condition( { name=>$name, compare=>$compare, count=>$count } );
}

sub _do_no_link {
  my($self, $args) = @_;
  if (!defined $args) {
    $self->stack_code( qq(fail "No arguments for %%no_link";\n) );
    $self->test_count( $self->test_count() + 1 );
  }
  else {
    my ($name) = $self->_extract_quotelike_args($args);
    $self->_do_has_link(qq($name == 0));
  }
}

sub _link_conditions {
  my ($self) = shift;
  return wantarray ? @{ $self->{Link_conditions} } : $self->{Link_conditions};
}

sub _add_link_condition {
  my ($self, $condition) = @_;
  push @{ $self->{Link_conditions}->{ $condition->{name} } }, $condition;
}

sub filters {
  return \&filter;
}

sub filter {
  my($self, @code) = @_;
  # If we've recursed because of the stack_code in this method, just exit.

  return unless defined $self->_link_conditions;
  my $test_count = 0;

  for my $link_name (keys %{$self->_link_conditions()} ) {
    for my $link_condition ( @{ $self->{Link_conditions}->{$link_name} } ) {
      my $compare = $link_condition->{compare};
      my $count   = $link_condition->{count};
      my $name    = $link_condition->{name};
  
      my $not_bogus = 1;
      my %have_a;

      # name alone is "at least one link with this name"
      if (defined $name and (! defined $compare) and (! defined $count) ) {
        $compare = ">";
        $count   = "0";
      }

      # Name is always defined, or we'd never have gotten here.
      $name = _dequote($name);

      # comparison is always defined: either we fixed it just above (because
      # it was missing altogether), or it's there (but possibly bad).
      if (! grep {$compare eq $_} qw(== > < >= <= !=) ) {
        push @code, qq(fail "$compare is not a legal comparison operator (use < > <= >= == !=)";\n);
        $test_count++;
        $not_bogus = 0;
      }

      if (!defined($count)) {
        push @code, qq(fail "Missing count";\n);
        $test_count++;
        $not_bogus = 0;
      }
      elsif (! looks_like_number($count) ) {
        push @code, qq(fail "$count doesn't look like a legal number to me";\n);
        $test_count++;
        $not_bogus = 0;
      }

      if ($not_bogus) {
        my $last_testspec  = $self->get_current_spec;
        $last_testspec->comment( qq('$name' link count $compare $count) );

        push @code, qq(cmp_ok scalar \@{[mech()->find_all_links(text=>qq($name))]}, qq($compare), qq($count), "'$name' link count $compare $count";\n);
        $test_count++;
        @code = _snapshot_hack($self, @code);
      }
    }
  }
  $self->test_count($self->test_count() + $test_count);
  return @code;
}

sub _snapshot_hack {
  # Snapshot MUST be called for every test stacked.
  my ($self, @code) = @_;
  if ($self->can('snapshot')) {
    return &App::SimpleScan::Plugin::Snapshot::filter($self, @code);
  }
  else {
    return @code;
  }
}

sub _extract_quotelike_args {
  # Extract strings and backticked strings and just plain words.
  my ($self, $string) = @_;

  # extract_quotelike complains if no quotelike strings were found.
  # Shut this up.
  no warnings;

  # The result of the extract multiple is to give us the whitespace
  # between words and strings with leading whitespace before the
  # first word of quotelike strings. Confused? This is what happens:
  #
  # for the string
  #   a test `backquoted' "just quoted"
  # we get
  #   'a'
  #   ' '
  #  'test'
  #  ' `backquoted'
  #  `backquoted`
  #  ' '
  #  ' "just'
  #  '"just quoted"'
  #
  # We do NOT use grep because if one of the arguments evaluates to 
  # zero, it won't get saved.
  my @wanted;
  foreach my $item 
    (extract_multiple($string, [qr/[^'"`\s]+/,\&extract_quotelike])) {
    push @wanted, _dequote($item) if $item !~ /^\s/;
  }
  return @wanted;
}

sub _dequote {
  my $string = shift;
  $string = eval $string if $string =~ /^(['"]).*(\1)$/;
  return $string;
}


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