# Fri Oct 29 16:30:48 2004  Chris Tarnutzer, tarnutzer@ethlife.ethz.ch
# 
# Copyright 2004 by Chris Tarnutzer
# Published under the same terms as perl itself
#

=head1 NAME

Chj::Backtrace

=head1 SYNOPSIS

Add backtrace to all string based exceptions (those thrown by die
"somestring").

=head1 DESCRIPTION


=head1 NOTE

This is alpha software! Read the status section in the package README
or on the L<website|http://functional-perl.org/>.

=cut


package Chj::Backtrace;
use strict; use warnings; use warnings FATAL => 'uninitialized';
use Carp;

# Carp::longmess 'usually' inserts a needless repetition
# if the argument was already created by confess:
#   Hello at (eval 35) line 1.
#    at (eval 35) line 1
#           eval 'package calc; no strict \'vars\';  die "Hello"
#   ...
# Clean removes this needless second line/repetition.
# (croak creates a different text so the double duty is not removed.)

sub Clean {
    my ($str)=@_;
    $str=~ s/(at [^\n]* line \d+)\.\n (at [^\n]* line \d+)\n/
       if ($1 eq $2) {
          $1.".\n"
       } else {
          $1.".\n ".$2."\n"
       }
    /se;
    $str
}

our $singlestep=0;#?.
our $only_confess_if_not_already=1;
our $do_confess_objects=0;

sub import {

    # Do not override any handler that a previous FP::Repl::Trap may
    # have installed (HACKY):
    return if UNIVERSAL::isa($SIG{__DIE__}, "FP::Repl::WithRepl::Handler");

    $SIG{__DIE__} = sub {
        $DB::single=1 if $singlestep;
        if ($only_confess_if_not_already) {
            if (!$do_confess_objects and ref $_[0]) {
                # exception object
                # (ah well, confess does that check anyway!)
                die @_
            } else {
                #print STDERR "\n------\n@_\n------\n";
                if ($_[0]=~ /^[^\n]*line \d+\.\n/s) { # die, not confess.
                    die Clean Carp::longmess @_
                } elsif ($_[0]=~ /^[^\n]*line \d+\n\t/s) { # confess
                    die @_
                } else { # unsure
                    die Clean Carp::longmess @_
                }
            }
        } else {
            die Clean Carp::longmess @_
        }
    };
}


1;