File Coverage

blib/lib/Object/ForkAware.pm

Criterion	Covered	Total	%
statement	40	40	100.0
branch	23	24	95.8
condition	8	14	57.1
subroutine	10	11	90.9
pod	1	4	25.0
total	82	93	88.1

use strict;
use warnings;
package Object::ForkAware; # git description: v0.003-22-g1de42b4
# vim: set ts=8 sts=4 sw=4 tw=115 et :
# ABSTRACT: Make an object aware of process forks and threads, recreating itself as needed
# KEYWORDS: process thread fork multiprocessing multithreading clone

our $VERSION = '0.004';

use Scalar::Util ();

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

    my $self = {};
    $self->{_create} = $opts{create} or die 'missing required option: create';
    $self->{_on_fork} = $opts{on_fork} if exists $opts{on_fork};

    $self = bless($self, $class);

    $self->_create_obj($self->{_create}) if not $opts{lazy};

    return $self;
}

sub _create_obj
{
    my ($self, $sub) = @_;

    my $obj = $sub->( defined $self->{_obj} ? $self->{_obj} : () );
    $self->{_pid} = $$;
    $self->{_tid} = threads->tid if $INC{'threads.pm'};
    $self->{_obj} = $obj;
}

sub _get_obj
{
    my $self = shift;

    return if not Scalar::Util::blessed($self);
    if (not defined $self->{_pid}
        or $$ != $self->{_pid}
        or $INC{'threads.pm'} and ($self->{_tid} || 0) != threads->tid)
    {
        $self->_create_obj($self->{_on_fork} || $self->{_create});
    }

    return $self->{_obj};
}

sub isa
{
    my ($self, $class) = @_;
    $self->SUPER::isa($class) || do {
        my $obj = $self->_get_obj;
        $obj && $obj->isa($class);
    };
}

sub can
{
    my ($self, $method) = @_;
    $self->SUPER::can($method) || do {
        my $obj = $self->_get_obj;
        $obj && $obj->can($method);
    };
}

sub VERSION
{
    my ($self, @args) = @_;

    my $obj = $self->_get_obj;
    return $obj
        ? $obj->VERSION(@args)
        : $self->SUPER::VERSION(@args);
}

our $AUTOLOAD;
sub AUTOLOAD
{
    my $self = shift;

    # Remove qualifier from original method name...
    (my $called = $AUTOLOAD) =~ s/.*:://;
    return $self->_get_obj->$called(@_);
}

sub DESTROY {}  # avoid calling AUTOLOAD at destruction time

1;

__END__