use overload;

sub stacktrace {
    #this is taken almost verbatum from Carp::Heavy::longmess_heavy
    no strict;
    no warnings;
    return @_ if ref $_[0];
    my $error = join '', @_;
    my $mess = "";
    my $i = 0;
    my @stack;
    my ($pack,$file,$line,$sub,$hargs,$eval,$require);
    my (@a);
    #
    # crawl up the stack....
    #
    while (do { { package DB; @a = caller($i++) } } ) {
    # get copies of the variables returned from caller()
    ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;

        # Build a string, $sub, which names the sub-routine called.
    # This may also be "require ...", "eval '...' or "eval {...}"
        if (defined $eval) {
        if ($require) {
            $sub = "require $eval";
        } else {
            $eval =~ s/([\\\'])/\\$1/g;
            if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
            substr($eval,$MaxEvalLen) = '...';
            }
            $sub = "eval '$eval'";
        }
        } elsif ($sub eq '(eval)') {
        $sub = 'eval {...}';
        }
        # if there are any arguments in the sub-routine call, format
        # them according to the format variables defined earlier in
        # this file and join them onto the $sub sub-routine string
        if ($hargs) {
        # we may trash some of the args so we take a copy
        @a = @DB::args;    # must get local copy of args
        # don't print any more than $MaxArgNums
        if ($MaxArgNums and @a > $MaxArgNums) {
            # cap the length of $#a and set the last element to '...'
            $#a = $MaxArgNums;
            $a[$#a] = "...";
        }
        for (@a) {
            # set args to the string "undef" if undefined
            $_ = "undef", next unless defined $_;
            if (ref $_) {
            # force reference to string representation
            $_ = overload::StrVal($_);
            s/'/\\'/g;
            }
            else {
            s/'/\\'/g;
            # terminate the string early with '...' if too long
            substr($_,$MaxArgLen) = '...'
                if $MaxArgLen and $MaxArgLen < length;
            }
            # 'quote' arg unless it looks like a number
            $_ = "'$_'" unless /^-?[\d.]+$/;
            # print high-end chars as 'M-<char>'
            s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
            # print remaining control chars as ^<char>
            s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
        }
        # append ('all', 'the', 'arguments') to the $sub string
        $sub .= '(' . join(', ', @a) . ')';
        }
        # here's where the error message, $mess, gets constructed
        unshift @stack,"$sub $error at $file line $line".
                ((defined &Thread::tid)
                  ? " thread ". Thread->self->tid
              : "");


    } join ("\n",@stack) || "No stack at toplevel...\n";
}
[download]