You are viewing a plain text version of this content. The canonical link for it is here.
Posted to modperl-cvs@perl.apache.org by do...@hyperreal.org on 1998/11/06 22:07:54 UTC
cvs commit: modperl/Leak Leak.pm Leak.xs Makefile.PL typemap
dougm 98/11/06 13:07:54
Added: Leak Leak.pm Leak.xs Makefile.PL typemap
Log:
new module for tracking memory leaks
Revision Changes Path
1.1 modperl/Leak/Leak.pm
Index: Leak.pm
===================================================================
package Apache::Leak;
use strict;
use DynaLoader ();
use Exporter ();
*import = \&Exporter::import;
{
no strict;
@EXPORT = qw(leak_test);
$VERSION = '1.00';
@ISA = qw(DynaLoader);
__PACKAGE__->bootstrap($VERSION);
}
sub LOOP_N () {2}
sub leak_test (&;$$) {
my($cv, $x, $fh) = @_;
$x ||= LOOP_N;
$fh ||= \*STDERR;
my $first = $x;
while($x--) {
my $handle;
my $enter = NoteSV($handle);
my $leave = 0;
print $fh "ENTER: $enter SVs\n";
{
$cv->();
}
$leave = CheckSV($handle);
print $fh "\nLEAVE: $leave SVs\n";
if($enter != $leave) {
my $n = $leave - $enter;
if($x+1 == $first) {
}
else {
print $fh "!!! $n SVs leaked !!!\n";
}
}
}
}
sub handler {
my $r = shift;
my $uri = $r->uri;
my $handle;
my $count = NoteSV($handle);
$r->push_handlers(PerlLogHandler => sub {
warn "Leak test for $uri:\n";
warn " ENTER: $count SVs\n";
$count = CheckSV($handle);
warn " LEAVE: $count SVs\n";
});
0;
}
1;
__END__
=head1 NAME
Apache::Leak - Module for tracking memory leaks in mod_perl code
=head1 SYNOPSIS
use Apache::Leak;
leak_test {
my $obj = Foo->new;
$obj->thingy;
};
#now look in error_log for results
=head1 DESCRIPTION
"Under Construction."
=head1 SEE ALSO
Devel::Leak
=head1 AUTHOR
Doug MacEachern
Leak.xs derived from Nick Ing-Simmons' Devel::Leak
1.1 modperl/Leak/Leak.xs
Index: Leak.xs
===================================================================
/*
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.
*/
/*
modified by dougm for use with 5.004_04
future versions may be made special for the mod_perl environment
*/
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#include "patchlevel.h"
#if ((PATCHLEVEL == 4) && (SUBVERSION <= 76))
#define PL_sv_arenaroot sv_arenaroot
#endif
typedef long used_proc _((void *, SV *, long));
typedef struct hash_s *hash_ptr;
#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;
}
static 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;
}
}
}
static long int sv_apply_to_used(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(void *p, SV *sv, long int n) {
lookup(p, sv, old);
return n+1;
}
static 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 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;
}
}
free(ht);
*x = NULL;
return count;
}
MODULE = Apache::Leak PACKAGE = Apache::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
void
check_arenas()
1.1 modperl/Leak/Makefile.PL
Index: Makefile.PL
===================================================================
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => "Apache::Leak",
VERSION_FROM => "Leak.pm",
);
1.1 modperl/Leak/typemap
Index: typemap
===================================================================
hash_ptr * T_PTR
Re: cvs commit: modperl/Leak Leak.pm Leak.xs Makefile.PL typemap
Posted by doomgrinder <ix...@maz.org>.
YAY!@#$@#$@#!
Scalars leaked: 1
On 6 Nov 1998 dougm@hyperreal.org wrote:
dougm> dougm 98/11/06 13:07:54
dougm>
dougm> Added: Leak Leak.pm Leak.xs Makefile.PL typemap
dougm> Log:
dougm> new module for tracking memory leaks
dougm>
dougm> Revision Changes Path
dougm> 1.1 modperl/Leak/Leak.pm
dougm>
dougm> Index: Leak.pm
dougm> ===================================================================
dougm> package Apache::Leak;
dougm>
dougm> use strict;
dougm> use DynaLoader ();
dougm> use Exporter ();
dougm> *import = \&Exporter::import;
dougm> {
dougm> no strict;
dougm> @EXPORT = qw(leak_test);
dougm> $VERSION = '1.00';
dougm> @ISA = qw(DynaLoader);
dougm> __PACKAGE__->bootstrap($VERSION);
dougm> }
dougm>
dougm> sub LOOP_N () {2}
dougm>
dougm> sub leak_test (&;$$) {
dougm> my($cv, $x, $fh) = @_;
dougm> $x ||= LOOP_N;
dougm> $fh ||= \*STDERR;
dougm> my $first = $x;
dougm>
dougm> while($x--) {
dougm> my $handle;
dougm> my $enter = NoteSV($handle);
dougm> my $leave = 0;
dougm> print $fh "ENTER: $enter SVs\n";
dougm> {
dougm> $cv->();
dougm> }
dougm> $leave = CheckSV($handle);
dougm> print $fh "\nLEAVE: $leave SVs\n";
dougm> if($enter != $leave) {
dougm> my $n = $leave - $enter;
dougm> if($x+1 == $first) {
dougm> }
dougm> else {
dougm> print $fh "!!! $n SVs leaked !!!\n";
dougm> }
dougm> }
dougm> }
dougm> }
dougm>
dougm> sub handler {
dougm> my $r = shift;
dougm> my $uri = $r->uri;
dougm> my $handle;
dougm> my $count = NoteSV($handle);
dougm> $r->push_handlers(PerlLogHandler => sub {
dougm> warn "Leak test for $uri:\n";
dougm> warn " ENTER: $count SVs\n";
dougm> $count = CheckSV($handle);
dougm> warn " LEAVE: $count SVs\n";
dougm> });
dougm> 0;
dougm> }
dougm>
dougm> 1;
dougm> __END__
dougm>
dougm> =head1 NAME
dougm>
dougm> Apache::Leak - Module for tracking memory leaks in mod_perl code
dougm>
dougm> =head1 SYNOPSIS
dougm>
dougm> use Apache::Leak;
dougm>
dougm> leak_test {
dougm> my $obj = Foo->new;
dougm> $obj->thingy;
dougm> };
dougm> #now look in error_log for results
dougm>
dougm> =head1 DESCRIPTION
dougm>
dougm> "Under Construction."
dougm>
dougm> =head1 SEE ALSO
dougm>
dougm> Devel::Leak
dougm>
dougm> =head1 AUTHOR
dougm>
dougm> Doug MacEachern
dougm> Leak.xs derived from Nick Ing-Simmons' Devel::Leak
dougm>
dougm>
dougm>
dougm> 1.1 modperl/Leak/Leak.xs
dougm>
dougm> Index: Leak.xs
dougm> ===================================================================
dougm> /*
dougm> Copyright (c) 1995,1996-1998 Nick Ing-Simmons. All rights reserved.
dougm> This program is free software; you can redistribute it and/or
dougm> modify it under the same terms as Perl itself.
dougm> */
dougm> /*
dougm> modified by dougm for use with 5.004_04
dougm> future versions may be made special for the mod_perl environment
dougm> */
dougm>
dougm> #include <EXTERN.h>
dougm> #include <perl.h>
dougm> #include <XSUB.h>
dougm>
dougm> #include "patchlevel.h"
dougm> #if ((PATCHLEVEL == 4) && (SUBVERSION <= 76))
dougm> #define PL_sv_arenaroot sv_arenaroot
dougm> #endif
dougm>
dougm> typedef long used_proc _((void *, SV *, long));
dougm> typedef struct hash_s *hash_ptr;
dougm>
dougm> #define MAX_HASH 1009
dougm>
dougm> static hash_ptr pile = NULL;
dougm>
dougm> static void
dougm> LangDumpVec(char *who, int count, SV **data)
dougm> {
dougm> int i;
dougm> PerlIO_printf(PerlIO_stderr(), "%s (%d):\n", who, count);
dougm> for (i = 0; i < count; i++)
dougm> {
dougm> SV *sv = data[i];
dougm> if (sv) {
dougm> PerlIO_printf(PerlIO_stderr(), "%2d ", i);
dougm> sv_dump(sv);
dougm> }
dougm> }
dougm> }
dougm>
dougm> struct hash_s {
dougm> struct hash_s *link;
dougm> SV *sv;
dougm> char *tag;
dougm> };
dougm>
dougm> static char *lookup(hash_ptr *ht, SV *sv, void *tag)
dougm> {
dougm> unsigned hash = ((unsigned long) sv) % MAX_HASH;
dougm> hash_ptr p = ht[hash];
dougm> while (p) {
dougm> if (p->sv == sv) {
dougm> char *old = p->tag;
dougm> p->tag = tag;
dougm> return old;
dougm> }
dougm> p = p->link;
dougm> }
dougm> if ((p = pile))
dougm> pile = p->link;
dougm> else
dougm> p = (hash_ptr) malloc(sizeof(struct hash_s));
dougm> p->link = ht[hash];
dougm> p->sv = sv;
dougm> p->tag = tag;
dougm> ht[hash] = p;
dougm> return NULL;
dougm> }
dougm>
dougm> static void check_arenas()
dougm> {
dougm> SV *sva;
dougm> for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
dougm> SV *sv = sva + 1;
dougm> SV *svend = &sva[SvREFCNT(sva)];
dougm> while (sv < svend) {
dougm> if (SvROK(sv) && ((IV) SvANY(sv)) & 1) {
dougm> warn("Odd SvANY for %p @ %p[%d]",sv,sva,(sv-sva));
dougm> abort();
dougm> }
dougm> ++sv;
dougm> }
dougm> }
dougm> }
dougm>
dougm> static long int sv_apply_to_used(void *p, used_proc *proc, long int n)
dougm> {
dougm> SV *sva;
dougm> for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
dougm> SV *sv = sva + 1;
dougm> SV *svend = &sva[SvREFCNT(sva)];
dougm>
dougm> while (sv < svend) {
dougm> if (SvTYPE(sv) != SVTYPEMASK) {
dougm> n = (*proc) (p, sv, n);
dougm> }
dougm> ++sv;
dougm> }
dougm> }
dougm> return n;
dougm> }
dougm>
dougm> static char old[] = "old";
dougm> static char new[] = "new";
dougm>
dougm> static long note_sv(void *p, SV *sv, long int n) {
dougm> lookup(p, sv, old);
dougm> return n+1;
dougm> }
dougm>
dougm> static long note_used(hash_ptr **x)
dougm> {
dougm> hash_ptr *ht;
dougm> Newz(603, ht, MAX_HASH, hash_ptr);
dougm> *x = ht;
dougm> return sv_apply_to_used(ht, note_sv, 0);
dougm> }
dougm>
dougm> static long check_sv(void *p, SV *sv, long hwm)
dougm> {
dougm> char *state = lookup(p,sv,new);
dougm> if (state != old) {
dougm> fprintf(stderr, "%s %p : ", state ? state : new, sv);
dougm> sv_dump(sv);
dougm> }
dougm> return hwm+1;
dougm> }
dougm>
dougm> static long check_used(hash_ptr **x) {
dougm> hash_ptr *ht = *x;
dougm> long count = sv_apply_to_used(ht, check_sv, 0);
dougm> long i;
dougm> for (i = 0; i < MAX_HASH; i++) {
dougm> hash_ptr p = ht[i];
dougm> while (p) {
dougm> hash_ptr t = p;
dougm> p = t->link;
dougm> if (t->tag != new) {
dougm> LangDumpVec(t->tag ? t->tag : "NUL", 1, &t->sv);
dougm> }
dougm> t->link = pile;
dougm> pile = t;
dougm> }
dougm> }
dougm> free(ht);
dougm> *x = NULL;
dougm> return count;
dougm> }
dougm>
dougm> MODULE = Apache::Leak PACKAGE = Apache::Leak
dougm>
dougm> PROTOTYPES: Enable
dougm>
dougm> IV
dougm> NoteSV(obj)
dougm> hash_ptr * obj = NO_INIT
dougm>
dougm> CODE:
dougm> RETVAL = note_used(&obj);
dougm>
dougm> OUTPUT:
dougm> obj
dougm> RETVAL
dougm>
dougm> IV
dougm> CheckSV(obj)
dougm> hash_ptr * obj
dougm>
dougm> CODE:
dougm> RETVAL = check_used(&obj);
dougm>
dougm> OUTPUT:
dougm> RETVAL
dougm>
dougm> void
dougm> check_arenas()
dougm>
dougm>
dougm>
dougm>
dougm>
dougm> 1.1 modperl/Leak/Makefile.PL
dougm>
dougm> Index: Makefile.PL
dougm> ===================================================================
dougm> use ExtUtils::MakeMaker;
dougm>
dougm> WriteMakefile(
dougm> NAME => "Apache::Leak",
dougm> VERSION_FROM => "Leak.pm",
dougm> );
dougm>
dougm>
dougm>
dougm>
dougm> 1.1 modperl/Leak/typemap
dougm>
dougm> Index: typemap
dougm> ===================================================================
dougm> hash_ptr * T_PTR
dougm>
dougm>
dougm>
dougm>
dougm>
Brian Moseley, Chief Suspect
ix@maz.org -*- http://maz.org/ -*- Evolve ICB