File Coverage

inc/Test/Warn.pm

Criterion	Covered	Total	%
statement	41	140	29.2
branch	3	46	6.5
condition	1	18	5.5
subroutine	10	24	41.6
pod	3	3	100.0
total	58	231	25.1

#line 1
#line 241


package Test::Warn;

use 5.006;
use strict;
use warnings;

#use Array::Compare;
use Sub::Uplevel 0.12;

our $VERSION = '0.30';

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
    @EXPORT
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
    warning_is   warnings_are
    warning_like warnings_like
    warnings_exist
);

use Test::Builder;
my $Tester = Test::Builder->new;

{
no warnings 'once';
*warning_is = *warnings_are;
*warning_like = *warnings_like;
}

sub warnings_are (&$;$) {
    my $block       = shift;
    my @exp_warning = map {_canonical_exp_warning($_)}
                          _to_array_if_necessary( shift() || [] );
    my $testname    = shift;
    my @got_warning = ();
    local $SIG{__WARN__} = sub {
        my ($called_from) = caller(0);  # to find out Carping methods
        push @got_warning, _canonical_got_warning($called_from, shift());
    };
    uplevel 1,$block;
    my $ok = _cmp_is( \@got_warning, \@exp_warning );
    $Tester->ok( $ok, $testname );
    $ok or _diag_found_warning(@got_warning),
           _diag_exp_warning(@exp_warning);
    return $ok;
}


sub warnings_like (&$;$) {
    my $block       = shift;
    my @exp_warning = map {_canonical_exp_warning($_)}
                          _to_array_if_necessary( shift() || [] );
    my $testname    = shift;
    my @got_warning = ();
    local $SIG{__WARN__} = sub {
        my ($called_from) = caller(0);  # to find out Carping methods
        push @got_warning, _canonical_got_warning($called_from, shift());
    };
    uplevel 1,$block;
    my $ok = _cmp_like( \@got_warning, \@exp_warning );
    $Tester->ok( $ok, $testname );
    $ok or _diag_found_warning(@got_warning),
           _diag_exp_warning(@exp_warning);
    return $ok;
}

sub warnings_exist (&$;$) {
    my $block       = shift;
    my @exp_warning = map {_canonical_exp_warning($_)}
                          _to_array_if_necessary( shift() || [] );
    my $testname    = shift;
    my @got_warning = ();
    local $SIG{__WARN__} = sub {
        my ($called_from) = caller(0);  # to find out Carping methods
        my $wrn_text=shift;
        my $wrn_rec=_canonical_got_warning($called_from, $wrn_text);
        foreach my $wrn (@exp_warning) {
          if (_cmp_got_to_exp_warning_like($wrn_rec,$wrn)) {
            push @got_warning, $wrn_rec;
            return;
          }
        }
        warn $wrn_text;
    };
    uplevel 1,$block;
    my $ok = _cmp_like( \@got_warning, \@exp_warning );
    $Tester->ok( $ok, $testname );
    $ok or _diag_found_warning(@got_warning),
           _diag_exp_warning(@exp_warning);
    return $ok;
}


sub _to_array_if_necessary {
    return (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : ($_[0]);
}

sub _canonical_got_warning {
    my ($called_from, $msg) = @_;
    my $warn_kind = $called_from eq 'Carp' ? 'carped' : 'warn';
    my @warning_stack = split /\n/, $msg;     # some stuff of uplevel is included
    return {$warn_kind => $warning_stack[0]}; # return only the real message
}

sub _canonical_exp_warning {
    my ($exp) = @_;
    if (ref($exp) eq 'HASH') {             # could be {carped => ...}
        my $to_carp = $exp->{carped} or return; # undefined message are ignored
        return (ref($to_carp) eq 'ARRAY')  # is {carped => [ ..., ...] }
            ? map({ {carped => $_} } grep {defined $_} @$to_carp)
            : +{carped => $to_carp};
    }
    return {warn => $exp};
}

sub _cmp_got_to_exp_warning {
    my ($got_kind, $got_msg) = %{ shift() };
    my ($exp_kind, $exp_msg) = %{ shift() };
    return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
    my $cmp = $got_msg =~ /^\Q$exp_msg\E at .+ line \d+\.?$/;
    return $cmp;
}

sub _cmp_got_to_exp_warning_like {
    my ($got_kind, $got_msg) = %{ shift() };
    my ($exp_kind, $exp_msg) = %{ shift() };
    return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
    if (my $re = $Tester->maybe_regex($exp_msg)) { #qr// or '//'
        my $cmp = $got_msg =~ /$re/;
        return $cmp;
    } else {
        return Test::Warn::Categorization::warning_like_category($got_msg,$exp_msg);
    }
}


sub _cmp_is {
    my @got  = @{ shift() };
    my @exp  = @{ shift() };
    scalar @got == scalar @exp or return 0;
    my $cmp = 1;
    $cmp &&= _cmp_got_to_exp_warning($got[$_],$exp[$_]) for (0 .. $#got);
    return $cmp;
}

sub _cmp_like {
    my @got  = @{ shift() };
    my @exp  = @{ shift() };
    scalar @got == scalar @exp or return 0;
    my $cmp = 1;
    $cmp &&= _cmp_got_to_exp_warning_like($got[$_],$exp[$_]) for (0 .. $#got);
    return $cmp;
}

sub _diag_found_warning {
    foreach (@_) {
        if (ref($_) eq 'HASH') {
            ${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}")
                          : $Tester->diag("found warning: ${$_}{warn}");
        } else {
            $Tester->diag( "found warning: $_" );
        }
    }
    $Tester->diag( "didn't find a warning" ) unless @_;
}

sub _diag_exp_warning {
    foreach (@_) {
        if (ref($_) eq 'HASH') {
            ${$_}{carped} ? $Tester->diag("expected to find carped warning: ${$_}{carped}")
                          : $Tester->diag("expected to find warning: ${$_}{warn}");
        } else {
            $Tester->diag( "expected to find warning: $_" );
        }
    }
    $Tester->diag( "didn't expect to find a warning" ) unless @_;
}

package Test::Warn::Categorization;

use Carp;

my $bits = \%warnings::Bits;
my @warnings = sort grep {
  my $warn_bits = $bits->{$_};
  #!grep { $_ ne $warn_bits && ($_ & $warn_bits) eq $_ } values %$bits;
} keys %$bits;

my %warnings_in_category = (
  'utf8' => ['Wide character in \w+\b',],
);

sub _warning_category_regexp {
    my $category = shift;
    my $category_bits = $bits->{$category} or return;
    my @category_warnings
      = grep { ($bits->{$_} & $category_bits) eq $bits->{$_} } @warnings;

    my @list =
      map { exists $warnings_in_category{$_}? (@{ $warnings_in_category{$_}}) : ($_) }
      @category_warnings;
    my $re = join "|", @list;
    return qr/$re/;
}

sub warning_like_category {
    my ($warning, $category) = @_;
    my $re = _warning_category_regexp($category) or
        carp("Unknown warning category '$category'"),return;
    my $ok = $warning =~ /$re/;
    return $ok;
}

1;