# Backtrace.pm --- stack trace stub
# Author: Noah Friedman <friedman@splode.com>
# Created: 1997-01-18
# Public domain.

# $Id: Backtrace.pm,v 1.8 2000/02/11 11:15:42 friedman Exp $

# Commentary:

# More useful error information than `die'; it produces a subroutine stack
# trace showing arguments and line numbers.  I also like it better than the
# `confess' function from the Carp module.

# This routine lies about the stack frame number a little; it lists the
# caller of the backtrace function as frame 0, when really the backtrace
# subroutine itself is frame 0.

# Some versions of Perl5 sometimes get line numbers wrong.

# Code:

package NF::Backtrace;

use NF::Hook;
use strict;

use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
$VERSION     = 1.00;
@ISA         = qw(Exporter);
@EXPORT_OK   = qw(bt_caller bt_errmsg bt_join);
@EXPORT      = qw(backtrace);


use vars qw($backtrace_enabled $backtrace_hook);
$backtrace_enabled = 1;
$backtrace_hook = [];

sub backtrace ($;$$)
{
  my ($errmsg, $returnp, $frameskip) = @_;

  bt_errmsg ($returnp ? "error" : "fatal error", $errmsg);
  if ($backtrace_enabled)
    {
      bt_errmsg ("Stack trace follows.");

      my $framelist = [[ "Frame", "Line#", "Package", "Function", "Arguments" ]];
      my $maxwidth  =  [       5,       5,         7,          8,           9 ];
      my $numericp  =  [       1,       1 ];
      bt_frames_collect ($framelist, $maxwidth, $frameskip + 1);
      bt_frames_print ($framelist, $maxwidth, $numericp);
      run_hooks ($backtrace_hook);
    }
  exit (1) unless $returnp;
}

use vars qw(@current_frame);

sub bt_frames_collect ($$$)
{
  my ($framelist, $maxwidth, $frameskip) = @_;

  my $frameno = $frameskip;
  my @first_frame = bt_caller ($frameno);
  local *current_frame = \@first_frame;
  while (defined @current_frame)
    {
      @DB::args = ();
      my @next_frame = bt_caller ($frameno + 1);

      my $lineno = $current_frame[2];
      my $pkg = $current_frame[0];
      my $fn = $next_frame[3] ? $next_frame[3] : '[TOP LEVEL]';
      my $argstr = bt_join (', ', @DB::args);

      $fn = substr ($fn, length ($pkg) + 2) if (index ($fn, $pkg) == 0);
      $argstr = "(" . $argstr . ")" if ($argstr ne "");

      my @row = ($frameno - $frameskip, $lineno, $pkg, $fn, $argstr);

      my $i = 0;
      for my $elt (@row)
        {
          my $l = length ("$elt");
          $maxwidth->[$i] = $l if ($l > $maxwidth->[$i]);
          $i++;
        }
      push @$framelist, \@row;

      *current_frame = \@next_frame;
      $frameno++;
    }

  # perl complains of "attempt to free unreferenced scalar" if this is
  # pointing to undef, so set it back.
  *current_frame = \@first_frame;
}

sub bt_frames_print ($$$)
{
  my ($framelist, $maxwidth, $numericp) = @_;
  my $fmt = "";
  my $i = 0;

  while (defined $maxwidth->[$i])
    {
      $fmt .= $numericp->[$i] ? '%%%ds ' : '%%-%ds ';
      $i++;
    }
  $fmt = sprintf ($fmt, @$maxwidth);
  for my $row (@$framelist)
    {
      bt_errmsg (sprintf ($fmt, @$row));
    }
}

sub bt_caller
{
  # Switch context to the DB package, because that's the only way
  # the `caller' primitive will record the arguments to functions.  Feh!
  package DB;

  # Return the n+1 frame, to account for the fact that calling this
  # function pushed a new frame.
  caller ($_[0] + 1);
}

sub bt_errmsg
{
  my ($msg) = "\n";
  $msg = bt_escape (join (": ", $0, @_)) . "\n"
    if (defined ($_[0]));
  $msg =~ s/[ \t]+$//o;
  print (STDERR $msg);
}

sub bt_escape ($)
{
  my $s = $_[0];
  $s =~ s/\\/\\\\/go;
  $s =~ s/\n/\\n/go;
  return $s;
}

sub bt_join
{
  my ($sep, @list) = @_;
  my $i = 0;

  while ($i <= $#list)
    {
      $list[$i] = "'" . $list[$i] . "'"
        if (defined ($list[$i])
            && ($list[$i] =~ /[ \t\n\f\a"',]/o
                || $list[$i] eq ''
                # Distinguish between undef as an undefined parameter, and
                # the literal string `undef'.
                || $list[$i] eq 'undef'));
      $list[$i] = 'undef'
        if (! defined ($list[$i]));
      $i++;
    }
  join ($sep, @list);
}

1;

# Backtrace.pm ends here.