Acme-JavaTrace

 view release on metacpan or  search on metacpan

lib/Acme/JavaTrace.pm  view on Meta::CPAN

{
    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 {

lib/Acme/JavaTrace.pm  view on Meta::CPAN

# 
# _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) = @_;

lib/Acme/JavaTrace.pm  view on Meta::CPAN

        $context[1] =~ '(eval \d+)' and $context[1] = '<eval>' and $in_eval = 1;
        $context[3] eq '(eval)' and $context[3] = '<eval>' 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__

=head1 NAME

t/02hooks.t  view on Meta::CPAN

# Now check that Acme::JavaTrace is working as expected.
# For this, we define a few functions that call each others using 
# the differents mechanisms available in Perl. 
sub first_caller  { second_caller(@_) }
sub second_caller { third_caller(@_) }
sub third_caller  { goto &fourth_caller }
sub fourth_caller { eval "fifth_caller('$_[0]')"; die $@ if $@ }
sub fifth_caller  { eval "$_[0] 'hellooo nurse!!'"; die $@ if $@ }

# To intercept the messages, we redefine STDERR as a tie()ed object. 
my $stderr = '';
tie *STDERR, 'Acme::JavaTrace::Test';

# First we test warn().
$stderr = '';
first_caller('warn');
my $warn_msg = $stderr;

# Then we test die().
$stderr = '';
eval { first_caller('die') };
my $die_msg = $@;

# Now we check that what we got correspond to what we expected.
my($file) = $warn_msg =~ /\(([^<>]+?):\d+\)/;
my $errmsg = <<"ERRMSG";
hellooo nurse!!
	at <eval>(<eval>:1)
	at main::fifth_caller(${file}:27)
	at <eval>(<eval>:1)

t/02hooks.t  view on Meta::CPAN

ok( $die_msg, $errmsg );  #06


package Acme::JavaTrace::Test;
sub TIEHANDLE {
    return bless {}, shift
}
sub PRINT {
    my $self = shift;
    $stderr .= join '', @_;
}