File Coverage

blib/lib/Devel/SummarizedWarnings.pm

Criterion	Covered	Total	%
statement	22	43	51.1
branch	2	18	11.1
condition			n/a
subroutine	7	8	87.5
pod	0	3	0.0
total	31	72	43.0

package Devel::SummarizedWarnings;
use strict;
use vars qw(@LOGGED_WARNINGS $INSTALLED_HANDLER $VERSION);

sub install_handler {
    my $old_handler = $SIG{'__WARN__'};
    my $new_handler =
	( $old_handler
	  ? sub { &$old_handler; &append_to_warning_log; }
	  : \&append_to_warning_log );

    $INSTALLED_HANDLER = $SIG{'__WARN__'} = $new_handler;

    return;
}

# Modify this globally
BEGIN {
    $VERSION = 0.01;
    install_handler();
}

END {
    dump_warnings();
}

sub append_to_warning_log {
    push @LOGGED_WARNINGS, @_;
}

sub dump_warnings {
    local $^W;
    if ( $SIG{'__WARN__'} != $INSTALLED_HANDLER ) {
        push
	    @LOGGED_WARNINGS,
	    __PACKAGE__ . " was disabled prior to summarization\n";
    }

    # Summarize the saved warnings
    my %order;
    my %sum;
    while ( my $warning = shift @LOGGED_WARNINGS ) {
	my $msg;
	my $line;
        if ( not $warning =~ /^(.*) at .+? line (\d+)\.$/s ) {
	    $warning =~ s/\n$//;
	    $msg = $warning;
	    $line = 'NoSuchLine';
        } else {
	    $msg  = $1;
	    $line = $2;
        }
	$sum{$msg}{$line}++;

	if ( not exists $order{$msg} ) {
	    $order{$msg} = 1 + %order;
	}
    }

    # Reformat the summarization
    my @out;
    for ( sort { $order{$a} <=> $order{$b} }
	  keys %order ) {
        my $wrn = $sum{$_};
        if ( exists $wrn->{'NoSuchLine'} ) {
            push
		@out,
	        $_
                . ( $wrn->{'NoSuchLine'} > 1
                    ? " (x$wrn->{'NoSuchLine'})"
                    : '' );
        } else {
            push
		@out,
		"$_ on line@{[1 < keys %$wrn ? 's' : '']} "
                . join( 2 == keys %$wrn ? ' and ' : ', ',
			map "$_@{[ $wrn->{$_} == 1
                                   ? ''
                                   : qq[ (x$wrn->{$_})]]}",
			sort { $a <=> $b }
                        keys %$wrn );
        }
    }

    local $\ = "\n";
    print STDERR for @out;
}

1;

__END__