File Coverage

lib/No/Die.pm

Criterion	Covered	Total	%
statement	48	49	97.9
branch	8	10	80.0
condition			n/a
subroutine	10	11	90.9
pod			n/a
total	66	70	94.2

package No::Die;

use Carp                        qw[carp croak];
use Params::Check               qw[check];
use Locale::Maketext::Simple    Style => 'gettext';

use strict;
use vars qw[$DIE $VERSION];

$VERSION = 0.02;

BEGIN { *CORE::GLOBAL::die = sub { goto &_nodie } }

my $Store = { files => [ ], packages => [ ] };

### for debugging purposes only ###
sub _store { return $Store };

sub import {
    my $self = shift;
    my ($pkg,$file) = caller;

    if( @_ ) {

        my $tmpl = {
           files       => { default => [ ], strict_type => 1 },
           packages    => { default => [ ], strict_type => 1 },
        };

        local $Params::Check::VERBOSE = 1;

        my $args = check( $tmpl, { @_ } )
            or die qq[Improper arguments!];

        for( keys %$args ) {
            push @{$Store->{$_}}, @{$args->{$_}};
        }

    }
    push @{$Store->{files}}, $file, $INC{'No/Die.pm'};
    push @{$Store->{packages}}, $pkg, __PACKAGE__;

    {   no strict 'refs';
        *{"${pkg}::DIE"} = *DIE;
    }
}

sub _nodie {
    my @call; my $flag;
    my ($pkg) = @call = caller;

    local $Params::Check::VERBOSE = 0;

    ### sort is important, because of caller order ###
    for my $key ( reverse sort keys %$Store ) {
        $flag++ if check(
                { $key => { allow => $Store->{$key} } },
                { $key => shift @call },
            );
    };

    if( $flag ) {
        $DIE = undef;
        croak(@_);

    } else {
        carp loc(q[Unallowed '%1' requested from package '%2'], 'die', $pkg) if $^W;
        $DIE = "@_";
        return undef;
    }
}
1;

__END__