view release on metacpan or  search on metacpan

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

    }

=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};

    return $self;
}

## Actually runs the test suite in an eval.
sub run {
    my ($self) = @_;

=item I<Tested package is available for "use">

As shown in L</SYNOPSIS>, one can invoke "use MyPackage;" at the top
of the test suite and this will not cause the package under test to be
reloaded from the filesystem. The import() semantics of MyPackage, if
any, will work as normal.

=cut

    local %INC = %INC;
    if (defined $self->{package} && defined $self->{packfilename}) {
        # Heuristics needed here. $self->{packfilename} is a filename,
        # say /path/to/lib/Foo/Bar.pm, and we want to set
        # $INC{"Foo/Bar.pm"} so we must weed out /path/to/lib
        # wisely. $self->{package} is "Foo::Bar" most of the time but
        # may also be "Foo::Bar::SubPackage", "Foo" (if Foo::Bar is a
        # mixin to Foo) or even "Un::Related". In the latter case
        # we're out of luck and we leave %INC unmolested.
        for(my $package = $self->{package};
            $package; $package =~ s/(::|^)[^:]*$//) {
            my $filename = $package;
            $filename =~ s|::|/|g;
#warn "Considering $filename against $self->{packfilename}";
            next unless ($self->{packfilename} =~
                         m{(\Q$filename\E(?:/.*|\.pm)$)});
#warn "Inhibiting load of $1";
            $INC{$1} = $self->{packfilename}; last;
        }
    };


=item I<%ENV is standardized>

When running under C<require My::Tests::Below>, %ENV is reset to a
sane value to avoid freaky side effects when eg the locales are weird
and this influences some shell tool fired up by the test suite.  The
original contents of %ENV is stashed away in %main::ENVorig in case it
is actually needed.

=cut

    local %main::ENVorig; %main::ENVorig = %ENV;
    $ENV{PATH} =~ m|^(.*)$|; # Untaints
    local %ENV = (
            "PATH"  => $1,
            "DEBUG" => $ENV{"DEBUG"} ? 1 : 0,
           );

    eval $self->{testsuite};

    die $@ if $@;
}

=back

=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

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

  =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
inside your POD documentation, yow! Using the above sample .pm file
(see L</pod_data_snippet>), you could do something like this in the
test trailer:

=for My::Tests::Below "POD testing example" begin

  my $snippet = My::Tests::Below->pod_code_snippet("create-zoinx");

  # Munging $snippet a bit before running it (e.g. with regexp
  # replaces) is par for the course.

  my $zoinx = eval $snippet;
  die $@ if $@; # If snippet fails, we want to know

  # Optionally proceed to test the outcome of the snippet:

  is(ref($zoinx), "Zoinx", '$zoinx is a Zoinx');

=for My::Tests::Below "POD testing example" end

=cut

sub pod_code_snippet {
    my ($self, $name) = @_; $self = $singleton if ! ref $self;
    return "#line " . $self->{podsnippets}{$name}->{lineno} .
        " \"$self->{packfilename}\"\n" .
            $self->pod_data_snippet($name);
}

=back

=head1 SEE ALSO

L<My::Module::Build> knows how to remove I<My::Tests::Below>
suites at "make" or "./Build code" time, so as not to burden the
compiled package with the test suite.

While I am (obviously) partial to putting tests at the bottom of the
package, I also occasionally make use of classic C<t/*.t> tests; in
particular I use the same C<t/maintainer/*.t> tests in all my CPAN
modules.

=head1 BUGS

The purpose of this package is mostly a duplicate of L<Test::Inline>
and/or L<Pod::Tests>, but I cannot join either of these efforts in the
current state of CPAN affairs (I<Pod::Tests> is not maintained, and as
stated L<above|/"Why not use Test::Inline then?"> I<Test::Inline> is
not adequate for many reasons). What I could do, however, is to
standardize on similar POD markup for snippets - but the corresponding
features are being reimplemented in I<Test::Inline> as of version
2.103 (see
F<http://search.cpan.org/~adamk/Test-Inline-2.103/lib/Test/Inline.pm#TO_DO>).
So I'll just wait and see.

=cut

1;

__END__

# Yes, even this module has a
######################## TEST SUITE ###################################

use strict;
use Test::More tests => 11;
use IO::File;
use IO::Handle;
use IPC::Open3;
use File::Spec;
use Fatal qw(mkdir chdir);

=begin internals

=head2 Tests over the __END__ test section for real modules

=head3 run_perl($filename)

Runs Perl on $filename, returning what we got on stdout / stderr.
$? is also set.

=cut

sub run_perl {
    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;