File Coverage

blib/lib/Test/Group/Tester.pm

Criterion	Covered	Total	%
statement	76	131	58.0
branch	27	64	42.1
condition	4	17	23.5
subroutine	10	12	83.3
pod	3	3	100.0
total	120	227	52.8

package Test::Group::Tester;
use strict;
use warnings;

use Carp;
use Config;
use Test::Builder;
use Test::Cmd;

=head1 NAME

Test::Group::Tester - Test Test::Group extensions

=head1 VERSION

Test::Group::Tester version 0.01

=cut

use vars qw($VERSION);
$VERSION = '0.01';

=head1 SYNOPSIS

=for tests "synopsis" begin

  use Test::More tests => 1;
  use Test::Group::Tester;

  testscript_ok('#line '.(__LINE__+1)."\n".<<'EOSCRIPT', 3);

    use Test::More;
    use Test::Group;

    # Test a passing test group
    want_test('pass', "this_should_pass");
    test this_should_pass => sub {
        ok 1, "1 is true";
        ok 2, "2 is true";
    };

    # Test a failing test group
    want_test('fail', "this_should_fail",
        fail_diag("0 is true", 0, __LINE__+5),
        fail_diag("this_should_fail", 1, __LINE__+5),
    );
    test this_should_fail => sub {
        ok 1, "1 is true";
        ok 0, "0 is true";
    };

    # Test a skipped test group
    want_test('skip', "just because I can");
    skip_next_test("just because I can");
    test this_should_be_skipped => sub {
        ok 0;
    };

  EOSCRIPT

=for tests "synopsis" end

=head1 DESCRIPTION

Test the behavior of a L compatible test script, by
spawning an external process to run the script and capturing its STDOUT
and STDERR.  Includes support for matching the failed test diagnostic
messages produced by L and L.

Useful when writing tests for L extension modules, see
L.

This module is used within the test suite of L itself, so
several usage examples can be found by searching for C in
the files in L's F subdirectory.

=head1 FUNCTIONS EXPORTED BY DEFAULT

=cut

use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK);
@ISA       = qw(Exporter);
@EXPORT    = qw(testscript_ok);
@EXPORT_OK = qw(want_test fail_diag);

=over

=item I

A test predicate for checking that a test script acts as expected. Runs
the script capturing STDOUT and STDERR and fails if anything unexpected
happens.

The expected behavior of the script is defined by calling want_test()
from within the script, just before running each test.

I<$source> is the body of the test script, as a single multi-line string.

I<$plan> is the number of tests that the test script will run.

I<$name> is a name for this test.

Some code will be prepended to I<$source>, to make the want_test() and
fail_diag() functions available and to set the test plan to I<$plan>.

Tip: include a C<#line> directive in your script source as shown in the
SYNOPSIS above, so that the reported line numbers for problems will point
to the correct line in your source file.

=cut

sub testscript_ok {
    my ($source, $plan, $name) = @_;
    $plan =~ /^\d+$/ or croak "non-numeric plan [$plan]";
    $name ||= 'testscript_ok';

    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my $script_source = <
use Test::Builder;
Test::Builder->new->plan( tests => $plan );
use Test::Group::Tester qw(want_test fail_diag);

$source

print STDERR "\nXXtestscript_under_test_endXX\n";
EOSCRIPT

    my $perl = Test::Cmd->new
        (prog => join(' ', $Config{perlpath},
                      (map { ("-I", $_) } @INC), '-'),
         workdir => '');
    $perl or croak "$name Test::Cmd failed";

    my $status = $perl->run(stdin => $script_source);
    my $stdout = $perl->stdout();
    my $stderr = $perl->stderr();
    $stderr =~ s/\nXXtestscript_under_test_endXX\n.*//s;

    my $ok = 1;
    my $expect_failed_tests = 0;
    my @fail;

    my @errbits = split /XXwant_test_markerXX/, $stderr, -1;
    my $preamble = shift @errbits;
    if (length $preamble) {
        $ok = 0;
        push @fail, "STDERR output before first test:";
        push @fail, "  $preamble";
    }
    my $rantests = @errbits;
    unless ($rantests == $plan) {
        $ok = 0;
        push @fail, "planned $plan tests, script ran $rantests";
    }

    my $want_out = "1..$plan\n";
    foreach my $i (0 .. $#errbits) {
        my $e = $errbits[$i];
        unless ($e =~ s/^ want_test:([,\w]+)\n//) {
            $ok = 0;
            push @fail, "missing header in section [$e]";
            next;
        }
        my ($call_line, $type, $name, @diag) =
               map { $_ eq 'undef' ? undef : pack 'H*', $_} split /,/, $1, -1;

        my $out = ($type eq 'fail' ? 'not ' : '') . 'ok ' . ($i+1);
        if ($type eq 'skip') {
            $out .= " # skip";
            defined $name and $out .= " $name";
        } else {
            defined $name and $out .= " - $name";
        }
        $want_out .= "$out\n";

        ++$expect_failed_tests if $type eq 'fail';

        $e =~ s/\n$//;
        my @lines = split /\n/, $e, -1;
        my @mismatch;
        foreach my $i (0 .. $#lines) {
            last if @mismatch;
            my $line = $lines[$i];
            my $want = $diag[$i];
            if (!defined $want) {
                push @mismatch, "unmatched line '$line'";
            } elsif ($want =~ s{^/}{}) {
                unless ($line =~ /$want/) {
                    push @mismatch,
                        "line '$line'",
                        "doesn't match /$want/";
                }
            } elsif ($line ne $want) {
                push @mismatch,
                    "line '$line'",
                    "isnt '$want'";
            }
        }
        if (@lines < @diag) {
            push @mismatch, "too few lines";
        }
        if (@mismatch) {
            $ok = 0;
            my $msg = "STDERR MISMATCH";
            defined $name and $msg .= " FOR $name";
            $msg .= " (line $call_line)";
            push @fail, "$msg...",
                        " got stderr:",
                        map({"  [$_]"} @lines),
                        " want stderr:",
                        map({"  [$_]"} @diag),
                        " mismatch details:",
                        map({"  $_"} @mismatch),
                        ;

        }
    }

    if ($stdout ne $want_out) {
       $ok = 0;
       push @fail, "want stdout: $want_out",
                   "got stdout: $stdout";
    }

    if ($expect_failed_tests and not $status) {
        $ok = 0;
        push @fail, "test script failed to fail";
    } elsif ($status and not $expect_failed_tests) {
        $ok = 0;
        push @fail, "test script unexpectedly failed";
    }

    my $Test = Test::Builder->new;
    $Test->ok($ok, $name);
    foreach my $fail (@fail) {
        $Test->diag("* $fail");
    }
}

=back

=head1 TEST SCRIPT FUNCTIONS

The following functions are for use from within the script under test.
They are not exported by default.

=over

=item I

Declares that the next test will pass or fail or be skipped according to
I<$type>, will have name I<$name> and will produce the diagnostic output
lines listed in I<@diag>.

I<$type> must be one of the strings 'pass', 'fail', 'skip'. I<$name>
can be undef for a test without a name.  The elements of I<@diag> can
be strings for an exact match, or regular expressions prefixed with
C or compiled with C.

Note that diagnostic lines consist of a hash character followed by a
space and then the diagnostic message. The strings and patterns passed
to want_test() must include this prefix.

=cut

sub want_test {
    my ($type, $name, @diag) = @_;
    my $call_line = (caller)[2];

    $type =~ /^(pass|fail|skip)\z/i or croak
          "want_test type=[$type], need pass|fail|skip";
    $type = lc $1;

    # flatten diags to strings
    foreach my $diag (@diag) {
        ref $diag eq 'Regexp' and $diag = "/$diag";
        ref $diag and croak "unexpected reference diag [$diag] in want_test";
    }

    my @args = map {defined $_ ? unpack('H*', $_) : 'undef'}
                                              $call_line, $type, $name, @diag;
    print STDERR 'XXwant_test_markerXX want_test:', join(',', @args), "\n";
}

=item I

Call only in a list context, and pass the results to want_test() as
diagnostic line patterns.

Returns the diagnostic line pattern(s) to match output from a failed
test. I<$test_name> is the name of the test, or undef for a nameless
test.  I<$line> should be defined only if a file and line diagnostic
is expected, and should give the expected line number.  I<$file> is
the filename for the failed test diagnostic, it defaults to the
current file.

C<$from_test_builder> should be true if L will produce
the diagnostic, false if the diagnostic will come from L.
The expected text will be adjusted according to the version of
L or L in use.

=cut

sub fail_diag {
    wantarray or croak "fail_diag needs a list context";

    my ($test_name, $from_test_builder, $line, $file) = @_;
    $file ||= (caller)[1];

    my @diag;

    if ($from_test_builder and $ENV{HARNESS_ACTIVE}) {
        # Test::Builder adds a blank diag line for a failed test
        # if HARNESS_ACTIVE is set.
        push @diag, '';
    }

    if ($from_test_builder and $Test::Builder::VERSION <= 0.30) {
        my $diag = "#     Failed test";
        if (defined $line) {
            $diag .= " ($file at line $line)";
        }
        push @diag, $diag;
    }  else {
        if (defined $test_name) {
            push @diag, "#   Failed test '$test_name'";
        } else {
            push @diag, "#   Failed test";
        }
        if (defined $line) {
            my $qm = quotemeta $file;
            push @diag, "/^\\#\\s+(at $qm|in $qm at) line $line\\.?\\s*\$";
        }
    }

    return @diag;
}

=back

=head1 AUTHORS

Nick Cleaton

Dominique Quatravaux

=head1 LICENSE

Copyright (c) 2009 by Nick Cleaton and Dominique Quatravaux

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.1 or,
at your option, any later version of Perl 5 you may have available.

=cut

1;