head	1.1;
access;
symbols;
locks
	mjd:1.1; strict;
comment	@# @;


1.1
date	2002.08.30.19.29.14;	author mjd;	state Exp;
branches;
next	;


desc
@@


1.1
log
@Initial revision
@
text
@
package LeakFinder;
use Scalar::Util 'reftype', 'blessed';
$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 {
    print STDERR "*** Don't know how to compute size of $type object -- guessing 16 bytes\n"
      unless $dunno{$type}++;
  }
#  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;
  length $$sref + 16 + 1;  # Approximate; depends on flags
}

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 {
  return 108;  # Plus the name, which I omitted
}

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



1;
@