File Coverage

blib/lib/Test/Warnings.pm

Criterion	Covered	Total	%
statement	93	94	98.9
branch	31	36	86.1
condition	31	38	81.5
subroutine	23	23	100.0
pod	7	8	87.5
total	185	199	92.9

use strict;
use warnings;
package Test::Warnings; # git description: v0.037-4-gdc90508
# 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.038';

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

our @EXPORT_OK = qw(
    allow_warnings allowing_warnings
    had_no_warnings
    warnings warning
    allow_patterns
    disallow_patterns
);
our @EXPORT = qw(done_testing);
our %EXPORT_TAGS = ( all => [ @EXPORT_OK, @EXPORT ] );

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;
my @allowed_patterns;

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

    if (not $no_end_test) {
        $names{done_testing} = ();
        my $callpkg = caller(0);
        no strict 'refs';
        no warnings 'once';
        undef *{$callpkg.'::done_testing'} if *{$callpkg.'::done_testing'}{CODE};
    }

    __PACKAGE__->export_to_level(1, $class, keys %names);
}

# swap this out 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 or grep +($_[0] =~ $_), @allowed_patterns) {
        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;
}

# check for any forbidden warnings, and record that we have done so
# so we do not check again via END
sub done_testing {
    if (Test2::Tools::Basic->can('done_testing')) {
        if (not $no_end_test and not $done_testing_called) {
            # we could use $ctx to create the test, which means not having to adjust Level,
            # but then we need to make _builder Test2-compatible, which seems like a PITA.
            local $Test::Builder::Level = $Test::Builder::Level + 3;
            had_no_warnings('no (unexpected) warnings (via done_testing)');
            $done_testing_called = 1;
        }

        Test2::Tools::Basic::done_testing(@_);
    }
    elsif (Test::Builder->can('done_testing')) {
        # 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 $done_testing_called
            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;
        }

        _builder->done_testing(@_);
    }
    else {
        die 'no done_testing available via a Test module';
    }
}

# we also monkey-patch Test::Builder::done_testing (which is called by Test::More::done_testing),
# in case Test::More was loaded after Test::Warnings and therefore its version of done_testing was
# imported into the test rather than ours.
if (Test::Builder->can('done_testing')) {
    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 $done_testing_called
            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 ]");
        }
    }
}

# pass one or more regexes (in qr format)
# when called in void context, lasting effect is universal
# otherwise, returns objects: when they go out of scope, the effect is removed
#   (warning disallowed again).
sub allow_patterns(@) {
  push @allowed_patterns, @_;
  return if not defined wantarray;
  return [ map +Test::Warnings::TemporaryWarning->new($_), @_ ];
}

sub disallow_patterns(@) {
  foreach my $pattern (@_) {
    @allowed_patterns = grep +($_ ne $pattern), @allowed_patterns;
  }
}

package # hide from PAUSE
  Test::Warnings::TemporaryWarning;

sub new {
  my ($class, $pattern) = @_;
  bless \$pattern, $class;
}

sub DESTROY {
  Test::Warnings::disallow_patterns(${$_[0]});
}

1;

__END__