File Coverage

examples/simple_scan

Criterion	Covered	Total	%
statement	76	92	82.6
branch	34	48	70.8
condition	7	12	58.3
subroutine	9	9	100.0
pod			n/a
total	126	161	78.2

#!/usr/bin/env perl
use warnings;
use strict;
use Getopt::Long;
use Regexp::Common;
use WWW::Mechanize;
use Test::WWW::Simple;

use constant SHEBANG => "#!$^X";
my($generate, $run, $warn);

GetOptions('generate' => \$generate,
           'run'      => \$run,
           'warn'     => \$warn);

# Assume run if no flags at all.
$run++ unless $run or $generate;

my @tests;
my @countries;
my $agent = "Windows IE 6";
my $number_of_tests;
my @lines = <>;
while(@lines) {
  $_ = shift @lines;
  chomp;
  # Discard comments.
  /^#/ and next;

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

  # First, look for any of our pragmas.
  # These all start with %% and a pragma name.

  # %%cache
  # This pragma tells simple_scan to cache all URLs.
  /^%%cache/ and do {
    push @tests, "cache();\n";
    next;
  };

  # %%nocache
  # This pragma tells simple_scan to not cache URLs.
  /^%%nocache/ and do {
    push @tests, "no_cache();\n";
    next;
  };

  # %xx: es de au ..
  # This pragma lets us define a list of country IDs
  # to be substituted into the URLs following it. We look for ">xx<"
  # in the URLs to find the characters we'll replace.
  /^%%xx:/ and do {
    if (/^%%xx: (([a-z1-9]{2,}(\s+|$))+)/) {
      my $countries = $1;
      @countries = split(/\s+/, $countries);
    }
    else {
      die "Invalid '%%xx:' pragma: must be '%%xx: ' followed by two (or more) character country IDs.\n";
    }
    next;
  };

  # %agent: agent_alias
  # This pragma tells us to switch the user agent to the one specified.
  # if it's not a valid user agent, we die.
  /%%agent: (.*)/ and do {
    $agent = $1;
    my @aliases = WWW::Mechanize::known_agent_aliases();
    unless (grep {/$agent/} @aliases) {
      die "$agent is an invalid user agent alias/";
    }
    push @tests, qq!Test::WWW::Simple::user_agent("$agent");\n!;
    next;
  };

  # if an xx: pragma is in effect, substitute the country for ">xx<"
  # everywhere in the input record (so we can include the country in the
  # comment!).
  if (@countries) {
    my @localized;
    for my $country (@countries) {
      my $localized;
      # don't create localized tests if the test is not localizable.
      unless (/>xx
        emit_a_test($_);
        last;
      }
      # Localize.
      ($localized = $_) =~ s/>xx
      push @localized, $localized;
    }
    emit_a_test(@localized);

    # Discard the unlocalized line.
    next;
  }

  # No localization in effect. Just make a test.
  else {
    emit_a_test($_);
  }

}

if (defined $number_of_tests) {
  unshift @tests,
    "@{[SHEBANG]}\nuse Test::WWW::Simple tests=>$number_of_tests;\n";
  print @tests if $generate;
  eval(join '',@tests) if $run;
  $@ and warn $@,"\n";
}
else {
  warn "# No tests were found in your input file.\n"
    if $warn;
}

sub emit_a_test {
  my (@input) = @_;
  # All these extra undefs are the result of using Regexp::Common to
  # capture the first two fields. Less confusing and error-prone than
  # actually coding the regexes oneself.
  local $_;
  for (@input) {
    s/>agent
    my($url,   undef, undef, undef, undef, undef, undef, undef,
       undef, undef, $regex, undef,
       undef, $switches,
       $which,
       @comment) =
      m[$RE{URI}{HTTP}{-keep}\s+              # a URL
        $RE{delimited}{-delim=>'/'}{-keep}    # a regex, in slashes
        (([sixogim]+)\s+|\s+)                 # possibly with switches
        ([yY]|[nN])\s+                              # should/shoudn't match
        (.*)$]x;                              # test comment

    # Clean things up a bit.

    # Make sure the "which" is uppercase for later tests.
    $which = uc($which) if defined $which;

    # Add url and which way the pattern should match to the comment.
    push @comment, "[$url]" if defined $url;

    # avoid a warning if the test spec had a syntax error.
    push @comment, "[/$regex/ " . ($which eq 'Y' ? "should" : "shouldn't") . " match]"
     if defined $regex and defined $which;

    # Avoid undef warnings if no regex switches were used.
    $switches = "" unless defined $switches;

    # Warn about possible errors.
    unless (defined $url and defined $regex and defined $which) {
      push @tests, "# $_\n","# Possible syntax error in this test spec\n";
      warn "$_: syntax error" if $warn;
      next;
    }

    push @tests, qq!page_@{[$which eq 'Y' ? "" : "un"]}! .
                 qq!like("$url", qr/$regex/$switches, "@{[join " ",@comment]}");\n!;
    $number_of_tests++;
  }
}
__END__