view release on metacpan or  search on metacpan

lib/Test/Group/Tester.pm  view on Meta::CPAN

                        " 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<want_test($type, $name, @diag)>

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<qr//>.

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<fail_diag($test_name [,$from_test_builder] [,$line] [,$file])>

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<Test::Builder> will produce
the diagnostic, false if the diagnostic will come from L<Test::Group>.
The expected text will be adjusted according to the version of
L<Test::Builder> or L<Test::Group> 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 <ncleaton@cpan.org>

Dominique Quatravaux <domq@cpan.org>

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