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