view release on metacpan or  search on metacpan

lib/POE/Callback.pm  view on Meta::CPAN

# $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();};