package LeakFinder;
use Scalar::Util 'reftype', 'blessed';
use B;
$DEBUG = $ENV{LEAKFINDER_DEBUG};

BEGIN {
  if (exists $ENV{LEAKFINDER}) {
    unless (open REPORT, ">", $ENV{LEAKFINDER}) {
      die "Couldn't open LeakFinder report file '$ENV{LEAKFINDER}': $!; aborting";
    }
  } else {
    open REPORT, ">&STDOUT" 
      or die "Couldn't dup STDOUT: $!; aborting";
  }
}

END {
  walk_symbol_table('', \&register_destructor);

  # In case walking the symbol table didn't already install this
  *UNIVERSAL::DESTROY = \&_destroy_sub;

  print STDERR "Executed LeakFinder::END\n" if $DEBUG;
}

sub walk_symbol_table {
  my ($package, $callback, $user) = @_;
  print STDERR "Walking from $package\n" if $DEBUG > 1;
  return if $package eq 'main::'; # special case
  $callback->($package);
  my $symtab = \%{$package . "::"};
  for my $k (keys %$symtab) {
    next unless $k =~ /::$/;
    walk_symbol_table("$package$k", $callback, $user);
  }
}

sub register_destructor {
  my $package = shift;
  $package =~ s/^:://;
  $package =~ s/::$//;
  if (defined &{"$package\::DESTROY"}) {
    print STDERR "Replacing DESTROY for package $package\n" if $DEBUG;
    $true_destructor{$package} = \&{"$package\::DESTROY"};
    *{"$package\::DESTROY"} = \&_destroy_sub;
  }
}

sub _destroy_sub {
  # Issue report about object being destroyed
  my ($obj) = @_;
  _report_on($obj);

  # Now call the real destructor
  my $class = ref $obj;
  my $true_destructor = $true_destructor{$class};
  $true_destructor->($obj) if defined $true_destructor;
}

sub _report_on {
  my $obj = shift;
  my $class = ref $obj;
  my $type = reftype $obj;
  my $size = _sizeof($obj, 1);
  $total_size += $size;
  print REPORT "$obj $size $total_size\n";
}

my %seen;
sub _sizeof {
  my $thing = shift;

  if (not defined $thing) {
    print STDERR "$:It's undefined.  Returning.\n" if $DEBUG;
    return;
  }

  my $top = shift;
  local $INDENT = $INDENT + 1;
  local $: = "  " x $INDENT;

  my $seen = $seen{$thing} ? ' (already seen)' : '';
  print STDERR "$:Computing size of '$thing'$seen\n" if $DEBUG;

  # These will get counted later, when they are DESTROYed
  if ((not $top) and blessed($thing)) {
    print STDERR "$:It's blessed; I'll count it later.\n" if $DEBUG;
    return 0;
  }

  # Do not count the same object twice
  if (ref $thing && $seen{$thing}++) {
    print STDERR "$:Saw it already; returning 0\n" if $DEBUG;
    return 0;
  }

  my $type = reftype $thing;
  if (! defined($type) || $type eq "") {
    my $s = 16 + length($thing);  # Approximate
    print STDERR "$:It's not a reference; estimating $s.\n" if $DEBUG;
    return $s;
  } else {
    print STDERR "$:It has reftype $type\n" if $DEBUG;
  }

  # extra 16 bytes for the reference itself
  print STDERR "$:Calling _sizeof_$type\n" if $DEBUG;
  my $subr = "_sizeof_$type";
  my $size = 16;
  if (defined &$subr) {
    my $newsize = &{$subr}($thing);
    print STDERR "$:It said $newsize bytes.\n" if $DEBUG;
    $size += $newsize;
  } else {
    dunno($type, 16);
  }
#  delete $seen{$thing};
  print STDERR "$:Size is $size bytes\n" if $DEBUG;
  return $size;
}

sub _sizeof_ARRAY {
  my $aref = shift;
  my $size = 49 + 4 * @$aref;
  my $i = 0;
  for (@$aref) {
    print STDERR "$: [$i]...\n" if $DEBUG > 2;
    $i++;
    $size += _sizeof($_);
  }
  $size;
}

sub _sizeof_SCALAR {
  my $sref = shift;
  my $B = B::svref_2object($sref);
  my $flags = $B->FLAGS;
  my $type = $B->class;
  if ($type eq 'RV') {
    return 16 + _sizeof_SCALAR($$sref);
  } elsif ($type eq 'PV') {
    return 24 + length($$sref) + 1;   # Extra 1 for trailing nul
  } elsif ($type eq 'PVIV') {
    my $s = 28;
    if ($flags & B::Svf_POK) {
      $s += lengtg($$sref) + 1;
    }
    return $s;
  } elsif ($type eq 'NV') {
    my $s = 32;
    if ($flags & B::Svf_POK) {
      $s += lengtg($$sref) + 1;
    }
    return $s;
  } elsif ($type =~ /^PV(MG|LV|BM|FM|IO)$/) {
    my $t = $1;
    my %base_size = (MG => 40, LV => 56, 
                     BM => 47, FM => 88, IO => 96);
    my $s = $base_size{$t};
    $s += _sizeof_MAGIC($B->MAGIC);
    return $s;
  } elsif ($type eq 'PVGV') {
    my $s = _sizeof_GLOB($sref, $B);
    return $s;
  } else {
    dunno($type);
  }
}

sub _sizeof_HASH {
  my $href = shift;
  my $nkeys = keys %$href;
  my ($nbuckets) = %$href =~ m{/(\d+)};
  my $size = 56 + $nbuckets*4 + 21*$nkeys;
  print STDERR "$:Hash $href has $nkeys keys and overhead $size bytes.\n" 
    if $DEBUG > 1;
  my ($k, $v);
  foreach $k (keys %$href) {
    print STDERR "$: key $k...\n" if $DEBUG > 2;
    $size += length($k) + 1;  # +1 for trailing null
    $size += _sizeof($href->{$k}) if defined $href->{$k};
  }
  print STDERR "$:sizeof_HASH returning $size\n" if $DEBUG > 1;
  $size;
}

sub _sizeof_GLOB {
  my ($sref, $B) = @_;
  $B = B::svref_2object($sref) unless $B;
  my $s = 60 + 48;   # gv = 60; struct gp = 48
  $s += length($B->NAME) + 1;
  $s += _sizeof_HASH($B->STASH);
  $s += _sizeof_HASH($B->HV);
  $s += _sizeof_ARRAY($B->AV);
  $s += _sizeof_SCALAR($B->SV);
  $s += _sizeof_SCALAR($B->FM);
  $s += _sizeof_IO($B->IO);
  $s += _sizeof_IO($B->EGV);
  $s += _sizeof_MAGIC($B->MAGIC);
  return $s;
}

sub _sizeof_MAGIC {
  my $s = 0;
  for (my $mg = shift; $mg; $mg = $mg->MOREMAGIC) {
    # 24 = MAGIC
    # 28 = mgvtbl
    $s += 24 + 28;
  }
  return $s;
}

sub _sizeof_IO {
  return 96;  # Plus the PerlIO structures, which I omitted
}


sub dunno {
  my $ype = shift;
  print STDERR "*** Don't know how to compute size of $type object\n";
    unless $dunno{$type}++;
  return;
}

1;