view release on metacpan or  search on metacpan

lib/Devel/Leak/Cb.pm  view on Meta::CPAN

package Devel::Leak::Cb;

use 5.008008;
use common::sense;
m{
use strict;
use warnings;
}x;
=head1 NAME

Devel::Leak::Cb - Detect leaked callbacks

=head1 VERSION

Version 0.04

=cut

our $VERSION = '0.04';

=head1 SYNOPSIS

    use Devel::Leak::Cb;
    
    AnyEvent->timer( after => 1, cb => cb {
        ...
    });
    
    # If $ENV{DEBUG_CB} is true and callback not destroyed till END, the you'll be noticed

=head1 DESCRIPTION

By default, cb { .. } will be rewritten as sub { .. } using L<Devel::Declare> and will give no additional cost at runtime

When C<$ENV{DEBUG_CB}> will be set, then all cb {} declarations will be counted, and if some of them will not be destroyed till the END stage, you'll be warned

=head1 EXPORT

Exports a single function: cb {}, which would be rewritten as sub {} when C<$ENV{DEBUG_CB}> is not in effect

If C<DEBUG_CB> > 1 and L<Devel::FindRef> is installed, then output will include reference tree of leaked callbacks

=head1 FUNCTIONS

=head2 cb {}

Create anonymous callback

	my $cb = cb {};

=head2 cb name {}

Create named callback with static name (Have no effect without C<$ENV{DEBUG_CB}>)

	my $cb = cb mycallback {};

=head2 cb $name {}

Create named callback with dynamic name (Have no effect without C<$ENV{DEBUG_CB}>)
$name could me only simple scalar identifier, without any special symbols

	my $cb = cb $name {};
	my $cb = cb $full::name {};

=head2 cb 'name' {}

Create named callback with dynamic name (Have no effect without C<$ENV{DEBUG_CB}>)
Currently supported only ' and ". Quote-like operators support will be later

	my $cb = cb 'name' {};
	my $cb = cb "name.$val" {};

=head2 COUNT

	You may call C<Devel::Leak::Cb::COUNT()> Manually to check state. All leaked callbacks will be warned. Noop without C<$ENV{DEBUG_CB}>

=cut

use Devel::Declare ();
use Scalar::Util 'weaken';

our @CARP_NOT = qw(Devel::Declare);
our %DEF;

BEGIN {
	if ($ENV{DEBUG_CB}) {
		my $debug = $ENV{DEBUG_CB};
		*DEBUG = sub () { $debug };
	} else {
		*DEBUG = sub () { 0 };
	}
}


BEGIN {
	if (DEBUG){
		eval { require Sub::Identify;   Sub::Identify->import('sub_fullname'); 1 } or *sub_fullname = sub { return };
		eval { require Sub::Name;       Sub::Name->import('subname');          1 } or *subname      = sub { $_[1] };
		eval { require Devel::Refcount; Devel::Refcount->import('refcount');   1 } or *refcount     = sub { -1 };
		*COUNT = sub () {
			for (keys %DEF) {
				my $d = delete $DEF{$_};
				#print STDERR "Counting $_ [ @$d ]";
				$d->[0] or next;
				my $name = $d->[4] ? $d->[1].'::cb.'.$d->[4] : sub_fullname($d->[0]) || $d->[1].'::cb.__ANON__';
				substr($name,-10) eq '::__ANON__' and substr($name,-10) = '::cb.__ANON__';
				warn "Leaked: $name (refs:".refcount($d->[0]).") defined at $d->[2] line $d->[3]\n".(DEBUG > 1 ? findref($d->[0]) : '' );
			}
		};
	} else {
		*COUNT = sub () {};
	}
	if (DEBUG>1) {
		eval { require Devel::FindRef;  *findref = \&Devel::FindRef::track; 1 } or *findref  = sub { "No Devel::FindRef installed\n" };
	}
}

sub import{
	my $class = shift;
	my $caller = caller;
	Devel::Declare->setup_for(
		$caller,
		{ 'cb' => { const => \&parse } }
	);
	{
		no strict 'refs';
		*{$caller.'::cb' } = sub() { 1 };
	}
}

sub __cb__::DESTROY {
	#print STDERR "destroy $_[0]\n";
	delete($DEF{int $_[0]});
};