view release on metacpan or  search on metacpan

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

#!perl -Tw
# Copyright Dominique Quatravaux 2006 - Licensed under the same terms as Perl itself

use strict;
use warnings;
use 5.006; # "our" keyword

=head1 NAME

B<My::Tests::Below> - invoke a test suite at the end of a module.

=head1 SYNOPSIS

 package MyPackage;

 <the text of the package goes here>

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

 1;

 __END__

 use MyPackage;


 # And there you go with your test suite

=head1 DESCRIPTION

DOMQ is a guy who releases CPAN packages from time to time - you are
probably frobbing into one of them right now.

This package is a helper that supports my coding style for unit tests
so as to facilitate relasing my code to the world.

=head2 How it works

The test code is written in L<perlmodlib> style, that is, at the
bottom of the Perl module to test, after an __END__ marker. This way
of organizing test code is not unlike L<Test::Inline>, by Adam Kennedy
et al, in that it keeps code, documentation and tests in the same
place, encouraging developers to modify all three at once.

I like to use L<Test::Group> for the unit perlmodlib-style unit tests,
because counting and recounting my tests drives me nuts :-). However
C<My::Tests::Below> itself is testing-framework agnostic (its own
self-test suite, for instance, uses only plain old L<Test::More>).

Invoking C<require My::Tests::Below> from anywhere (the idiomatic form
is shown in L</SYNOPSIS>) results in the block of code after the
__END__ marker being run at once. Due to the way this construct abuses
the Perl module mechanism, My::Tests::Below cannot be require()d or
use()d for any other purpose, hence the funny name.

=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'.

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

    my ($filename) = @_;
    my ($stdin, $stdout) = map { new IO::Handle } (1..2);
    my ($perl) = ($^X =~ m/^(.*)$/); # Untainted
    my $pid = open3($stdin, $stdout, $stdout,
          $perl, (map { -I => $_ } @INC), '-Tw', $filename);
    $stdin->close();
    my $retval = join('', <$stdout>);
    $stdout->close();
    waitpid($pid, 0); # Sets $?
    return $retval;
}

=head2 read_file($file)

=head2 write_file($file, @lines)

Like in L<File::Slurp>.

=cut

sub read_file {
  my ($filename) = @_;
  defined(my $file = IO::File->new($filename, "<")) or die <<"MESSAGE";
Cannot open $filename for reading: $!.
MESSAGE
  return wantarray? <$file> : join("", <$file>);
}

sub write_file {
  my ($filename, @contents) = @_;
  defined(my $file = IO::File->new($filename, ">")) or die <<"MESSAGE";
Cannot open $filename for writing: $!.
MESSAGE
  ($file->print(join("", @contents)) and $file->close()) or die <<"MESSAGE";
Cannot write into $filename: $!.
MESSAGE
}

=end internals

=cut

my $fakemoduledir = My::Tests::Below->tempdir() . "/Fake-Module";
mkdir($fakemoduledir);

mkdir(File::Spec->catdir($fakemoduledir, "Fake"));
my $fakemodule = File::Spec->catfile($fakemoduledir, "Fake", "Module.pm");
write_file($fakemodule, <<'FAKEMODULE');
#!perl -Tw

package Fake::Module;
use strict;

use base 'Exporter';
our @EXPORT = qw(zoinx);

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;