From: Peter Rabbitson <ribasushi@cpan.org>
Date: Mon, 18 Mar 2013 08:23:54 +0000 (+0100)
Subject: Make cref registry thread-safe and a ton of tests
X-Git-Tag: v0.10010~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1ed25f9e8d107a7311c579da0d23afa253c01268;p=p5sagit%2FClass-Accessor-Grouped.git

Make cref registry thread-safe and a ton of tests
---

diff --git a/lib/Class/Accessor/Grouped.pm b/lib/Class/Accessor/Grouped.pm
index d392a48..fb7a1ed 100644
--- a/lib/Class/Accessor/Grouped.pm
+++ b/lib/Class/Accessor/Grouped.pm
@@ -788,6 +788,14 @@ my $original_simple_setter = __PACKAGE__->can ('set_simple');
 
 my ($resolved_methods, $cag_produced_crefs);
 
+sub CLONE {
+  my @crefs = grep { defined $_ } values %{$cag_produced_crefs||{}};
+  $cag_produced_crefs = @crefs
+    ? { map { $_ => $_ } @crefs }
+    : undef
+  ;
+}
+
 # Note!!! Unusual signature
 $gen_accessor = sub {
   my ($type, $class, $group, $field, $methname) = @_;
diff --git a/t/accessors_pp.t b/t/accessors_pp.t
index 5a28b2f..de43239 100644
--- a/t/accessors_pp.t
+++ b/t/accessors_pp.t
@@ -1,5 +1,14 @@
+my $has_threads;
+BEGIN { eval '
+  use 5.008001;
+  use threads;
+  use threads::shared;
+  $has_threads = 1;
+' }
+
 use strict;
 use warnings;
+no warnings 'once';
 use FindBin qw($Bin);
 use File::Spec::Functions;
 use File::Spec::Unix (); # need this for %INC munging
@@ -25,8 +34,11 @@ BEGIN {
 our $SUBTESTING = 1;
 for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) {
 
-  for (1,2) {
-    note "\nTesting $tname without Sub::Name (pass $_)\n\n";
+  my $pass = 1;
+  share($pass) if $has_threads;
+
+  my $todo = sub {
+    note "\nTesting $tname without Sub::Name (pass @{[ $pass ++ ]})\n\n";
 
     my $tfn = catfile($Bin, $tname);
 
@@ -38,7 +50,18 @@ for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) {
     local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /subroutine .+ redefined/i };
 
     do($tfn);
+  };
 
+  if ($has_threads) {
+    threads->create(sub {
+      threads->create(sub {
+        $todo->() for (1,2) }
+      )->join;
+      $todo->() for (1,2);
+    })->join for (1,2)
+  }
+  else {
+    $todo->() for (1, 2);
   }
 }
 
diff --git a/t/accessors_xs.t b/t/accessors_xs.t
index eecf45c..54d8a1f 100644
--- a/t/accessors_xs.t
+++ b/t/accessors_xs.t
@@ -1,5 +1,14 @@
+my $has_threads;
+BEGIN { eval '
+  use 5.008001;
+  use threads;
+  use threads::shared;
+  $has_threads = 1;
+' }
+
 use strict;
 use warnings;
+no warnings 'once';
 use FindBin qw($Bin);
 use File::Spec::Functions;
 use File::Spec::Unix (); # need this for %INC munging
@@ -27,8 +36,11 @@ $Class::Accessor::Grouped::USE_XS = 1;
 
 for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) {
 
-  for (1,2) {
-    note "\nTesting $tname with USE_XS (pass $_)\n\n";
+  my $pass = 1;
+  share($pass) if $has_threads;
+
+  my $todo = sub {
+    note "\nTesting $tname with USE_XS (pass @{[ $pass++ ]})\n\n";
 
     my $tfn = catfile($Bin, $tname);
 
@@ -46,6 +58,18 @@ for my $tname (qw/accessors.t accessors_ro.t accessors_wo.t/) {
     local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /subroutine .+ redefined/i };
 
     do($tfn);
+  };
+
+  if ($has_threads) {
+    threads->create(sub {
+      threads->create(sub {
+        $todo->() for (1,2) }
+      )->join;
+      $todo->() for (1,2);
+    })->join for (1,2)
+  }
+  else {
+    $todo->() for (1, 2);
   }
 }
 
diff --git a/t/accessors_xs_cachedwarn.t b/t/accessors_xs_cachedwarn.t
index f7c2c6b..eecc8df 100644
--- a/t/accessors_xs_cachedwarn.t
+++ b/t/accessors_xs_cachedwarn.t
@@ -1,3 +1,11 @@
+my $has_threads;
+BEGIN { eval '
+  use 5.008004; # older perls get confused by $SIG fiddling
+  use threads;
+  use threads::shared;
+  $has_threads = 1;
+' }
+
 use strict;
 use warnings;
 use Test::More;
@@ -20,20 +28,26 @@ BEGIN {
 
 use AccessorGroupsSubclass;
 
-my $obj = AccessorGroupsSubclass->new;
-my $deferred_stub = AccessorGroupsSubclass->can('singlefield');
-my $obj2 = AccessorGroups->new;
-
 my @w;
+share(@w) if $has_threads;
+
 {
-  local $SIG{__WARN__} = sub { push @w, @_ };
-  is ($obj->$deferred_stub(1), 1, 'Set');
-  is ($obj->$deferred_stub, 1, 'Get');
-  is ($obj->$deferred_stub(2), 2, 'ReSet');
-  is ($obj->$deferred_stub, 2, 'ReGet');
-
-  is ($obj->singlefield, 2, 'Normal get');
-  is ($obj2->singlefield, undef, 'Normal get on unrelated object');
+  my $obj = AccessorGroupsSubclass->new;
+  my $deferred_stub = AccessorGroupsSubclass->can('singlefield');
+  my $obj2 = AccessorGroups->new;
+
+  my $todo = sub {
+    local $SIG{__WARN__} = sub { push @w, @_ };
+    is ($obj->$deferred_stub(1), 1, 'Set');
+    is ($obj->$deferred_stub, 1, 'Get');
+    is ($obj->$deferred_stub(2), 2, 'ReSet');
+    is ($obj->$deferred_stub, 2, 'ReGet');
+
+    is ($obj->singlefield, 2, 'Normal get');
+    is ($obj2->singlefield, undef, 'Normal get on unrelated object');
+  };
+
+  $has_threads ? threads->create( $todo )->join : $todo->();
 }
 
 is (@w, 3, '3 warnings total');
diff --git a/t/clean_namespace.t b/t/clean_namespace.t
index f423a0f..9ddffa3 100644
--- a/t/clean_namespace.t
+++ b/t/clean_namespace.t
@@ -39,6 +39,7 @@ is_deeply
     mk_group_accessors
     mk_group_ro_accessors
     mk_group_wo_accessors
+    CLONE
   /,
 )],
 'Expected list of methods in a freshly inheriting class';