# Fri Oct 29 16:30:48 2004  Chris Tarnutzer, tarnutzer@ethlife.ethz.ch
#
# Copyright 2004 by Chris Tarnutzer, 2005-2020 by Christian Jaeger
# 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 TODO

Use L<Devel::Confess> or L<Carp Always> instead?

=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;
use Safe::Isa;

# 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 $SIG{__DIE__}->$_isa("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;
