File Coverage

blib/lib/Acme/JavaTrace.pm

Criterion	Covered	Total	%
statement	61	65	93.8
branch	22	26	84.6
condition	14	17	82.3
subroutine	7	8	87.5
pod			n/a
total	104	116	89.6

package Acme::JavaTrace;
use strict;

{
    no strict;
    $VERSION = '0.08';
}

# Install warn() and die() substitutes
$SIG{'__WARN__'} = \&_do_warn;
$SIG{'__DIE__' } = \&_do_die;

my $stderr = '';
my $in_eval = 0;
my %options = (
    showrefs => 0,
);


#
# import()
# ------
sub import {
    my $class = shift;

    for my $opt (@_) {
        exists $options{$opt} ? $options{$opt} = not $options{$opt}
                              : CORE::warn "warning: Unknown option: $opt\n"
    }
}


#
# _use_data_dumper()
# ----------------
sub _use_data_dumper {
    require Data::Dumper;
    import Data::Dumper;
    $Data::Dumper::Indent = 1;      # no fancy indent
    $Data::Dumper::Terse  = 1;      # don't use $VAR unless needed
    $Data::Dumper::Sortkeys = 1;    # sort keys
    #$Data::Dumper::Deparse = 1;     # deparse code refs
    {
        local $^W = 0;
        *Devel::SimpleTrace::_use_data_dumper = sub {};
    }
}


#
# _do_warn()
# --------
sub _do_warn {
    local $SIG{'__WARN__'} = 'DEFAULT';

    my $msg = join '', @_;
    $msg =~ s/ at (.+?) line (\d+)\.$//;
    $stderr .= $msg;
    $stderr .= "\n" if substr($msg, -1, 1) ne "\n";

    _stack_trace($1, $2);

    print STDERR $stderr;
    $stderr = '';
    $in_eval = 0;
}


#
# _do_die()
# -------
sub _do_die {
    local $SIG{'__WARN__'} = 'DEFAULT';
    local $SIG{'__DIE__' } = 'DEFAULT';

    CORE::die @_ if ref $_[0] and not $options{showrefs};
    CORE::die @_ if index($_[0], "\n\tat ") >= 0;
    my @args = @_;

    _use_data_dumper() if ref $args[0];
    my $msg = join '', map { ref $_ ? "Caught exception object: $_\: ".Dumper($_) : $_ } @args;
    $msg =~ s/ at (.+?) line (\d+)\.$//;
    $stderr .= $msg;
    $stderr .= "\n" if substr($msg, -1, 1) ne "\n";

    _stack_trace($1, $2);

    if($in_eval) {
        $@ = $stderr;
        $stderr = '';
        $in_eval = 0;
        CORE::die $@

    } else {
        print STDERR $stderr;
        $stderr = '';
        exit -1
    }
}


#
# _stack_trace()
# ------------
sub _stack_trace {
    my($file,$line) = @_;
    $file ||= '';  $line ||= '';
    $file =~ '(eval \d+)' and $file = '';

    my $level = 2;
    my @stack = ( ['', $file, $line] );  # @stack = ( [ function, file, line ], ... )

    while(my @context = caller($level++)) {
        $context[1] ||= '';  $context[2] ||= '';
        $context[1] =~ '(eval \d+)' and $context[1] = '' and $in_eval = 1;
        $context[3] eq '(eval)' and $context[3] = '' and $in_eval = 1;
        $stack[-1][0] = $context[3];
        push @stack, [ '', @context[1, 2] ];
    }
    $stack[-1][0] = (caller($level-2))[0].'::' || 'main::';

    for my $func (@stack) {
        $$func[1] eq '' and $$func[1] = 'unknown source';
        $$func[2] and $$func[1] .= ':';
        $stderr .= "\tat $$func[0]($$func[1]$$func[2])\n";
    }
}


1;

__END__