File Coverage

blib/lib/Devel/DollarAt.pm

Criterion	Covered	Total	%
statement	49	79	62.0
branch	9	26	34.6
condition	2	15	13.3
subroutine	11	16	68.7
pod	3	3	100.0
total	74	139	53.2

package Devel::DollarAt;
use strict;
use warnings;
use base qw(Class::Accessor::Fast);
use Devel::Backtrace;

our $VERSION = '0.02';

__PACKAGE__->mk_accessors(
    qw(backtrace err propagated inputline inputhandle filename line)
);

# Note that to_string also internally called if an exception isn't catched by
# any eval and the error must be printed to STDERR.
use overload '""' => \&to_string;

$SIG{__DIE__} = \&_diehandler;

our $FRAME;

# This will be called every time the code says "die".  However it won't be
# called for other errors, such as division by zero.  So we still have to use
# $SIG{__DIE__}.
*CORE::GLOBAL::die = sub (@) {
    my $text = '';
    defined and $text .= $_ for @_;

    my $err = $@;

    if (defined($err) && length($err) && !length $text) {
	# In this case, perl would pass "$@\t...propagated at foo line bar.\n"
	# to the __DIE__ handler.  Because we don't want to parse that, we make
	# perl think $text is not empty.

	# We have to store $err in our NullMessage because perl will cleanse $@
	# before calling the __DIE__ handler.  This is very strange, because it
	# won't get cleansed if we don't override *CORE::GLOBAL::die.
	$text = Devel::DollarAt::NullMessage->_new(propagated=>$err);
    }

    CORE::die($text);
};

sub _diehandler {
    my ($err) = @_;

    my $propagated = $@;

    if (ref($err) && $err->isa('Devel::DollarAt::NullMessage')) {
	$propagated = $err->{propagated};
	$err = '';
    }

    my $backtrace = Devel::Backtrace->new(1);
    my $skip = $backtrace->skipmysubs(); # skips this handler plus our overridden
				         # CORE::GLOBAL::die if possible
    CORE::die "Strange:\n$backtrace" unless $skip;

    my ($inputhandle, $inputline);
    if ($err =~ s/^(.*) at .*?(?:<(.*)> line (\d+)|)\.\n\z/$1/s) {
	($inputhandle, $inputline) = ($2, $3);
    }

    my $dollarat = __PACKAGE__->_new({
	    backtrace => $backtrace,
	    err => $err,
	    filename => $skip->filename,
	    line => $skip->line,
	}
    );

    if (defined $inputline) {
	$dollarat->inputline($inputline);
	$dollarat->inputhandle($inputhandle);
    }

    if (defined $propagated and length $propagated) {
	$dollarat->propagated($propagated);
    }

    CORE::die($dollarat);
}

# Try to appear exactly like the normal $@
sub to_string {
    my $this = shift;

    my $text = $this->err;

    if (defined ($this->propagated)) {
	if (!length($text)) {
	    $text = $this->propagated . "\t...propagated";
	}
    }

    unless ($text =~ /\n\z/) {
	$text .= ' at ' . $this->filename . ' line ' . $this->line;
	if (defined $this->inputline) {
	    $text .= ', <'.$this->inputhandle . '> line ' . $this->inputline;
	}
    }

    $text .= '.';
    $text = "[[$text]]" if $FRAME;
    $text .= "\n";

    return $text;
}

sub _new {
    my $class = shift;
    my $this = $class->SUPER::new(@_);

    return $this;
}

sub import {
    my $class = shift;
    for (@_) {
	if ('frame' eq $_) {
	    $FRAME = 1;
	} else {
	    die 'Unknown parameter for '.__PACKAGE__.": $_";
	}
    };
}

sub redie {
    my $this = shift;
    my ($package, $filename, $line) = caller;
    push @{$this->{redispatch_points}}, Devel::DollarAt::RedispatchPoint->new({
	    package => $package,
	    filename => $filename,
	    line => $line,
	}
    );
    local $SIG{__DIE__};
    CORE::die($this);
}

sub redispatch_points {
    my $this = shift;
    return @{$this->{redispatch_points} || []};
}

package # hide from pause
    Devel::DollarAt::NullMessage;
#use overload '""' => sub {''};
sub _new { shift; bless {@_}; }

package # hide from pause
        Devel::DollarAt::RedispatchPoint;
use base qw(Class::Accessor::Fast);
__PACKAGE__->mk_ro_accessors(qw(package filename line));

use overload '""' => sub {
    my $this = shift;

    return 'redispatched from '.$this->package.' at '
    .$this->filename.':'.$this->line."\n";
};

1
__END__