File Coverage

blib/lib/POE/Callback.pm

Criterion	Covered	Total	%
statement	125	143	87.4
branch	55	76	72.3
condition	2	2	100.0
subroutine	13	13	100.0
pod	1	1	100.0
total	196	235	83.4

# $Id: Callback.pm 184 2009-06-11 06:44:27Z rcaputo $

=head1 NAME

POE::Callback - object wrapper for callbacks with lexical closures

=head1 SYNOPSIS

	# TODO - Make this a complete working example.
	my $callback = POE::Callback->new(
		name => "Pkg::sub",
		code => \&coderef,
	);
	$callback->(@arguments);

=head1 DESCRIPTION

POE::Callback wraps coderefs in magic that makes certain lexical
variables persistent between calls.

It's used internally by the classes that comprise POE::Stage.

=cut

package POE::Callback;

use warnings;
use strict;

use PadWalker qw(var_name peek_my peek_sub);
use Scalar::Util qw(blessed reftype weaken);
use Devel::LexAlias qw(lexalias);
use Carp qw(croak);

# Track our wrappers to avoid wrapping them.  Otherwise hilarity may
# ensue.

my %callbacks;
use constant CB_SELF => 0;
use constant CB_NAME => 1;

=head2 new CODEREF

Creates a new callback from a raw CODEREF.  Returns the callback,
which is just the CODEREF blessed into POE::Callback.

=cut

sub new {
	my ($class, $arg) = @_;

	foreach my $required (qw(name code)) {
		croak "POE::Callback requires a '$required'" unless $arg->{$required};
	}

	my $code = $arg->{code};
	my $name = $arg->{name};

	# Don't wrap callbacks.
	return $code if exists $callbacks{$code};

	# Gather the names of persistent variables.
	my $pad = peek_sub($code);
	my @persistent = grep {
		/^\$(self|req|rsp)$/ || /^([\$\@\%])(req|rsp|arg|self)_(\S+)/
	} keys %$pad;

	# No point in the wrapper if there are no persistent variables.

	unless (@persistent) {
		my $self = bless $code, $class;
		return $self->_track($name);
	}

	my $b_self = '';        # build $self
	my $b_rsp = '';         # build $rsp
	my $b_req = '';         # build $req
	my $b_arg = '';         # build $arg
	my $b_req_id = '';      # build $req->get_id()
	my $b_rsp_id = '';      # build $rsp->get_id()

	my $a_self = '';
	my $a_rsp = '';
	my $a_req = '';

	my @vars;

	foreach my $var_name (@persistent) {
		if ($var_name eq '_b_self') {
			$b_self = q{  my $self = POE::Stage::self();};
			next;
		}

		if ($var_name eq '_b_req') {
			push @persistent, '$self' unless $b_self;
			$b_req = q{  my $req = $self->_get_request();};
		}

		if ($var_name eq '_b_rsp') {
			push @persistent, '$self' unless $b_self;
			$b_rsp = q{  my $rsp = $self->_get_response(); };
		}

		if ($var_name eq '$self') {
			push @persistent, '_b_self' unless $b_self;
			$a_self = q{  lexalias($code, '$self', \$self);};
			next;
		}

		if ($var_name eq '_b_rsp_id') {
			push @persistent, '_b_rsp' unless $b_rsp;
			$b_rsp_id = q{  my $rsp_id = $rsp->get_id();};
			next;
		}

		if ($var_name eq '_b_req_id') {
			push @persistent, '_b_req' unless $b_req;
			$b_req_id = q{  my $req_id = $req->get_id();};
			next;
		}

		if ($var_name eq '$req') {
			push @persistent, '_b_req' unless $b_req;
			$a_req = q{  lexalias($code, '$req', \$req);};
			next;
		}

		if ($var_name eq '$rsp') {
			push @persistent, '_b_rsp' unless $b_rsp;
			$a_rsp = q{lexalias($code, '$rsp', \$rsp);};
			next;
		}

		next unless $var_name =~ /^([\$\@\%])(req|rsp|arg|self)_(\S+)/;

		my ($sigil, $prefix, $base_member_name) = ($1, $2, $3);
		my $member_name = $sigil . $base_member_name;

		# Arguments don't need vivification, so they come before @vivify.

		if ($prefix eq 'arg') {
			$b_arg ||= (
				q/  my $arg; { package DB; my @x = caller(0); $arg = $DB::args[1]; }/
			);

			my $def = (
				qq/  \$var_reference = \$pad->{'$var_name'};/
			);

			if ($sigil eq '$') {
				push @vars, (
					$def,
					qq/  \$\$var_reference = \$arg->{'$base_member_name'};/
				);
				next;
			}

			if ($sigil eq '@') {
				push @vars, (
					$def,
					qq/  \@\$var_reference = \@{\$arg->{'$base_member_name'}};/
				);
				next;
			}

			if ($sigil eq '%') {
				push @vars, (
					$def,
					qq/  \%\$var_reference = \%{\$arg->{'$base_member_name'}};/
				);
				next;
			}
		}

		# Common vivification code.

		my @vivify = ( q/  unless( defined $member_ref ) {/ );
		if ($sigil eq '$') {
			push @vivify, q(    my $new_scalar; $member_ref = \$new_scalar;);
		}
		elsif ($sigil eq '@') {
			push @vivify, q(    $member_ref = [];);
		}
		elsif ($sigil eq '%') {
			push @vivify, q(    $member_ref = {};);
		}

		# Determine which object to use based on the prefix.

		my $obj;
		if ($prefix eq 'req') {
			push @persistent, '_b_req_id' unless $b_req;

			# Get the existing member reference.
			push @vars, (
				q{  $member_ref = } .
				q{$self->_request_context_fetch(} .
				qq{\$req_id, '$member_name');}
			);

			# Autovivify if necessary.
			push @vars, (
				@vivify,
				q{    $self->_request_context_store(} .
				qq{\$req_id, '$member_name', \$member_ref);},
				q(  }),
				# Alias the member.
				qq{  lexalias(\$code, '$var_name', \$member_ref);}
			);
			next;
		}

		if ($prefix eq 'rsp') {
			push @persistent, '_b_rsp_id' unless $b_rsp;
			push @persistent, '$self' unless $b_self;

			# Get the existing member reference.
			push @vars, (
				q{  $member_ref = } .
				q{$self->_request_context_fetch(}.
				qq{\$rsp_id, '$member_name');}
			);

			# Autovivify if necessary.
			push @vars, (
				@vivify,
				q{    $self->_request_context_store(} .
				qq{    \$rsp_id, '$member_name', \$member_ref);},
				qq(  \}),
				# Alias the member.
				qq{  lexalias(\$code, '$var_name', \$member_ref);}
			);
			next;
		}

		if ($prefix eq 'self') {
			push @persistent, '$self' unless $b_self;

			# Get the existing member reference.
			push @vars, (
				qq{\$member_ref = \$self->_self_fetch('$member_name');}
			);

			# Autovivify if necessary.
			push @vars, (
				@vivify,
				qq{    \$self->_self_store('$member_name', \$member_ref);},
				qq(  \}),
				# Alias the member.
				qq{  lexalias(\$code, '$var_name', \$member_ref);}
			);

			next;
		}
	}

	unshift @vars, (
		$b_self, $b_arg, $b_req, $b_rsp, $b_req_id, $b_rsp_id,
		$a_self, $a_rsp, $a_req,
	);

	my $sub = join "\n", (
		"sub {",
		"  my \$pad = peek_sub(\$code);",
		"  my (\$member_ref, \$var_reference);",
		@vars,
		"  goto \$code;",
		"};"
	);
	#warn $sub; # for debugging generated code
	my $coderef = eval $sub;
	if( $@ ) {
		while( $@ =~ /line (\d+)/g ) {
			my $line = $1;
			for( ($line-10) .. $line-4 ) {
				warn $_+4, ": $vars[$_]\n";
			}
		}
		die $@;
	}

	my $self = bless $coderef, $class;
	return $self->_track($name);
}

# Track a callback so we don't accidentally wrap it.

sub _track {
	my ($self, $name) = @_;
	$callbacks{$self} = [
		$self,  # CB_SELF
		$name,  # CB_NAME
	];
	weaken($callbacks{$self}[CB_SELF]);
	return $self;
}

# When the callback object is destroyed, it's also removed from the
# tracking hash.

sub DESTROY {
	my $self = shift;
	warn "!!! Destroying untracked callback $self" unless (
		exists $callbacks{$self}
	);
	delete $callbacks{$self};
}

# End-of-run leak checking.

END {
	my @leaks;
	foreach my $callback (sort keys %callbacks) {
		no strict 'refs';
		my $cb_name = $callbacks{$callback}[CB_NAME];
		next if *{$cb_name}{CODE} == $callbacks{$callback}[CB_SELF];
		push @leaks, "!!!   $callback = $cb_name\n";
	}
	if (@leaks) {
		warn "\n!!! callback leak:";
		warn @leaks;
	}
}

1;