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__
=head1 NAME
App::SimpleScan::TestSpec - store a test spec, and transform it into test code
=head1 VERSION
This document describes App::SimpleScan::TestSpec version 0.01
=head1 SYNOPSIS
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();
=head1 DESCRIPTION
C<App::SimpleScan::TestSpec> centralizes the parsing to test specifications and
their transformation into code.
=head1 INTERFACE
=head2 app
Accessor for the owning App::SimpleScan object. Must be called
before C<as_tests> is used to permit access to any substitution
pragma data.
=head2 new($test_spec)
Creates a new C<TestSpec> object from a test specification line.
Actually just extracts the appropriate data and prepares for
later substitutions and assembly by C<as_tests>.
=head2 raw
Returns the raw test spec text was originally passed in.
=head2 parse
Breaks up the raw line into the proper fields and
sets the regex delimiter appropriately.
Since we're parsing a line which may or may not have
substitution tokens in it, we have to break it on appropriate
whitespace rather than by matching a "real" URI and a "real" regex.
=head2 uri
Accessor for the raw URI portion of the test spec.
=head2 delim
Accessor for the regex delimiter.
=head2 regex
Accessor for the regular expression itself.
=head2 kind
Accessor for the kind of test:
=over 4
=item * Y
Pattern should match.
=item * N
Pattern should I<not> match.
=item * TY
Pattern does not match currently, but should when code is working properly (TODO).
=item * TN
Pattern matches right now, but shouldn't when code is working properly (TODO).
=item * SY
This test should be skipped; later, it should match.
=item * SN
This test should be skipped; later, it should I<not> match.
=back
=head2 as_tests
Expands the test spec into one or more lines of Perl test code.
This method should only be called on test specs that have already been
through substitution in the main program.
=head1 EXTENDING APP::SIMPLESCAN
=head2 Adding new command-line options
Plugins can add new command-line options by defining an
C<options> class method which returns a set of parameters
appropriate for C<install_options>. C<App::SimpleScan> will
check for this method when you plugin is loaded, and call
it to install your options automatically.
=head1 DIAGNOSTICS
None as yet.
=head1 CONFIGURATION AND ENVIRONMENT
App::SimpleScan requires no configuration files or environment variables.
=head1 DEPENDENCIES
Module::Pluggable and WWW::Mechanize::Pluggable.
=head1 INCOMPATIBILITIES
None reported.
=head1 BUGS AND LIMITATIONS
Using capturing parentheses in a regex that will be matching non-ASCII characters
wil lead to confusion and heartbreak, as this will throw off the capturing of the
accent characters. If you need to do this, do the capturing separate from the
check of the accented characters.
Please report any bugs or feature requests to
C<bug-app-simplescan@rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org>.
=head1 AUTHOR
Joe McMahon C<< <mcmahon@yahoo-inc.com > >>
=head1 LICENCE AND COPYRIGHT
Copyright (c) 2005, Joe McMahon C<< <mcmahon@yahoo-inc.com > >>. All rights reserved.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.
=head1 DISCLAIMER OF WARRANTY
BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
NECESSARY SERVICING, REPAIR, OR CORRECTION.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
