package POE::Component::Generic::Child;
# $Id: Child.pm 759 2011-05-18 16:55:01Z fil $
# This is the object that does all the work in the child process
use strict;
use Symbol;
use Carp;
##################################################
# Called from Generic::process_requests
sub new
{
my( $package, %params ) = @_;
my $self = bless { %params }, $package;
$self->{filter} = POE::Filter::Reference->new();
# there's room for other callbacks
$self->{callback_defs} = {};
# sub-objects
$self->{objects} = {};
$params{ID} =~ s/[^A-Za-z]+/A/g;
$self->{object_id} = "$params{ID}OBJ000000";
$self->init_handles;
return $self;
}
##################################################
# Setup handles we want to play with
sub init_handles
{
my( $self ) = @_;
my $myout = $self->{myout} = gensym;
# Redirect STDOUT to STDERR, so that badly behaved user code doesn't
# mess up our communication with the parent
open $myout, ">&STDOUT" or die "Can't dup STDOUT: $!\n";
open STDOUT, ">&STDERR" or die "Can't dup STDERR: $!\n";
# binmode so that Storable refs can make it across
binmode(STDIN);
binmode(STDOUT);
binmode($myout);
# No buffers for us
STDOUT->autoflush(1);
$myout->autoflush(1);
}
##################################################
# Main loop.
# When this method exits, the child will exit.
sub loop
{
my( $self ) = @_;
$self->status( 'startup' );
READ:
while ( my $requests = $self->get_requests ) {
$self->status( 'request' );
unless ($self->{obj}) {
my $req = shift @{$requests};
unless( ref( $req ) eq 'HASH' and $req->{req} eq 'setup' ) {
die "First request must be req=>setup";
}
# use Data::Denter;
# warn "setup=", Denter $req;
$self->OOB_req( $req );
}
foreach my $req (@{$requests}) {
# use Data::Denter;
# warn "req=", Denter $req;
if( $req->{req} ) {
$self->OOB_req( $req );
}
else {
$self->request( $req );
}
}
$self->status( 'read' );
}
$self->status( 'exit' );
}
##################################################
# Get the next block of requests
# Return :
# undef() - shutdown child
# arrayref of request hashes
sub get_requests
{
my( $self ) = @_;
my $raw;
return unless sysread ( STDIN, $raw, $self->{size} );
return $self->{filter}->get([$raw]);
}
##################################################
# Update our status
sub status
{
my $self = shift;
$self->{debug} and warn join ' ', @_, "\n";
$0 = join ' ', $self->{proc}, $self->{name}, @_;
return;
}
##################################################
# Send a response to the parent
sub reply
{
my( $self, $resp ) = @_;
$self->status( 'reply' );
# use Data::Denter;
# warn "reply=", Denter $resp;
my $replies = $self->{filter}->put( [ $resp ] );
my $rv = $self->{myout}->print( join '', @$replies );
die "STDOUT: $!" unless $rv;
}
##################################################
# Handle a regular request from the parent
sub request
{
my( $self, $req ) = @_;
my $method = $req->{method};
$self->{debug} and warn "method=$method";
if( $req->{callbacks} ) {
$self->callback_demarshall( $req, $req->{callbacks} );
}
if( $req->{postbacks} ) {
$self->postback_demarshall( $req, $req->{postbacks} );
}
# The object we want to work on
my $obj = $self->{obj};
if( $req->{obj} ) {
$obj = $self->{objects}{ $req->{obj} };
unless( $obj ) {
$req->{error} = "Unknown object $req->{obj}";
$self->{debug} and warn $req->{error};
$self->reply( $req );
return;
}
if( $method eq 'DESTROY' ) { # special case
$self->{debug} and warn "DESTROY for object $req->{obj}";
delete $self->{objects}{ $req->{obj} };
# Generic::Object requires DESTROY getting this far.
# However, if the object can't really handle it, skip out now
return unless $obj->can( $method );
delete $req->{wantarray}; # never
delete $req->{event}; # ever
}
}
# keeping {args} in req messes up callbacks
my $args = delete $req->{args};
eval {
$self->{debug} and do {
if( $req->{factory} ) {
warn "Calling factory $method on $obj";
}
else {
warn "Calling $method on $obj";
}
};
if( $req->{wantarray} ) {
$req->{result} = [ $obj->$method( @$args ) ];
}
elsif( defined $req->{wantarray} or $req->{factory} ) {
$req->{result} = [ scalar $obj->$method( @$args ) ];
}
elsif( $method eq 'DESTROY' and not $obj->can( $method ) ) {
# DESTROY is dispacted from Generic::DESTROY. $obj might not
# implement it. If it doesn't, we don't want the error produced
# by blindly calling it.
}
else {
$obj->$method( @$args );
}
};
if ($@) {
$self->{debug} and warn $@;
$req->{error} = $@;
delete $req->{result};
}
#############
if( $req->{factory} ) {
$self->factory_response( $req );
}
#############
if( defined $req->{event} ) {
$self->reply( $req );
}
elsif( $req->{error} ) {
warn $req->{error};
}
}
##################################################
# Convert callbacks into coderefs
sub callback_demarshall
{
my( $self, $req, $cdef ) = @_;
foreach my $cb ( @$cdef ) {
unless( $req->{args}[ $cb->{pos} ] eq $cb->{CBid} ) {
die "Argument at position $cb->{pos} isn't $cb->{CBid}";
}
$req->{args}[ $cb->{pos} ] = sub {
$self->reply( {
response => 'callback',
RID => $req->{RID},
pos => $cb->{pos},
result => [ @_ ]
} );
};
}
}
##################################################
# Convert postbacks into a coderef
sub postback_demarshall
{
my( $self, $req, $pdef ) = @_;
foreach my $pb ( @$pdef ) {
unless( $req->{args}[ $pb->{pos} ] eq $pb->{PBid} ) {
die "Argument at position $pb->{pos} isn't $pb->{PBid}";
}
my $PBid = $pb->{PBid};
my $session = $pb->{session};
my $event = $pb->{event};
$req->{args}[ $pb->{pos} ] = sub {
$self->reply( {
response => 'postback',
PBid => $PBid,
session => $session,
event => $event,
result => [ @_ ]
} );
};
}
}
##################################################
# Modify the response from a factory method
sub factory_response
{
my( $self, $req ) = @_;
my $OBJid = $self->{object_id}++;
$self->{objects}{ $OBJid } = $req->{result}[0];
my $package = ref $self->{objects}{ $OBJid };
Carp::confess "Didn't return an object for $OBJid" unless $req->{result}[0];
$self->{debug} and
warn "factory_response package=$package $OBJid=$self->{objects}{ $OBJid }";
$req->{result}[0] = {
package => $package,
debug => $self->{debug},
methods => [ POE::Component::Generic->__package_methods( $package )
],
OBJid => $OBJid
};
}
##################################################
# Out-of-band request
sub OOB_req
{
my( $self, $req ) = @_;
$self->status( 'OOB' );
my $method = $req->{req};
if( $method eq 'setup' ) {
$self->OOB_setup( $req );
}
else {
warn "Unknown OOB request $method";
}
}
##################################################
# First request from parent
# Create the object, configure the child process
sub OOB_setup
{
my( $self, $req ) = @_;
foreach my $f ( qw( name size debug verbose ) ) {
next unless exists $req->{$f};
$self->{$f} = $req->{$f};
$self->{debug} and warn "Setting $f=$self->{$f}";
}
$self->{debug} and warn "build object $req->{package}";
$self->{obj} = object_build( $req->{package}, $req->{args} );
$self->{debug} and warn "Child PID is $$\n";
$self->{debug} and
warn "object=$self->{obj}";
$self->reply( { PID=>$$, response=>'new' } );
}
##################################################
# Create an object of a given class
sub object_build
{
my( $package, $args ) = @_;
my $ctor = package_load( $package );
die "Can't find constructor for package $package" unless $ctor;
return $package->can($ctor)->( $package, @$args );
}
##################################################
# Load the user package. Also used by PoCo::Generic
sub package_load
{
my( $package ) = @_;
my $ctor = find_ctor( $package );
return $ctor if $ctor; # package already loaded
eval "use $package";
die $@ if $@;
return find_ctor( $package );
}
##################################################
# Find an object constructor.
sub find_ctor
{
my( $package ) = @_;
foreach my $ctor ( qw( new spawn create ) ) {
return $ctor if $package->can( $ctor );
}
return;
}
1;
__END__
=head1 NAME
POE::Component::Generic::Child - Child process handling
=head1 SYNOPSIS
# Do not use POE::Component::Generic::Child directly.
# Let POE::Component::Generic do it for you
=head1 DESCRIPTION
POE::Component::Generic::Child handles the child process for
L<POE::Component::Generic>.
You might want to sub-class it if you want advanced interaction with your
object.
It is currently undocumented. Consult the source code.
=head1 AUTHOR
Philip Gwyn E<lt>gwyn-at-cpan.orgE<gt>
Based on work by David Davis E<lt>xantus@cpan.orgE<gt>
=head1 SEE ALSO
L<POE>, L<POE::Component::Generic>.
=head1 RATING
Please rate this module.
L<http://cpanratings.perl.org/rate/?distribution=POE-Component-Generic>
=head1 BUGS
Probably. Report them here:
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=POE%3A%3AComponent%3A%3AGeneric>
=head1 COPYRIGHT AND LICENSE
Copyright 2006-2008,2011 by Philip Gwyn;
Copyright 2005 by David Davis and Teknikill Software.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut