1# $Id: Callback.pm 184 2009-06-11 06:44:27Z rcaputo $
2
3=head1 NAME
4
5POE::Callback - object wrapper for callbacks with lexical closures
6
7=head1 SYNOPSIS
8
9	# TODO - Make this a complete working example.
10	my $callback = POE::Callback->new(
11		name => "Pkg::sub",
12		code => \&coderef,
13	);
14	$callback->(@arguments);
15
16=head1 DESCRIPTION
17
18POE::Callback wraps coderefs in magic that makes certain lexical
19variables persistent between calls.
20
21It's used internally by the classes that comprise POE::Stage.
22
23=cut
24
25package POE::Callback;
26
27use warnings;
28use strict;
29
30use PadWalker qw(var_name peek_my peek_sub);
31use Scalar::Util qw(blessed reftype weaken);
32use Devel::LexAlias qw(lexalias);
33use Carp qw(croak);
34
35# Track our wrappers to avoid wrapping them.  Otherwise hilarity may
36# ensue.
37
38my %callbacks;
39use constant CB_SELF => 0;
40use constant CB_NAME => 1;
41
42=head2 new CODEREF
43
44Creates a new callback from a raw CODEREF.  Returns the callback,
45which is just the CODEREF blessed into POE::Callback.
46
47=cut
48
49sub new {
50	my ($class, $arg) = @_;
51
52	foreach my $required (qw(name code)) {
53		croak "POE::Callback requires a '$required'" unless $arg->{$required};
54	}
55
56	my $code = $arg->{code};
57	my $name = $arg->{name};
58
59	# Don't wrap callbacks.
60	return $code if exists $callbacks{$code};
61
62	# Gather the names of persistent variables.
63	my $pad = peek_sub($code);
64	my @persistent = grep {
65		/^\$(self|req|rsp)$/ || /^([\$\@\%])(req|rsp|arg|self)_(\S+)/
66	} keys %$pad;
67
68	# No point in the wrapper if there are no persistent variables.
69
70	unless (@persistent) {
71		my $self = bless $code, $class;
72		return $self->_track($name);
73	}
74
75	my $b_self = '';        # build $self
76	my $b_rsp = '';         # build $rsp
77	my $b_req = '';         # build $req
78	my $b_arg = '';         # build $arg
79	my $b_req_id = '';      # build $req->get_id()
80	my $b_rsp_id = '';      # build $rsp->get_id()
81
82	my $a_self = '';
83	my $a_rsp = '';
84	my $a_req = '';
85
86	my @vars;
87
88	foreach my $var_name (@persistent) {
89		if ($var_name eq '_b_self') {
90			$b_self = q{  my $self = POE::Stage::self();};
91			next;
92		}
93
94		if ($var_name eq '_b_req') {
95			push @persistent, '$self' unless $b_self;
96			$b_req = q{  my $req = $self->_get_request();};
97		}
98
99		if ($var_name eq '_b_rsp') {
100			push @persistent, '$self' unless $b_self;
101			$b_rsp = q{  my $rsp = $self->_get_response(); };
102		}
103
104		if ($var_name eq '$self') {
105			push @persistent, '_b_self' unless $b_self;
106			$a_self = q{  lexalias($code, '$self', \$self);};
107			next;
108		}
109
110		if ($var_name eq '_b_rsp_id') {
111			push @persistent, '_b_rsp' unless $b_rsp;
112			$b_rsp_id = q{  my $rsp_id = $rsp->get_id();};
113			next;
114		}
115
116		if ($var_name eq '_b_req_id') {
117			push @persistent, '_b_req' unless $b_req;
118			$b_req_id = q{  my $req_id = $req->get_id();};
119			next;
120		}
121
122		if ($var_name eq '$req') {
123			push @persistent, '_b_req' unless $b_req;
124			$a_req = q{  lexalias($code, '$req', \$req);};
125			next;
126		}
127
128		if ($var_name eq '$rsp') {
129			push @persistent, '_b_rsp' unless $b_rsp;
130			$a_rsp = q{lexalias($code, '$rsp', \$rsp);};
131			next;
132		}
133
134		next unless $var_name =~ /^([\$\@\%])(req|rsp|arg|self)_(\S+)/;
135
136		my ($sigil, $prefix, $base_member_name) = ($1, $2, $3);
137		my $member_name = $sigil . $base_member_name;
138
139		# Arguments don't need vivification, so they come before @vivify.
140
141		if ($prefix eq 'arg') {
142			$b_arg ||= (
143				q/  my $arg; { package DB; my @x = caller(0); $arg = $DB::args[1]; }/
144			);
145
146			my $def = (
147				qq/  \$var_reference = \$pad->{'$var_name'};/
148			);
149
150			if ($sigil eq '$') {
151				push @vars, (
152					$def,
153					qq/  \$\$var_reference = \$arg->{'$base_member_name'};/
154				);
155				next;
156			}
157
158			if ($sigil eq '@') {
159				push @vars, (
160					$def,
161					qq/  \@\$var_reference = \@{\$arg->{'$base_member_name'}};/
162				);
163				next;
164			}
165
166			if ($sigil eq '%') {
167				push @vars, (
168					$def,
169					qq/  \%\$var_reference = \%{\$arg->{'$base_member_name'}};/
170				);
171				next;
172			}
173		}
174
175		# Common vivification code.
176
177		my @vivify = ( q/  unless( defined $member_ref ) {/ );
178		if ($sigil eq '$') {
179			push @vivify, q(    my $new_scalar; $member_ref = \$new_scalar;);
180		}
181		elsif ($sigil eq '@') {
182			push @vivify, q(    $member_ref = [];);
183		}
184		elsif ($sigil eq '%') {
185			push @vivify, q(    $member_ref = {};);
186		}
187
188		# Determine which object to use based on the prefix.
189
190		my $obj;
191		if ($prefix eq 'req') {
192			push @persistent, '_b_req_id' unless $b_req;
193
194			# Get the existing member reference.
195			push @vars, (
196				q{  $member_ref = } .
197				q{$self->_request_context_fetch(} .
198				qq{\$req_id, '$member_name');}
199			);
200
201			# Autovivify if necessary.
202			push @vars, (
203				@vivify,
204				q{    $self->_request_context_store(} .
205				qq{\$req_id, '$member_name', \$member_ref);},
206				q(  }),
207				# Alias the member.
208				qq{  lexalias(\$code, '$var_name', \$member_ref);}
209			);
210			next;
211		}
212
213		if ($prefix eq 'rsp') {
214			push @persistent, '_b_rsp_id' unless $b_rsp;
215			push @persistent, '$self' unless $b_self;
216
217			# Get the existing member reference.
218			push @vars, (
219				q{  $member_ref = } .
220				q{$self->_request_context_fetch(}.
221				qq{\$rsp_id, '$member_name');}
222			);
223
224			# Autovivify if necessary.
225			push @vars, (
226				@vivify,
227				q{    $self->_request_context_store(} .
228				qq{    \$rsp_id, '$member_name', \$member_ref);},
229				qq(  \}),
230				# Alias the member.
231				qq{  lexalias(\$code, '$var_name', \$member_ref);}
232			);
233			next;
234		}
235
236		if ($prefix eq 'self') {
237			push @persistent, '$self' unless $b_self;
238
239			# Get the existing member reference.
240			push @vars, (
241				qq{\$member_ref = \$self->_self_fetch('$member_name');}
242			);
243
244			# Autovivify if necessary.
245			push @vars, (
246				@vivify,
247				qq{    \$self->_self_store('$member_name', \$member_ref);},
248				qq(  \}),
249				# Alias the member.
250				qq{  lexalias(\$code, '$var_name', \$member_ref);}
251			);
252
253			next;
254		}
255	}
256
257	unshift @vars, (
258		$b_self, $b_arg, $b_req, $b_rsp, $b_req_id, $b_rsp_id,
259		$a_self, $a_rsp, $a_req,
260	);
261
262	my $sub = join "\n", (
263		"sub {",
264		"  my \$pad = peek_sub(\$code);",
265		"  my (\$member_ref, \$var_reference);",
266		@vars,
267		"  goto \$code;",
268		"};"
269	);
270	#warn $sub; # for debugging generated code
271	my $coderef = eval $sub;
272	if( $@ ) {
273		while( $@ =~ /line (\d+)/g ) {
274			my $line = $1;
275			for( ($line-10) .. $line-4 ) {
276				warn $_+4, ": $vars[$_]\n";
277			}
278		}
279		die $@;
280	}
281
282	my $self = bless $coderef, $class;
283	return $self->_track($name);
284}
285
286# Track a callback so we don't accidentally wrap it.
287
288sub _track {
289	my ($self, $name) = @_;
290	$callbacks{$self} = [
291		$self,  # CB_SELF
292		$name,  # CB_NAME
293	];
294	weaken($callbacks{$self}[CB_SELF]);
295	return $self;
296}
297
298# When the callback object is destroyed, it's also removed from the
299# tracking hash.
300
301sub DESTROY {
302	my $self = shift;
303	warn "!!! Destroying untracked callback $self" unless (
304		exists $callbacks{$self}
305	);
306	delete $callbacks{$self};
307}
308
309# End-of-run leak checking.
310
311END {
312	my @leaks;
313	foreach my $callback (sort keys %callbacks) {
314		no strict 'refs';
315		my $cb_name = $callbacks{$callback}[CB_NAME];
316		next if *{$cb_name}{CODE} == $callbacks{$callback}[CB_SELF];
317		push @leaks, "!!!   $callback = $cb_name\n";
318	}
319	if (@leaks) {
320		warn "\n!!! callback leak:";
321		warn @leaks;
322	}
323}
324
3251;
326