Change 33931 by [EMAIL PROTECTED] on 2008/05/25 22:45:48
Integrate:
[ 33882]
Integrate:
[ 33809]
Subject: [PATCH - revised^2] threads::shared 1.19
From: "Jerry D. Hedden" <[EMAIL PROTECTED]>
Date: Wed, 7 May 2008 16:36:28 -0400
Message-ID: <[EMAIL PROTECTED]>
[ 33811]
Remove C++ comments
[ 33836]
Subject: [PATCH - revised] threads::shared 1.21
From: "Jerry D. Hedden" <[EMAIL PROTECTED]>
Date: Fri, 16 May 2008 09:52:24 -0400
Message-ID: <[EMAIL PROTECTED]>
[ 33883]
Integrate:
[ 33808]
Subject: [PATCH - revised] Thread::Queue 2.07
From: "Jerry D. Hedden" <[EMAIL PROTECTED]>
Date: Thu, 8 May 2008 10:05:51 -0400
Message-ID: <[EMAIL PROTECTED]>
[ 33847]
Subject: [PATCH] Thread::Queue 2.08
From: "Jerry D. Hedden" <[EMAIL PROTECTED]>
Date: Wed, 14 May 2008 12:47:04 -0400
Message-ID: <[EMAIL PROTECTED]>
[ 33871]
Subject: [PATCH] Thread::Semaphore 2.08
From: "Jerry D. Hedden" <[EMAIL PROTECTED]>
Date: Mon, 19 May 2008 13:06:20 -0400
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/maint-5.8/perl/MANIFEST#432 integrate
... //depot/maint-5.8/perl/ext/threads/shared/Makefile.PL#4 integrate
... //depot/maint-5.8/perl/ext/threads/shared/shared.pm#18 integrate
... //depot/maint-5.8/perl/ext/threads/shared/shared.xs#32 integrate
... //depot/maint-5.8/perl/ext/threads/shared/t/clone.t#1 branch
... //depot/maint-5.8/perl/ext/threads/shared/t/stress.t#5 integrate
... //depot/maint-5.8/perl/ext/threads/shared/t/sv_refs.t#4 integrate
... //depot/maint-5.8/perl/lib/Thread/Queue.pm#3 integrate
... //depot/maint-5.8/perl/lib/Thread/Queue/t/02_refs.t#2 integrate
... //depot/maint-5.8/perl/lib/Thread/Semaphore.pm#5 integrate
Differences ...
==== //depot/maint-5.8/perl/MANIFEST#432 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#431~33930~ 2008-05-25 15:33:32.000000000 -0700
+++ perl/MANIFEST 2008-05-25 15:45:48.000000000 -0700
@@ -964,6 +964,7 @@
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
==== //depot/maint-5.8/perl/ext/threads/shared/Makefile.PL#4 (xtext) ====
Index: perl/ext/threads/shared/Makefile.PL
--- perl/ext/threads/shared/Makefile.PL#3~33522~ 2008-03-13
17:11:24.000000000 -0700
+++ perl/ext/threads/shared/Makefile.PL 2008-05-25 15:45:48.000000000 -0700
@@ -65,6 +65,7 @@
'Config' => 0,
'Carp' => 0,
'XSLoader' => 0,
+ 'Scalar::Util' => 0,
'Test' => 0,
'Test::More' => 0,
==== //depot/maint-5.8/perl/ext/threads/shared/shared.pm#18 (text) ====
Index: perl/ext/threads/shared/shared.pm
--- perl/ext/threads/shared/shared.pm#17~33522~ 2008-03-13 17:11:24.000000000
-0700
+++ perl/ext/threads/shared/shared.pm 2008-05-25 15:45:48.000000000 -0700
@@ -5,7 +5,9 @@
use strict;
use warnings;
-our $VERSION = '1.18';
+use Scalar::Util qw(reftype refaddr blessed);
+
+our $VERSION = '1.21';
my $XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -41,7 +43,7 @@
{
# 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 @@
}
+# Predeclarations for internal functions
+my ($make_shared);
+
+
### Methods, etc. ###
sub threads::shared::tie::SPLICE
@@ -63,6 +69,113 @@
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 @@
=head1 VERSION
-This document describes threads::shared version 1.18
+This document describes threads::shared version 1.21
=head1 SYNOPSIS
@@ -81,16 +194,28 @@
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 @@
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
@@ -126,33 +255,60 @@
=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
-
-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.
-
- my %hash :shared;
- $hash{'meaning'} = &share([]);
- $hash{'meaning'}[0] = &share({});
- $hash{'meaning'}[0]{'life'} = 42;
+ 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'} = [EMAIL PROTECTED];
+ $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
+
+=item shared_clone REF
+
+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
@@ -279,17 +435,13 @@
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 'bar' object
- my $bar;
- share($bar);
- $bar = &share({});
- bless($bar, 'bar');
+ # Create a shared 'Foo' object
+ my $foo :shared = shared_clone({});
+ bless($foo, 'Foo');
+
+ # Create a shared 'Bar' object
+ my $bar :shared = shared_clone({});
+ bless($bar, 'Bar');
# Put 'bar' inside 'foo'
$foo->{'bar'} = $bar;
@@ -297,21 +449,21 @@
# 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
@@ -362,6 +514,23 @@
error "locking can only be used on shared values" to occur when you attempt to
C<< lock($hasref->{key}) >>.
+Using L<refaddr()|Scalar::Util/"refaddr EXPR">) is unreliable for testing
+whether or not two shared references are equivalent (e.g., when testing for
+circular references). Use L<is_shared()/"is_shared VARIABLE">, instead:
+
+ use threads;
+ use threads::shared;
+ use Scalar::Util qw(refaddr);
+
+ # If ref is shared, use threads::shared's internal ID.
+ # Otherwise, use refaddr().
+ my $addr1 = is_shared($ref1) || refaddr($ref1);
+ my $addr2 = is_shared($ref2) || refaddr($ref2);
+
+ if ($addr1 == $addr2) {
+ # The refs are equivalent
+ }
+
View existing bug reports at, and submit any new bugs, problems, patches, etc.
to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared>
@@ -371,7 +540,7 @@
L<http://www.cpanforum.com/dist/threads-shared>
Annotated POD for L<threads::shared>:
-L<http://annocpan.org/~JDHEDDEN/threads-shared-1.18/shared.pm>
+L<http://annocpan.org/~JDHEDDEN/threads-shared-1.21/shared.pm>
Source repository:
L<http://code.google.com/p/threads-shared/>
==== //depot/maint-5.8/perl/ext/threads/shared/shared.xs#32 (text) ====
Index: perl/ext/threads/shared/shared.xs
--- perl/ext/threads/shared/shared.xs#31~33522~ 2008-03-13 17:11:24.000000000
-0700
+++ perl/ext/threads/shared/shared.xs 2008-05-25 15:45:48.000000000 -0700
@@ -712,6 +712,11 @@
ENTER_LOCK;
if (SvROK(ssv)) {
S_get_RV(aTHX_ sv, ssv);
+ /* Look ahead for refs of refs */
+ if (SvROK(SvRV(ssv))) {
+ SvROK_on(SvRV(sv));
+ S_get_RV(aTHX_ SvRV(sv), SvRV(ssv));
+ }
} else {
sv_setsv_nomg(sv, ssv);
}
@@ -880,9 +885,13 @@
/* Exists in the array */
if (SvROK(*svp)) {
S_get_RV(aTHX_ sv, *svp);
+ /* Look ahead for refs of refs */
+ if (SvROK(SvRV(*svp))) {
+ SvROK_on(SvRV(sv));
+ 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);
}
@@ -1336,6 +1345,8 @@
SV *ssv;
CODE:
myref = SvRV(myref);
+ if (SvMAGICAL(myref))
+ mg_get(myref);
if (SvROK(myref))
myref = SvRV(myref);
ssv = Perl_sharedsv_find(aTHX_ myref);
==== //depot/maint-5.8/perl/ext/threads/shared/t/clone.t#1 (text) ====
Index: perl/ext/threads/shared/t/clone.t
--- /dev/null 2008-05-07 15:08:24.549929899 -0700
+++ perl/ext/threads/shared/t/clone.t 2008-05-25 15:45:48.000000000 -0700
@@ -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([EMAIL PROTECTED]);
+
+ 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
==== //depot/maint-5.8/perl/ext/threads/shared/t/stress.t#5 (text) ====
Index: perl/ext/threads/shared/t/stress.t
--- perl/ext/threads/shared/t/stress.t#4~33522~ 2008-03-13 17:11:24.000000000
-0700
+++ perl/ext/threads/shared/t/stress.t 2008-05-25 15:45:48.000000000 -0700
@@ -79,25 +79,34 @@
# Gather thread results
my ($okay, $failures, $timeouts, $unknown) = (0, 0, 0, 0);
for (1..$cnt) {
- my $rc = $threads[$_]->join();
- if (! $rc) {
+ if (! $threads[$_]) {
$failures++;
- } elsif ($rc =~ /^timed out/) {
- $timeouts++;
- } elsif ($rc eq 'okay') {
- $okay++;
} else {
- $unknown++;
- print(STDERR "# Unknown error: $rc\n");
+ my $rc = $threads[$_]->join();
+ if (! $rc) {
+ $failures++;
+ } elsif ($rc =~ /^timed out/) {
+ $timeouts++;
+ } elsif ($rc eq 'okay') {
+ $okay++;
+ } else {
+ $unknown++;
+ print(STDERR "# Unknown error: $rc\n");
+ }
}
}
+ if ($failures) {
+ # Most likely due to running out of memory
+ print(STDERR "# Warning: $failures threads failed\n");
+ print(STDERR "# Note: errno 12 = ENOMEM\n");
+ $cnt -= $failures;
+ }
- if ($failures || $unknown || (($okay + $timeouts) != $cnt)) {
+ if ($unknown || (($okay + $timeouts) != $cnt)) {
print("not ok 1\n");
- my $too_few = $cnt - ($okay + $failures + $timeouts + $unknown);
+ my $too_few = $cnt - ($okay + $timeouts + $unknown);
print(STDERR "# Test failed:\n");
print(STDERR "#\t$too_few too few threads reported\n") if $too_few;
- print(STDERR "#\t$failures threads failed\n") if $failures;
print(STDERR "#\t$unknown unknown errors\n") if $unknown;
print(STDERR "#\t$timeouts threads timed out\n") if $timeouts;
==== //depot/maint-5.8/perl/ext/threads/shared/t/sv_refs.t#4 (text) ====
Index: perl/ext/threads/shared/t/sv_refs.t
--- perl/ext/threads/shared/t/sv_refs.t#3~30316~ 2007-02-15
05:28:31.000000000 -0800
+++ perl/ext/threads/shared/t/sv_refs.t 2008-05-25 15:45:48.000000000 -0700
@@ -31,7 +31,7 @@
BEGIN {
$| = 1;
- print("1..11\n"); ### Number of tests that will be run ###
+ print("1..21\n"); ### Number of tests that will be run ###
};
use threads;
@@ -74,4 +74,30 @@
ok(11, is_shared($foo), "Check for sharing");
+{
+ # Circular references with 3 shared scalars
+ my $x : shared;
+ my $y : shared;
+ my $z : shared;
+
+ $x = \$y;
+ $y = \$z;
+ $z = \$x;
+ ok(12, ref($x) eq 'REF', '$x ref type');
+ ok(13, ref($y) eq 'REF', '$y ref type');
+ ok(14, ref($z) eq 'REF', '$z ref type');
+
+ my @q :shared = ($x);
+ ok(15, ref($q[0]) eq 'REF', '$q[0] ref type');
+
+ my $w = $q[0];
+ ok(16, ref($w) eq 'REF', '$w ref type');
+ ok(17, ref($$w) eq 'REF', '$$w ref type');
+ ok(18, ref($$$w) eq 'REF', '$$$w ref type');
+ ok(19, ref($$$$w) eq 'REF', '$$$$w ref type');
+
+ ok(20, is_shared($x) == is_shared($w), '_id($x) == _id($w)');
+ ok(21, is_shared($w) == is_shared($$$$w), '_id($w) == _id($$$$w)');
+}
+
# EOF
==== //depot/maint-5.8/perl/lib/Thread/Queue.pm#3 (text) ====
Index: perl/lib/Thread/Queue.pm
--- perl/lib/Thread/Queue.pm#2~33516~ 2008-03-13 12:37:42.000000000 -0700
+++ perl/lib/Thread/Queue.pm 2008-05-25 15:45:48.000000000 -0700
@@ -3,19 +3,22 @@
use strict;
use warnings;
-our $VERSION = '2.06';
+our $VERSION = '2.08';
-use threads::shared 0.96;
-use Scalar::Util 1.10 qw(looks_like_number);
+use threads::shared 1.21;
+use Scalar::Util 1.10 qw(looks_like_number blessed reftype refaddr);
+
+# Carp errors from threads::shared calls should complain about caller
+our @CARP_NOT = ("threads::shared");
# Predeclarations for internal functions
-my ($make_shared, $validate_count, $validate_index);
+my ($validate_count, $validate_index);
# Create a new queue possibly pre-populated with items
sub new
{
my $class = shift;
- my @queue :shared = map { $make_shared->($_) } @_;
+ my @queue :shared = map { shared_clone($_) } @_;
return bless([EMAIL PROTECTED], $class);
}
@@ -24,7 +27,7 @@
{
my $queue = shift;
lock(@$queue);
- push(@$queue, map { $make_shared->($_) } @_)
+ push(@$queue, map { shared_clone($_) } @_)
and cond_signal(@$queue);
}
@@ -111,7 +114,7 @@
}
# Add new items to the queue
- push(@$queue, map { $make_shared->($_) } @_);
+ push(@$queue, map { shared_clone($_) } @_);
# Add previous items back onto the queue
push(@$queue, @tmp);
@@ -161,72 +164,6 @@
### Internal Functions ###
-# Create a thread-shared version of a complex data structure or object
-$make_shared = sub {
- my $item = shift;
-
- # If not running 'threads' or already thread-shared,
- # then just return the input item
- return $item if (! $threads::threads ||
- threads::shared::is_shared($item));
-
- # Make copies of array, hash and scalar refs
- my $copy;
- if (my $ref_type = Scalar::Util::reftype($item)) {
- # Copy an array ref
- if ($ref_type eq 'ARRAY') {
- # Make empty shared array ref
- $copy = &share([]);
- # Recursively copy and add contents
- push(@$copy, map { $make_shared->($_) } @$item);
- }
-
- # Copy a hash ref
- elsif ($ref_type eq 'HASH') {
- # Make empty shared hash ref
- $copy = &share({});
- # Recursively copy and add contents
- foreach my $key (keys(%{$item})) {
- $copy->{$key} = $make_shared->($item->{$key});
- }
- }
-
- # 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);
- }
- }
-
- # Copy of a ref of a ref
- elsif ($ref_type eq 'REF') {
- my $tmp = $make_shared->($$item);
- $copy = \$tmp;
- share($copy);
- }
- }
-
- # If no copy is created above, then just return the input item
- # NOTE: This will end up generating an error for anything
- # other than an ordinary scalar
- return $item if (! defined($copy));
-
- # Clone READONLY flag
- if (Internals::SvREADONLY($item)) {
- Internals::SvREADONLY($copy, 1);
- }
-
- # If input item is an object, then bless the copy into the same class
- if (my $class = Scalar::Util::blessed($item)) {
- bless($copy, $class);
- }
-
- return $copy;
-};
-
# Check value of the requested index
$validate_index = sub {
my $index = shift;
@@ -265,7 +202,7 @@
=head1 VERSION
-This document describes Thread::Queue version 2.06
+This document describes Thread::Queue version 2.08
=head1 SYNOPSIS
@@ -518,7 +455,7 @@
L<http://www.cpanforum.com/dist/Thread-Queue>
Annotated POD for Thread::Queue:
-L<http://annocpan.org/~JDHEDDEN/Thread-Queue-2.06/lib/Thread/Queue.pm>
+L<http://annocpan.org/~JDHEDDEN/Thread-Queue-2.08/lib/Thread/Queue.pm>
Source repository:
L<http://code.google.com/p/thread-queue/>
==== //depot/maint-5.8/perl/lib/Thread/Queue/t/02_refs.t#2 (text) ====
Index: perl/lib/Thread/Queue/t/02_refs.t
--- perl/lib/Thread/Queue/t/02_refs.t#1~33516~ 2008-03-13 12:37:42.000000000
-0700
+++ perl/lib/Thread/Queue/t/02_refs.t 2008-05-25 15:45:48.000000000 -0700
@@ -23,7 +23,7 @@
require Test::More;
}
Test::More->import();
-plan('tests' => 39);
+plan('tests' => 46);
# Regular array
my @ary1 = qw/foo bar baz/;
@@ -62,18 +62,34 @@
my $qux = \$baz;
is_deeply($$$$qux, $foo, 'Ref of ref');
+# Circular refs
+my $cir1;
+$cir1 = \$cir1;
+
+my $cir1s : shared;
+$cir1s = \$cir1s;
+
+my $cir2;
+$cir2 = [ \$cir2, { 'ref' => \$cir2 } ];
+
+my $cir3 :shared = &share({});
+$cir3->{'self'} = \$cir3;
+bless($cir3, 'Circular');
+
# Queue up items
my $q = Thread::Queue->new([EMAIL PROTECTED], [EMAIL PROTECTED]);
ok($q, 'New queue');
is($q->pending(), 2, 'Queue count');
$q->enqueue($obj1, $obj2);
is($q->pending(), 4, 'Queue count');
-$q->enqueue($sref1, $sref2, $qux);
-is($q->pending(), 7, 'Queue count');
+$q->enqueue($sref1, $sref2, $foo, $qux);
+is($q->pending(), 8, 'Queue count');
+$q->enqueue($cir1, $cir1s, $cir2, $cir3);
+is($q->pending(), 12, 'Queue count');
# Process items in thread
threads->create(sub {
- is($q->pending(), 7, 'Queue count in thread');
+ is($q->pending(), 12, 'Queue count in thread');
my $tary1 = $q->dequeue();
ok($tary1, 'Thread got item');
@@ -116,9 +132,38 @@
is($$tsref2, 69, 'Shared scalar ref contents');
$$tsref2 = 'zzz';
+ my $myfoo = $q->dequeue();
+ is_deeply($myfoo, $foo, 'Array ref');
+
my $qux = $q->dequeue();
is_deeply($$$$qux, $foo, 'Ref of ref');
+ my ($c1, $c1s, $c2, $c3) = $q->dequeue(4);
+ SKIP: {
+ skip("Needs threads::shared >= 1.19", 5)
+ if ($threads::shared::VERSION < 1.19);
+
+ is(threads::shared::_id($$c1),
+ threads::shared::_id($c1),
+ 'Circular ref - scalar');
+
+ is(threads::shared::_id($$c1s),
+ threads::shared::_id($c1s),
+ 'Circular ref - shared scalar');
+
+ is(threads::shared::_id(${$c2->[0]}),
+ threads::shared::_id($c2),
+ 'Circular ref - array');
+
+ is(threads::shared::_id(${$c2->[1]->{'ref'}}),
+ threads::shared::_id($c2),
+ 'Circular ref - mixed');
+
+ is(threads::shared::_id(${$c3->{'self'}}),
+ threads::shared::_id($c3),
+ 'Circular ref - hash');
+ }
+
is($q->pending(), 0, 'Empty queue');
my $nothing = $q->dequeue_nb();
ok(! defined($nothing), 'Nothing on queue');
==== //depot/maint-5.8/perl/lib/Thread/Semaphore.pm#5 (text) ====
Index: perl/lib/Thread/Semaphore.pm
--- perl/lib/Thread/Semaphore.pm#4~33516~ 2008-03-13 12:37:42.000000000
-0700
+++ perl/lib/Thread/Semaphore.pm 2008-05-25 15:45:48.000000000 -0700
@@ -3,7 +3,7 @@
use strict;
use warnings;
-our $VERSION = '2.07';
+our $VERSION = '2.08';
use threads::shared;
use Scalar::Util 1.10 qw(looks_like_number);
@@ -12,7 +12,10 @@
sub new {
my $class = shift;
my $val :shared = @_ ? shift : 1;
- if (! looks_like_number($val) || (int($val) != $val)) {
+ if (!defined($val) ||
+ ! looks_like_number($val) ||
+ (int($val) != $val))
+ {
require Carp;
$val = 'undef' if (! defined($val));
Carp::croak("Semaphore initializer is not an integer: $val");
@@ -25,7 +28,11 @@
my $sema = shift;
lock($$sema);
my $dec = @_ ? shift : 1;
- if (! looks_like_number($dec) || (int($dec) != $dec) || ($dec < 1)) {
+ if (! defined($dec) ||
+ ! looks_like_number($dec) ||
+ (int($dec) != $dec) ||
+ ($dec < 1))
+ {
require Carp;
$dec = 'undef' if (! defined($dec));
Carp::croak("Semaphore decrement is not a positive integer: $dec");
@@ -39,7 +46,11 @@
my $sema = shift;
lock($$sema);
my $inc = @_ ? shift : 1;
- if (! looks_like_number($inc) || (int($inc) != $inc) || ($inc < 1)) {
+ if (! defined($inc) ||
+ ! looks_like_number($inc) ||
+ (int($inc) != $inc) ||
+ ($inc < 1))
+ {
require Carp;
$inc = 'undef' if (! defined($inc));
Carp::croak("Semaphore increment is not a positive integer: $inc");
@@ -55,7 +66,7 @@
=head1 VERSION
-This document describes Thread::Semaphore version 2.07
+This document describes Thread::Semaphore version 2.08
=head1 SYNOPSIS
@@ -140,7 +151,7 @@
L<http://www.cpanforum.com/dist/Thread-Semaphore>
Annotated POD for Thread::Semaphore:
-L<http://annocpan.org/~JDHEDDEN/Thread-Semaphore-2.07/lib/Thread/Semaphore.pm>
+L<http://annocpan.org/~JDHEDDEN/Thread-Semaphore-2.08/lib/Thread/Semaphore.pm>
Source repository:
L<http://code.google.com/p/thread-semaphore/>
End of Patch.
