use strict;
use warnings;
-our $VERSION = '1.19';
+use Scalar::Util qw(reftype refaddr blessed);
+
+our $VERSION = '1.21';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
{
# Exported subroutines
my @EXPORT = qw(share is_shared cond_wait cond_timedwait
- cond_signal cond_broadcast);
+ cond_signal cond_broadcast shared_clone);
if ($threads::threads) {
push(@EXPORT, 'bless');
}
}
+# Predeclarations for internal functions
+my ($make_shared);
+
+
### Methods, etc. ###
sub threads::shared::tie::SPLICE
Carp::croak('Splice not implemented for shared arrays');
}
+
+# Create a thread-shared clone of a complex data structure or object
+sub shared_clone
+{
+ if (@_ != 1) {
+ require Carp;
+ Carp::croak('Usage: shared_clone(REF)');
+ }
+
+ return $make_shared->(shift, {});
+}
+
+
+### Internal Functions ###
+
+# Used by shared_clone() to recursively clone
+# a complex data structure or object
+$make_shared = sub {
+ my ($item, $cloned) = @_;
+
+ # Just return the item if:
+ # 1. Not a ref;
+ # 2. Already shared; or
+ # 3. Not running 'threads'.
+ return $item if (! ref($item) || is_shared($item) || ! $threads::threads);
+
+ # Check for previously cloned references
+ # (this takes care of circular refs as well)
+ my $addr = refaddr($item);
+ if (exists($cloned->{$addr})) {
+ # Return the already existing clone
+ return $cloned->{$addr};
+ }
+
+ # Make copies of array, hash and scalar refs and refs of refs
+ my $copy;
+ my $ref_type = reftype($item);
+
+ # Copy an array ref
+ if ($ref_type eq 'ARRAY') {
+ # Make empty shared array ref
+ $copy = &share([]);
+ # Add to clone checking hash
+ $cloned->{$addr} = $copy;
+ # Recursively copy and add contents
+ push(@$copy, map { $make_shared->($_, $cloned) } @$item);
+ }
+
+ # Copy a hash ref
+ elsif ($ref_type eq 'HASH') {
+ # Make empty shared hash ref
+ $copy = &share({});
+ # Add to clone checking hash
+ $cloned->{$addr} = $copy;
+ # Recursively copy and add contents
+ foreach my $key (keys(%{$item})) {
+ $copy->{$key} = $make_shared->($item->{$key}, $cloned);
+ }
+ }
+
+ # Copy a scalar ref
+ elsif ($ref_type eq 'SCALAR') {
+ $copy = \do{ my $scalar = $$item; };
+ share($copy);
+ # Clone READONLY flag
+ if (Internals::SvREADONLY($$item)) {
+ Internals::SvREADONLY($$copy, 1);
+ }
+ # Add to clone checking hash
+ $cloned->{$addr} = $copy;
+ }
+
+ # Copy of a ref of a ref
+ elsif ($ref_type eq 'REF') {
+ # Special handling for $x = \$x
+ if ($addr == refaddr($$item)) {
+ $copy = \$copy;
+ share($copy);
+ $cloned->{$addr} = $copy;
+ } else {
+ my $tmp;
+ $copy = \$tmp;
+ share($copy);
+ # Add to clone checking hash
+ $cloned->{$addr} = $copy;
+ # Recursively copy and add contents
+ $tmp = $make_shared->($$item, $cloned);
+ }
+
+ } else {
+ require Carp;
+ Carp::croak("Unsupported ref type: ", $ref_type);
+ }
+
+ # If input item is an object, then bless the copy into the same class
+ if (my $class = blessed($item)) {
+ bless($copy, $class);
+ }
+
+ # Clone READONLY flag
+ if (Internals::SvREADONLY($item)) {
+ Internals::SvREADONLY($copy, 1);
+ }
+
+ return $copy;
+};
+
1;
__END__
=head1 VERSION
-This document describes threads::shared version 1.19
+This document describes threads::shared version 1.21
=head1 SYNOPSIS
use threads::shared;
my $var :shared;
- $var = $scalar_value;
- $var = $shared_ref_value;
- $var = share($simple_unshared_ref_value);
+ my %hsh :shared;
+ my @ary :shared;
my ($scalar, @array, %hash);
share($scalar);
share(@array);
share(%hash);
- my $bar = &share([]);
- $hash{bar} = &share({});
+
+ $var = $scalar_value;
+ $var = $shared_ref_value;
+ $var = shared_clone($non_shared_ref_value);
+ $var = shared_clone({'foo' => [qw/foo bar baz/]});
+
+ $hsh{'foo'} = $scalar_value;
+ $hsh{'bar'} = $shared_ref_value;
+ $hsh{'baz'} = shared_clone($non_shared_ref_value);
+ $hsh{'quz'} = shared_clone([1..3]);
+
+ $ary[0] = $scalar_value;
+ $ary[1] = $shared_ref_value;
+ $ary[2] = shared_clone($non_shared_ref_value);
+ $ary[3] = shared_clone([ {}, [] ]);
{ lock(%hash); ... }
By default, variables are private to each thread, and each newly created
thread gets a private copy of each existing variable. This module allows you
-to share variables across different threads (and pseudo-forks on Win32). It is
-used together with the L<threads> module.
+to share variables across different threads (and pseudo-forks on Win32). It
+is used together with the L<threads> module.
+
+This module supports the sharing of the following data types only: scalars
+and scalar refs, arrays and array refs, and hashes and hash refs.
=head1 EXPORT
-C<share>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>, C<cond_broadcast>,
-C<is_shared>
+The following functions are exported by this module: C<share>,
+C<shared_clone>, C<is_shared>, C<cond_wait>, C<cond_timedwait>, C<cond_signal>
+and C<cond_broadcast>
Note that if this module is imported when L<threads> has not yet been loaded,
then these functions all become no-ops. This makes it possible to write
=item share VARIABLE
-C<share> takes a value and marks it as shared. You can share a scalar, array,
-hash, scalar ref, array ref, or hash ref. C<share> will return the shared
-rvalue, but always as a reference.
+C<share> takes a variable and marks it as shared:
+
+ my ($scalar, @array, %hash);
+ share($scalar);
+ share(@array);
+ share(%hash);
+
+C<share> will return the shared rvalue, but always as a reference.
-A variable can also be marked as shared at compile time by using the
-C<:shared> attribute: C<my $var :shared;>.
+Variables can also be marked as shared at compile time by using the
+C<:shared> attribute:
-Due to problems with Perl's prototyping, if you want to share a newly created
-reference, you need to use the C<&share([])> and C<&share({})> syntax.
+ my ($var, %hash, @array) :shared;
-The only values that can be assigned to a shared scalar are other scalar
-values, or shared refs:
+Shared variables can only store scalars, refs of shared variables, or
+refs of shared data (discussed in next section):
- my $var :shared;
- $var = 1; # ok
- $var = []; # error
- $var = &share([]); # ok
+ my ($var, %hash, @array) :shared;
+ my $bork;
+
+ # Storing scalars
+ $var = 1;
+ $hash{'foo'} = 'bar';
+ $array[0] = 1.5;
+
+ # Storing shared refs
+ $var = \%hash;
+ $hash{'ary'} = \@array;
+ $array[1] = \$var;
+
+ # The following are errors:
+ # $var = \$bork; # ref of non-shared variable
+ # $hash{'bork'} = []; # non-shared array ref
+ # push(@array, { 'x' => 1 }); # non-shared hash ref
-C<share> will traverse up references exactly I<one> level. C<share(\$a)> is
-equivalent to C<share($a)>, while C<share(\\$a)> is not. This means that you
-must create nested shared data structures by first creating individual shared
-leaf nodes, and then adding them to a shared hash or array.
+=item shared_clone REF
- my %hash :shared;
- $hash{'meaning'} = &share([]);
- $hash{'meaning'}[0] = &share({});
- $hash{'meaning'}[0]{'life'} = 42;
+C<shared_clone> takes a reference, and returns a shared version of its
+argument, preforming a deep copy on any non-shared elements. Any shared
+elements in the argument are used as is (i.e., they are not cloned).
+
+ my $cpy = shared_clone({'foo' => [qw/foo bar baz/]});
+
+Object status (i.e., the class an object is blessed into) is also cloned.
+
+ my $obj = {'foo' => [qw/foo bar baz/]};
+ bless($obj, 'Foo');
+ my $cpy = shared_clone($obj);
+ print(ref($cpy), "\n"); # Outputs 'Foo'
+
+For cloning empty array or hash refs, the following may also be used:
+
+ $var = &share([]); # Same as $var = share_clone([]);
+ $var = &share({}); # Same as $var = share_clone({});
=item is_shared VARIABLE
L<threads::shared> exports a version of L<bless()|perlfunc/"bless REF"> that
works on shared objects such that I<blessings> propagate across threads.
- # Create a shared 'foo' object
- my $foo;
- share($foo);
- $foo = &share({});
- bless($foo, 'foo');
+ # Create a shared 'Foo' object
+ my $foo :shared = shared_clone({});
+ bless($foo, 'Foo');
- # Create a shared 'bar' object
- my $bar;
- share($bar);
- $bar = &share({});
- bless($bar, 'bar');
+ # Create a shared 'Bar' object
+ my $bar :shared = shared_clone({});
+ bless($bar, 'Bar');
# Put 'bar' inside 'foo'
$foo->{'bar'} = $bar;
# Rebless the objects via a thread
threads->create(sub {
# Rebless the outer object
- bless($foo, 'yin');
+ bless($foo, 'Yin');
# Cannot directly rebless the inner object
- #bless($foo->{'bar'}, 'yang');
+ #bless($foo->{'bar'}, 'Yang');
# Retrieve and rebless the inner object
my $obj = $foo->{'bar'};
- bless($obj, 'yang');
+ bless($obj, 'Yang');
$foo->{'bar'} = $obj;
})->join();
- print(ref($foo), "\n"); # Prints 'yin'
- print(ref($foo->{'bar'}), "\n"); # Prints 'yang'
- print(ref($bar), "\n"); # Also prints 'yang'
+ print(ref($foo), "\n"); # Prints 'Yin'
+ print(ref($foo->{'bar'}), "\n"); # Prints 'Yang'
+ print(ref($bar), "\n"); # Also prints 'Yang'
=head1 NOTES
L<http://www.cpanforum.com/dist/threads-shared>
Annotated POD for L<threads::shared>:
-L<http://annocpan.org/~JDHEDDEN/threads-shared-1.19/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-shared-1.21/shared.pm>
Source repository:
L<http://code.google.com/p/threads-shared/>
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN {
+ if ($ENV{'PERL_CORE'}){
+ chdir 't';
+ unshift @INC, '../lib';
+ }
+ use Config;
+ if (! $Config{'useithreads'}) {
+ print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
+ exit(0);
+ }
+}
+
+use ExtUtils::testlib;
+
+sub ok {
+ my ($id, $ok, $name) = @_;
+
+ # You have to do it this way or VMS will get confused.
+ if ($ok) {
+ print("ok $id - $name\n");
+ } else {
+ print("not ok $id - $name\n");
+ printf("# Failed test at line %d\n", (caller)[2]);
+ }
+
+ return ($ok);
+}
+
+BEGIN {
+ $| = 1;
+ print("1..28\n"); ### Number of tests that will be run ###
+};
+
+my $test = 1;
+
+use threads;
+use threads::shared;
+ok($test++, 1, 'Loaded');
+
+### Start of Testing ###
+
+{
+ # Scalar
+ my $x = shared_clone(14);
+ ok($test++, $x == 14, 'number');
+
+ $x = shared_clone('test');
+ ok($test++, $x eq 'test', 'string');
+}
+
+{
+ my %hsh = ('foo' => 2);
+ eval {
+ my $x = shared_clone(%hsh);
+ };
+ ok($test++, $@ =~ /Usage:/, '1 arg');
+
+ threads->create(sub {})->join(); # Hide leaks, etc.
+}
+
+{
+ my $x = 'test';
+ my $foo :shared = shared_clone($x);
+ ok($test++, $foo eq 'test', 'cloned string');
+
+ $foo = shared_clone(\$x);
+ ok($test++, $$foo eq 'test', 'cloned scalar ref');
+
+ threads->create(sub {
+ ok($test++, $$foo eq 'test', 'cloned scalar ref in thread');
+ })->join();
+
+ $test++;
+}
+
+{
+ my $foo :shared;
+ $foo = shared_clone(\$foo);
+ ok($test++, ref($foo) eq 'REF', 'Circular ref typ');
+ ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref');
+
+ threads->create(sub {
+ ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref in thread');
+
+ my ($x, $y, $z);
+ $x = \$y; $y = \$z; $z = \$x;
+ $foo = shared_clone($x);
+ })->join();
+
+ $test++;
+
+ ok($test++, threads::shared::_id($$foo) == threads::shared::_id($$$$$foo),
+ 'Cloned circular refs from thread');
+}
+
+{
+ my @ary = (qw/foo bar baz/);
+ my $ary = shared_clone(\@ary);
+
+ ok($test++, $ary->[1] eq 'bar', 'Cloned array');
+ $ary->[1] = 99;
+ ok($test++, $ary->[1] == 99, 'Clone mod');
+ ok($test++, $ary[1] eq 'bar', 'Original array');
+
+ threads->create(sub {
+ ok($test++, $ary->[1] == 99, 'Clone mod in thread');
+
+ $ary[1] = 'bork';
+ $ary->[1] = 'thread';
+ })->join();
+
+ $test++;
+
+ ok($test++, $ary->[1] eq 'thread', 'Clone mod from thread');
+ ok($test++, $ary[1] eq 'bar', 'Original array');
+}
+
+{
+ my $scalar = 'zip';
+
+ my $obj = {
+ 'ary' => [ 1, 'foo', [ 86 ], { 'bar' => [ 'baz' ] } ],
+ 'ref' => \$scalar,
+ };
+
+ $obj->{'self'} = $obj;
+
+ bless($obj, 'Foo');
+
+ my $copy :shared;
+
+ threads->create(sub {
+ $copy = shared_clone($obj);
+
+ ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
+ ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
+ ok($test++, is_shared($copy->{'ary'}->[2]), 'Shared element in cloned obj');
+ })->join();
+
+ $test += 3;
+
+ ok($test++, ref($copy) eq 'Foo', 'Obj cloned by thread');
+ ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
+ ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
+ ok($test++, $copy->{'ary'}->[3]->{'bar'}->[0] eq 'baz', 'Deeply cloned');
+ ok($test++, ref($copy) eq 'Foo', 'Cloned object class');
+}
+
+{
+ my $hsh :shared = shared_clone({'foo' => [qw/foo bar baz/]});
+ ok($test++, is_shared($hsh), 'Shared hash ref');
+ ok($test++, is_shared($hsh->{'foo'}), 'Shared hash ref elem');
+ ok($test++, $$hsh{'foo'}[1] eq 'bar', 'Cloned structure');
+}
+
+# EOF
projects / p5sagit/p5-mst-13.2.git / commitdiff