File Coverage

blib/lib/Test/Warnings.pm

Criterion	Covered	Total	%
statement	59	59	100.0
branch	18	20	90.0
condition	22	26	84.6
subroutine	16	16	100.0
pod	5	5	100.0
total	120	126	95.2

use strict;
use warnings;
package Test::Warnings; # git description: v0.031-5-g17d6729
# vim: set ts=8 sts=2 sw=2 tw=100 et :
# ABSTRACT: Test for warnings and the lack of them
# KEYWORDS: testing tests warnings

our $VERSION = '0.032';

use parent 'Exporter';
use Test::Builder;

our @EXPORT_OK = qw(
    allow_warnings allowing_warnings
    had_no_warnings
    warnings warning
);
our %EXPORT_TAGS = ( all => \@EXPORT_OK );

my $warnings_allowed;
my $forbidden_warnings_found;
my $done_testing_called;
my $no_end_test;
my $fail_on_warning;
my $report_warnings;
my @collected_warnings;

sub import {
    my $class = shift @_;

    my %names; @names{@_} = ();
    # END block will check for this status
    $no_end_test = exists $names{':no_end_test'};
    # __WARN__ handler will check for this status
    $fail_on_warning = exists $names{':fail_on_warning'};
    # Collect and report warnings at the end
    $report_warnings = exists $names{':report_warnings'};

    delete @names{qw(:no_end_test :fail_on_warning :report_warnings)};
    __PACKAGE__->export_to_level(1, $class, keys %names);
}

# for testing this module only!
my $tb;
sub _builder(;$) {
    if (not @_) {
        $tb ||= Test::Builder->new;
        return $tb;
    }

    $tb = shift;
}

my $_orig_warn_handler = $SIG{__WARN__};
$SIG{__WARN__} = sub {
    if ($warnings_allowed) {
        Test::Builder->new->note($_[0]);
    }
    else {
        $forbidden_warnings_found++;
        push @collected_warnings, $_[0] if $report_warnings;

        # TODO: this doesn't handle blessed coderefs... does anyone care?
        goto &$_orig_warn_handler if $_orig_warn_handler
            and (  (ref $_orig_warn_handler eq 'CODE')
                or ($_orig_warn_handler ne 'DEFAULT'
                    and $_orig_warn_handler ne 'IGNORE'
                    and defined &$_orig_warn_handler));

        if ($_[0] =~ /\n$/) {
            warn $_[0];
        } else {
            require Carp;
            Carp::carp($_[0]);
        }
        _builder->ok(0, 'unexpected warning') if $fail_on_warning;
    }
};

sub warnings(;&) {
    # if someone manually does warnings->import in the same namespace this is
    # imported into, this sub will be called.  in that case, just return the
    # string "warnings" so it calls the correct method.
    if (!@_) {
        return 'warnings';
    }
    my $code = shift;
    my @warnings;
    local $SIG{__WARN__} = sub {
        push @warnings, shift;
    };
    $code->();
    @warnings;
}

sub warning(&) {
    my @warnings = &warnings(@_);
    return @warnings == 1 ? $warnings[0] : \@warnings;
}

if (Test::Builder->can('done_testing')) {
    # monkeypatch Test::Builder::done_testing:
    # check for any forbidden warnings, and record that we have done so
    # so we do not check again via END

    no strict 'refs';
    my $orig = *{'Test::Builder::done_testing'}{CODE};
    no warnings 'redefine';
    *{'Test::Builder::done_testing'} = sub {
        # only do this at the end of all tests, not at the end of a subtest
        my $builder = _builder;
        my $in_subtest_sub = $builder->can('in_subtest');
        if (not $no_end_test
            and not ($in_subtest_sub ? $builder->$in_subtest_sub : $builder->parent)) {
            local $Test::Builder::Level = $Test::Builder::Level + 3;
            had_no_warnings('no (unexpected) warnings (via done_testing)');
            $done_testing_called = 1;
        }

        $orig->(@_);
    };
}

END {
    if (not $no_end_test
        and not $done_testing_called
        # skip this if there is no plan and no tests have been run (e.g.
        # compilation tests of this module!)
        and (_builder->expected_tests or _builder->current_test > 0)
    ) {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        had_no_warnings('no (unexpected) warnings (via END block)');
    }
}

# setter
sub allow_warnings(;$) {
    $warnings_allowed = @_ || defined $_[0] ? $_[0] : 1;
}

# getter
sub allowing_warnings() { $warnings_allowed }

# call at any time to assert no (unexpected) warnings so far
sub had_no_warnings(;$) {
    if ($ENV{PERL_TEST_WARNINGS_ONLY_REPORT_WARNINGS}) {
        $forbidden_warnings_found
            and _builder->diag("Found $forbidden_warnings_found warnings but allowing them because PERL_TEST_WARNINGS_ONLY_REPORT_WARNINGS is set");
    }
    else {
        _builder->ok(!$forbidden_warnings_found, shift || 'no (unexpected) warnings');
    }
    if (($report_warnings or $ENV{PERL_TEST_WARNINGS_ONLY_REPORT_WARNINGS})
          and $forbidden_warnings_found) {
        _builder->diag("Got the following unexpected warnings:");
        for my $i (1 .. @collected_warnings) {
            _builder->diag("  $i: $collected_warnings[ $i - 1 ]");
        }
    }
}

1;

__END__