r41192 - in /branches/upstream/libdevel-leak-perl/current: Leak.pm Leak.xs MANIFEST MANIFEST.SKIP Makefile.PL README t/ t/basic.t typemap
ryan52-guest at users.alioth.debian.org
ryan52-guest at users.alioth.debian.org
Mon Aug 3 08:29:37 UTC 2009
Author: ryan52-guest
Date: Mon Aug 3 08:29:30 2009
New Revision: 41192
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=41192
Log:
Load /tmp/tmp.BGZqoNAsRe/to_upload/Devel-Leak-0.03 into
branches/upstream/libdevel-leak-perl/current.
Added:
branches/upstream/libdevel-leak-perl/current/Leak.pm
branches/upstream/libdevel-leak-perl/current/Leak.xs
branches/upstream/libdevel-leak-perl/current/MANIFEST
branches/upstream/libdevel-leak-perl/current/MANIFEST.SKIP
branches/upstream/libdevel-leak-perl/current/Makefile.PL
branches/upstream/libdevel-leak-perl/current/README
branches/upstream/libdevel-leak-perl/current/t/
branches/upstream/libdevel-leak-perl/current/t/basic.t
branches/upstream/libdevel-leak-perl/current/typemap
Added: branches/upstream/libdevel-leak-perl/current/Leak.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdevel-leak-perl/current/Leak.pm?rev=41192&op=file
==============================================================================
--- branches/upstream/libdevel-leak-perl/current/Leak.pm (added)
+++ branches/upstream/libdevel-leak-perl/current/Leak.pm Mon Aug 3 08:29:30 2009
@@ -1,0 +1,61 @@
+package 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 at ni-s.u-net.com>
+
+=cut
+
Added: branches/upstream/libdevel-leak-perl/current/Leak.xs
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdevel-leak-perl/current/Leak.xs?rev=41192&op=file
==============================================================================
--- branches/upstream/libdevel-leak-perl/current/Leak.xs (added)
+++ branches/upstream/libdevel-leak-perl/current/Leak.xs Mon Aug 3 08:29:30 2009
@@ -1,0 +1,218 @@
+/*
+ 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()
+
+
Added: branches/upstream/libdevel-leak-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdevel-leak-perl/current/MANIFEST?rev=41192&op=file
==============================================================================
--- branches/upstream/libdevel-leak-perl/current/MANIFEST (added)
+++ branches/upstream/libdevel-leak-perl/current/MANIFEST Mon Aug 3 08:29:30 2009
@@ -1,0 +1,8 @@
+Leak.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
Added: branches/upstream/libdevel-leak-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdevel-leak-perl/current/MANIFEST.SKIP?rev=41192&op=file
==============================================================================
--- branches/upstream/libdevel-leak-perl/current/MANIFEST.SKIP (added)
+++ branches/upstream/libdevel-leak-perl/current/MANIFEST.SKIP Mon Aug 3 08:29:30 2009
@@ -1,0 +1,4 @@
+\bblib\b
+%$
+\.(bak|old|o|c|bs|gz)$
+\b(pm_to_blib|Makefile)$
Added: branches/upstream/libdevel-leak-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdevel-leak-perl/current/Makefile.PL?rev=41192&op=file
==============================================================================
--- branches/upstream/libdevel-leak-perl/current/Makefile.PL (added)
+++ branches/upstream/libdevel-leak-perl/current/Makefile.PL Mon Aug 3 08:29:30 2009
@@ -1,0 +1,15 @@
+use 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'
+);
+
Added: branches/upstream/libdevel-leak-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdevel-leak-perl/current/README?rev=41192&op=file
==============================================================================
--- branches/upstream/libdevel-leak-perl/current/README (added)
+++ branches/upstream/libdevel-leak-perl/current/README Mon Aug 3 08:29:30 2009
@@ -1,0 +1,15 @@
+Copyright (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.
Added: branches/upstream/libdevel-leak-perl/current/t/basic.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdevel-leak-perl/current/t/basic.t?rev=41192&op=file
==============================================================================
--- branches/upstream/libdevel-leak-perl/current/t/basic.t (added)
+++ branches/upstream/libdevel-leak-perl/current/t/basic.t Mon Aug 3 08:29:30 2009
@@ -1,0 +1,16 @@
+use Test;
+plan test => 3;
+eval { require Devel::Leak };
+ok($@, "", "loading module");
+eval { import Devel::Leak };
+ok($@, "", "running import");
+ at 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");
+
Added: branches/upstream/libdevel-leak-perl/current/typemap
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libdevel-leak-perl/current/typemap?rev=41192&op=file
==============================================================================
--- branches/upstream/libdevel-leak-perl/current/typemap (added)
+++ branches/upstream/libdevel-leak-perl/current/typemap Mon Aug 3 08:29:30 2009
@@ -1,0 +1,2 @@
+hash_ptr * T_PTR
+
More information about the Pkg-perl-cvs-commits
mailing list