Главная   Изменения   Спек   Патчи   Исходники   Загрузить   Gear   Bugs and FR  Repocop 

pax_global_header00006660000000000000000000000064100263554370014517gustar00rootroot0000000000000052 comment=2e9c76fd658d8a642adc1ddbd9da5f720712ec5c
Devel-Leak-0.03/000075500000000000000000000000001002635543700133505ustar00rootroot00000000000000Devel-Leak-0.03/Leak.pm000064400000000000000000000030211002635543700145560ustar00rootroot00000000000000package Devel::Leak;
use 5.005;
use vars qw($VERSION);
require DynaLoader;
use base qw(DynaLoader);
$VERSION = '0.03';

bootstrap Devel::Leak;

1;
__END__

=head1 NAME

Devel::Leak - Utility for looking for perl objects that are not reclaimed.

=head1 SYNOPSIS

  use Devel::Leak;
  ... setup code

  my $count = Devel::Leak::NoteSV($handle);

  ... code that may leak

  Devel::Leak::CheckSV($handle);

=head1 DESCRIPTION

Devel::Leak has two functions C<NoteSV> and C<CheckSV>.

C<NoteSV> walks the perl internal table of allocated SVs (scalar values) - (which
actually  contains arrays and hashes too), and records their addresses in a
table. It returns a count of these "things", and stores a pointer to the
table (which is obtained from the heap using malloc()) in its argument.

C<CheckSV> is passed argument which holds a pointer to a table created by
C<NoteSV>. It re-walks the perl-internals and calls sv_dump() for any "things"
which did not exist when C<NoteSV> was called. It returns a count of the number
of "things" now allocated.

=head1 CAVEATS

Note that you need a perl built with -DDEBUGGING for
sv_dump() to print anything, but counts are valid in any perl.

If new "things" I<have> been created, C<CheckSV> may (also) report additional
"things" which are allocated by the sv_dump() code.

=head1 HISTORY

This little utility module was part of Tk until the variable renaming
in perl5.005 made it clear that Tk had no business knowing this much
about the perl internals.

=head1 AUTHOR

Nick Ing-Simmons <nick@ni-s.u-net.com>

=cut

Devel-Leak-0.03/Leak.xs000064400000000000000000000063631002635543700146100ustar00rootroot00000000000000/*
  Copyright (c) 1995,1996-1998 Nick Ing-Simmons. All rights reserved.
  This program is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
*/

#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>

typedef long used_proc _((void *,SV *,long));
typedef struct hash_s *hash_ptr;

#ifndef DEBUGGING
#define sv_dump(sv) PerlIO_printf(PerlIO_stderr(), "\n")
#endif

#define MAX_HASH 1009

static hash_ptr pile = NULL;

static void
LangDumpVec(char *who, int count, SV **data)
{
 int i;
 PerlIO_printf(PerlIO_stderr(), "%s (%d):\n", who, count);
 for (i = 0; i < count; i++)
  {
   SV *sv = data[i];
   if (sv)
    {
     PerlIO_printf(PerlIO_stderr(), "%2d ", i);
     sv_dump(sv);
    }
  }
}

struct hash_s
{struct hash_s *link;
 SV *sv;
 char *tag;
};

static char *
lookup(hash_ptr *ht, SV *sv, void *tag)
{unsigned hash = ((unsigned long) sv) % MAX_HASH;
 hash_ptr p = ht[hash];
 while (p)
  {
   if (p->sv == sv)
    {char *old = p->tag;
     p->tag = tag;
     return old;
    }
   p = p->link;
  }
 if ((p = pile))
  pile = p->link;
 else
  p = (hash_ptr) malloc(sizeof(struct hash_s));
 p->link  = ht[hash];
 p->sv    = sv;
 p->tag   = tag;
 ht[hash] = p;
 return NULL;
}

void
check_arenas()
{
 SV *sva;
 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva))
  {
   SV *sv = sva + 1;
   SV *svend = &sva[SvREFCNT(sva)];
   while (sv < svend)
    {
     if (SvROK(sv) && ((IV) SvANY(sv)) & 1)
      {
       warn("Odd SvANY for %p @ %p[%d]",sv,sva,(sv-sva));
       abort();
      }
     ++sv;
    }
  }
}

long int
sv_apply_to_used(p, proc,n)
void *p;
used_proc *proc;
long int n;
{
 SV *sva;
 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva))
  {
   SV *sv = sva + 1;
   SV *svend = &sva[SvREFCNT(sva)];

   while (sv < svend)
    {
     if (SvTYPE(sv) != SVTYPEMASK)
      {
       n = (*proc) (p, sv, n);
      }
     ++sv;
    }
  }
 return n;
}

static char old[] = "old";
static char new[] = "new";

static long
note_sv(p,sv, n)
void *p;
SV *sv;
long int n;
{
 lookup(p,sv,old);
 return n+1;
}

long
note_used(hash_ptr **x)
{
 hash_ptr *ht;
 Newz(603, ht, MAX_HASH, hash_ptr);
 *x = ht;
 return sv_apply_to_used(ht, note_sv, 0);
}

static long
check_sv(void *p, SV *sv, long hwm)
{
 char *state = lookup(p,sv,new);
 if (state != old)
  {
   fprintf(stderr,"%s %p : ", state ? state : new, sv);
   sv_dump(sv);
  }
 return hwm+1;
}

static long
find_object(void *p, SV *sv, long count)
{
 if (sv_isobject(sv))
  {
   sv_dump(sv);
   count++;
  }
 return count;
}

long
check_used(hash_ptr **x)
{hash_ptr *ht = *x;
 long count = sv_apply_to_used(ht, check_sv, 0);
 long i;
 for (i = 0; i < MAX_HASH; i++)
  {hash_ptr p = ht[i];
   while (p)
    {
     hash_ptr t = p;
     p = t->link;
     if (t->tag != new)
      {
       LangDumpVec(t->tag ? t->tag : "NUL",1,&t->sv);
      }
     t->link = pile;
     pile = t;
    }
  }
 Safefree(ht);
 *x = NULL;
 return count;
}

MODULE = Devel::Leak	PACKAGE = Devel::Leak

PROTOTYPES: Enable

IV
NoteSV(obj)
hash_ptr *	obj = NO_INIT
CODE:
 {
  RETVAL = note_used(&obj);
 }
OUTPUT:
 obj
 RETVAL

IV
CheckSV(obj)
hash_ptr *	obj
CODE:
 {
  RETVAL = check_used(&obj);
 }
OUTPUT:
 RETVAL

IV
FindObjects()
CODE:
 {
  RETVAL = sv_apply_to_used(NULL, find_object, 0);
 }
OUTPUT:
 RETVAL

void
check_arenas()


Devel-Leak-0.03/MANIFEST000064400000000000000000000004121002635543700144760ustar00rootroot00000000000000Leak.pm				The perl part (with the docs as pod)
Leak.xs				C code
MANIFEST			This file
MANIFEST.SKIP			Things to to list here
Makefile.PL			How to build it
README				Description of package 
t/basic.t			A Basic test
typemap				How our C structures get stored as perl
Devel-Leak-0.03/MANIFEST.SKIP000064400000000000000000000000741002635543700152470ustar00rootroot00000000000000\bblib\b
%$
\.(bak|old|o|c|bs|gz)$
\b(pm_to_blib|Makefile)$
Devel-Leak-0.03/Makefile.PL000064400000000000000000000005431002635543700153240ustar00rootroot00000000000000use ExtUtils::MakeMaker;
use Config;

unless ($Config{'ccflags'} =~ /-DDEBUGGING/)
 {
  warn "This perl is not compiled with -DDEBUGGING - functions restricted\n";
 }

WriteMakefile( 
    'NAME'     => 'Devel::Leak',
    'clean' => {FILES => "*% *.bak"},
    'dist'     => { COMPRESS => 'gzip -f9', SUFFIX => '.gz' },
    'VERSION_FROM'  => 'Leak.pm'
);

Devel-Leak-0.03/README000064400000000000000000000006311002635543700142300ustar00rootroot00000000000000Copyright (c) 1997-1998 Nick Ing-Simmons. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

This module provides a basic way to discover if a piece of perl code
is allocating perl data and not releasing them again.

You install this package using CPAN.pm or the normal:

perl Makefile.PL
make
make test 
make install 

process.
Devel-Leak-0.03/t/000075500000000000000000000000001002635543700136135ustar00rootroot00000000000000Devel-Leak-0.03/t/basic.t000064400000000000000000000005771002635543700150720ustar00rootroot00000000000000use Test;
plan test => 3;
eval { require Devel::Leak };
ok($@, "", "loading module");
eval { import Devel::Leak };
ok($@, "", "running import");
@somewhere = ();
my $count = Devel::Leak::NoteSV($handle);
print "$count SVs so far\n";
for my $i (1..10)
 {
  @somewhere = qw(one two);
 }
my $now = Devel::Leak::CheckSV($handle);
ok($now, $count+2, "Number of SVs created unexpected");

Devel-Leak-0.03/typemap000064400000000000000000000000231002635543700147450ustar00rootroot00000000000000hash_ptr *		T_PTR