package Devel::SummarizedWarnings;
use strict;
use warnings;
our @Warnings;

use constant NoSuchLine => 'NoSuchLine';

# Modify this globally
BEGIN {
    my $old_sig = $SIG{'__WARN__'};
    $SIG{'__WARN__'} =
        ref $SIG{'__WARN__'}
        ? sub { &$old_sig; &append_to_warning_log }
        : \ &append_to_warning_log;
}

END {
    dump_warnings();
}

sub append_to_warning_log {
    push @Warnings, grep +(not ref), @_;
}

sub dump_warnings {
    if ( $SIG{'__WARN__'} == \&append_to_warning_log ) {
        delete $SIG{'__WARN__'};
    } else {
        push @Warnings, __PACKAGE__ . " was disabled prior to summarization\n";
    }
    
    # Summarize the saved warnings
    my %order;
    my %sum;
    for ( @Warnings ) {
	my $msg;
	my $line;
        if ( not /^(.*) at $0 line (\d+).$/os ) {
	    s/\n$//;
	    $msg = $_;
	    $line = NoSuchLine;
        } else {
	    $msg  = $1;
	    $line = $2;
        }
	$sum{$msg}{$line}++;
	
	if ( not exists $order{$msg} ) {
	    no warnings 'numeric';
	    $order{$msg} = 1 + %order;
	}
    }
    @Warnings = ();

    # 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 @out;
}

1;

__END__

=head1 NAME

Devel::SummarizedWarnings - Causes warnings to be summarized

=head1 SYNOPSIS

 use Devel::SummarizedWarnings;
 use warnings;

 for ( 0 .. 10 ) {
     $k = 0 + undef . $_;
 }

 $k = 1 + undef . $_;

 warn "Seagulls!\n";

produces the output

 Warning: Use of "undef" without parens is ambiguous on lines 5 and 8
 Use of uninitialized value in addition (+) on lines 5 (x11) and 8
 Use of uninitialized value in concatenation (.) or string on line 8
 Seagulls!

instead of

 Warning: Use of "undef" without parens is ambiguous at w.pl line 5.
 Warning: Use of "undef" without parens is ambiguous at w.pl line 8.
 Use of uninitialized value in addition (+) at w.pl line 5.
 Use of uninitialized value in addition (+) at w.pl line 5.
 Use of uninitialized value in addition (+) at w.pl line 5.
 Use of uninitialized value in addition (+) at w.pl line 5.
 Use of uninitialized value in addition (+) at w.pl line 5.
 Use of uninitialized value in addition (+) at w.pl line 5.
 Use of uninitialized value in addition (+) at w.pl line 5.
 Use of uninitialized value in addition (+) at w.pl line 5.
 Use of uninitialized value in addition (+) at w.pl line 5.
 Use of uninitialized value in addition (+) at w.pl line 5.
 Use of uninitialized value in addition (+) at w.pl line 5.
 Use of uninitialized value in addition (+) at w.pl line 8.
 Use of uninitialized value in concatenation (.) or string at w.pl line 8.
 Seagulls!

=head1 DESCRIPTION

This module traps all warnings and summarizes them when the your perl script
exits. Warning trapping can be interrupted and resumed by removing/installing
the Devel::SummarizedWarnings::append_to_warning_log handler into
$SIG{'__WARN__'}.

Trapped warnings are stored in @Devel::SummarizedWarnings::Warnings.

=head1 AUTHOR

Joshua b. Jore E<lt>jjore@cpan.orgE<gt>

=cut