From: Jerry D. Hedden Date: Fri, 16 May 2008 09:52:24 +0000 (-0400) Subject: threads::shared 1.21 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=373098c085b1ffab2a229458ca868f1df31be81c;p=p5sagit%2Fp5-mst-13.2.git threads::shared 1.21 From: "Jerry D. Hedden" Message-ID: <1ff86f510805160652l73e7d5a9hdc675e8efbbf1479@mail.gmail.com> p4raw-id: //depot/perl@33836 --- diff --git a/MANIFEST b/MANIFEST index 3be3a7a..7a68a13 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1138,6 +1138,7 @@ ext/threads/shared/t/0nothread.t Tests for basic shared array functionality. ext/threads/shared/t/av_refs.t Tests for arrays containing references ext/threads/shared/t/av_simple.t Tests for basic shared array functionality. ext/threads/shared/t/blessed.t Test blessed shared variables +ext/threads/shared/t/clone.t Test shared cloning ext/threads/shared/t/cond.t Test condition variables ext/threads/shared/t/disabled.t Test threads::shared when threads are disabled. ext/threads/shared/t/hv_refs.t Test shared hashes containing references diff --git a/ext/threads/shared/Makefile.PL b/ext/threads/shared/Makefile.PL index 6c53eb1..13e8f44 100755 --- a/ext/threads/shared/Makefile.PL +++ b/ext/threads/shared/Makefile.PL @@ -65,6 +65,7 @@ if (grep { $_ eq 'PERL_CORE=1' } @ARGV) { 'Config' => 0, 'Carp' => 0, 'XSLoader' => 0, + 'Scalar::Util' => 0, 'Test' => 0, 'Test::More' => 0, diff --git a/ext/threads/shared/shared.pm b/ext/threads/shared/shared.pm index 092cefe..fee9365 100644 --- a/ext/threads/shared/shared.pm +++ b/ext/threads/shared/shared.pm @@ -5,7 +5,9 @@ use 5.008; 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; @@ -41,7 +43,7 @@ sub import { # 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'); } @@ -55,6 +57,10 @@ sub import } +# Predeclarations for internal functions +my ($make_shared); + + ### Methods, etc. ### sub threads::shared::tie::SPLICE @@ -63,6 +69,113 @@ 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__ @@ -73,7 +186,7 @@ threads::shared - Perl extension for sharing data structures between threads =head1 VERSION -This document describes threads::shared version 1.19 +This document describes threads::shared version 1.21 =head1 SYNOPSIS @@ -81,16 +194,28 @@ This document describes threads::shared version 1.19 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); ... } @@ -108,13 +233,17 @@ This document describes threads::shared version 1.19 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 module. +to share variables across different threads (and pseudo-forks on Win32). It +is used together with the L 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, C, C, C, C, -C +The following functions are exported by this module: C, +C, C, C, C, C +and C Note that if this module is imported when L has not yet been loaded, then these functions all become no-ops. This makes it possible to write @@ -126,33 +255,60 @@ modules that will work in both threaded and non-threaded environments. =item share VARIABLE -C takes a value and marks it as shared. You can share a scalar, array, -hash, scalar ref, array ref, or hash ref. C will return the shared -rvalue, but always as a reference. +C takes a variable and marks it as shared: + + my ($scalar, @array, %hash); + share($scalar); + share(@array); + share(%hash); + +C 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. +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 will traverse up references exactly I level. C is -equivalent to C, while C 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 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 @@ -279,17 +435,13 @@ a C on the locked variable, rather than only one. L exports a version of L that works on shared objects such that I 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; @@ -297,21 +449,21 @@ works on shared objects such that I propagate across threads. # 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 @@ -388,7 +540,7 @@ L Discussion Forum on CPAN: L Annotated POD for L: -L +L Source repository: L diff --git a/ext/threads/shared/shared.xs b/ext/threads/shared/shared.xs index e965955..cdea8c9 100644 --- a/ext/threads/shared/shared.xs +++ b/ext/threads/shared/shared.xs @@ -891,8 +891,7 @@ sharedsv_elem_mg_FETCH(pTHX_ SV *sv, MAGIC *mg) S_get_RV(aTHX_ SvRV(sv), SvRV(*svp)); } } else { - /* XXX Can this branch ever happen? DAPM */ - /* XXX assert("no such branch"); */ + /* $ary->[elem] or $ary->{elem} is a scalar */ Perl_sharedsv_associate(aTHX_ sv, *svp); sv_setsv(sv, *svp); } @@ -1346,6 +1345,8 @@ _id(SV *myref) SV *ssv; CODE: myref = SvRV(myref); + if (SvMAGICAL(myref)) + mg_get(myref); if (SvROK(myref)) myref = SvRV(myref); ssv = Perl_sharedsv_find(aTHX_ myref); diff --git a/ext/threads/shared/t/clone.t b/ext/threads/shared/t/clone.t new file mode 100644 index 0000000..8990adf --- /dev/null +++ b/ext/threads/shared/t/clone.t @@ -0,0 +1,159 @@ +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