Alien-Selenium

 view release on metacpan or  search on metacpan

inc/My/Tests/Below.pm  view on Meta::CPAN

=head3 Why not use Test::Inline then?

Well, for a variety of reasons:

=over

=item *

modules written with tests at the end syntax-highlight almost
perfectly under Emacs :-), which is far from being the case for tests
written in the POD

=item *

removing the My::Tests::Below altogether from the installed version
of a package is straightforward and does not alter line
numbering. (See L<My::Module::Build>)

=item *

no pre-processing step (e.g. C<inline2test>) and no temporary file
creation is required with My::Tests::Below. This goes a long ways
towards shortening the debugging cycle (no need to re-run "./Build
code" nor "make" each time)

=item *

L<Test::Inline> has a lot of dependencies, and using it would cause
the installation of small modules to become unduly burdensome.

=back

=cut "

package My::Tests::Below;

use strict;
use File::Temp ();

our $VERSION = 2.0;

## This is done at the top level, not in a sub, as "require
## My::Tests::Below" is what gets the ball rolling:
our $singleton = __PACKAGE__->_parse(\*main::DATA, caller(0));
unless (defined $singleton) {
    die "My::Tests::Below invoked, but no tests were found below!";
}
close(main::DATA);
$singleton->run();

## Creates an instance of My::Tests::Below from a source file
## that has tests at the bottom.
sub _parse {
    my ($class, $fd, $package, $packfilename, $packline) = @_;

    if (!defined $package) { # Handle self-testing case
        $package="My::Tests::Below";
        $0 =~ m/^(.*)$/; $packfilename = $1;
    }

    my $self = bless {
                      package => $package,
                      packfilename => $packfilename
                     }, $class;

    $self->{testsuite} = do { no warnings; scalar <$fd> };
    return undef if ! defined $self->{testsuite};
    $self->{testsuite} .= join('',<$fd>); # The rest of it

=head2 Comfort features

Unlike the C<< eval >> form recommended in L<perlmodlib>,
My::Tests::Below provides a couple of comfort features that help
making the system smooth to use for tests.

=over

=item I<Support for code and data snippets in the POD>

A mechanism similar to the now-deprecated L<Pod::Tests> is proposed to
test documented examples such as code fragments in the SYNOPSIS. See
L</CLASS METHODS> below.

=cut

    ## Parse the whole source file again in order to provide said
    ## features.  Yes, seeking to start also works on main::DATA!
    ## Gotta love Perl :-)
    seek($fd, 0, 0) or die $!; $. = 0;
    my $insnippet;
    SOURCELINE: while(<$fd>) {
        if (m/^=for\s+My::Tests::Below\s+"([^"]*)"(.*)$/) {
            my $snipkey = $1; my @args = split m/\s+/, $2;
            if (grep { lc($_) eq "end" } @args) {
                die qq'Not in an "=for My::Tests::Below" directive'.
                    qq' at line $.\n' unless (defined $insnippet);
                die qq'Badly nested "=for My::Tests::Below" directives'.
                    qq' at line $.\n' unless ($insnippet eq $snipkey);
                undef $insnippet;
            } else { # Assume "begin" for compatibility with old tests
                die qq'Duplicate "=for My::Tests::Below" directive'.
                    qq' for label $snipkey at line $.\n' if
                        (exists $self->{podsnippets}{$snipkey});
                die qq'Badly nested "=for My::Tests::Below" directives'.
                    qq' at line $.\n' if (defined $insnippet);
                $self->{podsnippets}{$snipkey}->{lineno} = $. + 1;
                $insnippet = $snipkey;
            }
        } elsif (m/^=for\s+My::Tests::Below/) {
            die qq'Parse error in "=for My::Tests::Below"'.
                qq' directive at line $.\n';
        } else {
            $self->{podsnippets}{$insnippet}->{text} .= $_ if (defined $insnippet);
        };

        next if (defined($packline) && $. <= $packline); # Be sure to
        # catch the first marker *after* the require directive, and
        # mind the self-test case too.

        next SOURCELINE unless (m/^__(END|DATA)__\s+$/);

inc/My/Tests/Below.pm  view on Meta::CPAN

=head1 CLASS METHODS

=over

=item I<tempdir()>

This class method returns the path of a temporary test directory
created using L<File::Temp/tempdir>. This directory is set to be
destroyed when the test finishes, except if the DEBUG environment
variable is set. This class method is idempotent: calling it several
times in a row always returns the same directory.

=cut

{
    my $cached;
    sub tempdir {
        return $cached if defined $cached;
        return ($cached = File::Temp::tempdir
                ("perl-My-Tests-Below-XXXXXX",
                 TMPDIR => 1, ($ENV{DEBUG} ? () : (CLEANUP => 1))));
    }
}

=item I<pod_data_snippet($snippetname)>

This class method allows the test code to grab an appropriately marked
section of the POD in the class being tested, for various
test-oriented purposes (such as eval'ing it, storing it in a
configuration file, etc.).  The return value has the same number of
lines as the original text in the source file, but it is ragged to the
left by suppressing a constant number of space characters at the
beginning of each line.

For example, consider the following module:

=for My::Tests::Below "reflection is a fun thing" begin

  #!/usr/bin/perl -w

  package Zoinx;
  use strict;

  =head1 NAME

  Zoinx!

  =head1 SYNOPSIS

  =for My::Tests::Below "create-zoinx" begin

  my $zoinx = new Zoinx;

  =for My::Tests::Below "create-zoinx" end

  =cut

  package Zoinx;

  sub new {
      bless {}, "Zoinx";
  }

  require My::Tests::Below unless caller;

=for My::Tests::Below "reflection is a fun thing" end

=for great "justice"

  __END__

then C<< My::Tests::Below->pod_data_snippet("create-zoinx") >> would
return "\nmy $zoinx = new Zoinx;\n\n".

The syntax of the C<=for My::Tests::Below> POD markup lines obeys the
following rules:

=over

=item *

the first token after C<My::Tests::Below> is a double-quoted string
that contains the unique label of the POD snippet (passed as the first
argument to I<pod_data_snippet()>);

=item *

the second token is either C<begin> and C<end>, which denote the start
and end of the snippet as shown above. Nesting is forbidden (for now).

=back

=cut

sub pod_data_snippet {
	my ($self, $name)=@_; $self = $singleton if ! ref $self;

	local $_ = $self->{podsnippets}{$name}->{text};
	return unless defined;

    my $ragamount;
    foreach my $line (split m/\n/s) {
        next if $line =~ m/^\t/; # tab width is treated as infinite to
        # cut through the whole mess
        next if $line eq ""; # Often authors leave empty lines to
        # delimit paragraphs in SYNOPSIS, count them as undefined
        # length as well

        $line =~ m/^( *)/; my $spaceamount = length($1);
        $ragamount = $spaceamount if ((!defined $ragamount) ||
                                       ($ragamount > $spaceamount));
    }

    s/^[ ]{$ragamount}//gm;
	m/^(.*)$/s; return $1; # Untainted
}

=item I<pod_code_snippet($snippetname)>

Works like L</pod_data_snippet>, except that an adequate #line is
prepended for the benefit of the debugger. You can thus single-step

inc/My/Tests/Below.pm  view on Meta::CPAN

sub zoinx {1}

package Fake::Module::Sub;

require My::Tests::Below unless (caller());

1;

__END__

use Fake::Module;

print "1..2\n";
if (__PACKAGE__ eq "main") {
   print "ok 1 # In package 'main' for tests\n";
} else {
   print "not ok 1 # Package should be main but is ".__PACKAGE__."\n";
}

zoinx();

print "ok 2 # Symbol zoinx is imported\n";

0; # Should not cause suite to fail, unlike perlmodlib
FAKEMODULE

my $result = run_perl($fakemodule);
is($?, 0, "Exited with return code 0\n");
like($result, qr/ok 1/, "Test result #1");
like($result, qr/ok 2/, "Test result #2");

write_file($fakemodule, <<'BUGGY_MODULE_WITH_TEST_MORE');
#!perl -Tw

package Fake::Module;
use strict;

1;

require My::Tests::Below unless (caller());

__END__

use Test::More no_plan => 1;

ok(1);
die;
BUGGY_MODULE_WITH_TEST_MORE

$result = run_perl($fakemodule);
is($?, 255 << 8, "Exited with return code 255\n");
like($result, qr/Looks like your test died just after/, "Test died");

######## POD snippets

my $snippet = My::Tests::Below->pod_data_snippet
        ("reflection is a fun thing");
like($snippet, qr/^package Zoinx/m, "pod_data_snippet");
unlike($snippet, qr/reflection/, "Pod delimiters should be cut out");
like($snippet, qr/^    bless/m, "smart ragging");

eval $snippet; die $@ if $@; pass("Created package Zoinx");

my $testsnippet =
    My::Tests::Below->pod_code_snippet("POD testing example");

no warnings "redefine"; local *My::Tests::Below::pod_code_snippet = sub {
    is($_[1], 'create-zoinx',
       "hijacked sub pod_code_snippet() called as expected");
    # Real men would invoke My::Tests::Below recursively here...
    return <<'LAZY_SHORTCUT';

my $zoinx = new Zoinx;

LAZY_SHORTCUT
};

eval $testsnippet; die $@ if $@; # $testsnippet contains an invocation of
# is(), so the test counter gets incremented by one here.

1;