# A thread-safe inside-out object class
package SafeObject;
use strict;
use warnings;
use Scalar::Util qw( refaddr weaken );

our $VERSION = 0.001;

# Global object tracking and constructor

my %REGISTRY;

# Object property storage and accessor

my %NAME;

sub name {
    my ($self, $value) = @_;
    
    # store a value if one is provided
    my $id = refaddr $self;
    if ( defined $value ) { $NAME{ $id } = $value; }
    
    return $NAME{ $id };
}

# Constructor and destructor 

sub new { 
    my $class = shift;
    my $self = bless {}, $class;

    # store a weak reference in the registry
    my $id = refaddr $self;
    weaken ( $REGISTRY{ $id } = $self );
    
    return $self;
}

sub DESTROY {
    my $self = shift;
    my $id = refaddr $self;
    
    # clean up memory used for the object
    delete $NAME{ $id };
    delete $REGISTRY{ $id };

    return;
}

# Cloning routine called for new threads

sub CLONE {
    # So we can see this called in a Windows fork()
    warn "# Notice: Cloning data in new thread\n";
    
    # fix-up all object ids in the new thread
    # (note: %REGISTRY change in the middle, so don't use "each")
    for my $old_id ( keys %REGISTRY ) {  
        
        # look under old_id to find the new, cloned reference
        my $object = $REGISTRY{ $old_id };
        my $new_id = refaddr $object;

        # relocate data
        $NAME{ $new_id } = $NAME{ $old_id };
        delete $NAME{ $old_id };

        # update the weak reference to the new, cloned object
        weaken ( $REGISTRY{ $new_id } = $REGISTRY{ $old_id } );
        delete $REGISTRY{ $old_id };
    }
    
    return;
}

1; # package must return true

##</code><code>##

#!/usr/bin/perl
use strict;
use warnings;
use 5.008; # CLONE only supported in Perl > 5.8

use threads;
use Test::More tests => 7;

require_ok( "SafeObject" );

my $safe_obj = SafeObject->new;
isa_ok( $safe_obj, "SafeObject" );

is( $safe_obj->name( "Charlie" ), "Charlie", "mutator returns value"  );
is( $safe_obj->name()           , "Charlie", "accessor returns value" );

my $thr = threads->new( 
    sub { 
        is( $safe_obj->name(        ), "Charlie", "got right name in thread");
        is( $safe_obj->name( "Fred" ), "Fred"   , "changed name in thread"  );
    } 
);
$thr->join;
is( $safe_obj->name(), "Charlie", "main thread still has original name" );

##</code><code>##

#!/usr/bin/perl
use strict;
use warnings;
use 5.008; # CLONE only supported in Perl > 5.8

use Test::More tests => 7;

require_ok( "SafeObject" );

my $obj = SafeObject->new;
isa_ok( $obj, "SafeObject" );

is( $obj->name( "Charlie" ), "Charlie", "mutator returns value"  );
is( $obj->name()           , "Charlie", "accessor returns value" );

my $child_pid = fork;
if ( !$child_pid ) { # we're in the child
        is( $obj->name(        ), "Charlie", "got right name in child");
        is( $obj->name( "Fred" ), "Fred"   , "changed name in child"  );
        exit;
}

# wait for child to finish
waitpid $child_pid, 0;

# Test counter is off due to the fork
Test::More->builder->current_test( 6 );

is( $obj->name(), "Charlie", "parent still has original name" );