view release on metacpan or  search on metacpan

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

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+$/);

=item I<Line counting for the debugger>

You can step through the test using a GUI debugger (e.g. perldb in
Emacs) because the line numbers are appropriately translated.

=cut

        $self->{testsuite}="#line ".($.+1)." \"$self->{packfilename}\"\n".
            $self->{testsuite};
        last SOURCELINE;
    }

=item I<Tests always start in package main>

The perlmodlib idiomatics puts you either in C<main> or in the package
where the eval was called from, depending on the version of Perl.

=cut

    $self->{testsuite}="package main;\n" . $self->{testsuite};