X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Faccessors_xs_cachedwarn.t;h=eecc8dff23908ec4a07fec0366b57434d24a1f59;hb=1ed25f9e8d107a7311c579da0d23afa253c01268;hp=42f0ebfafaa0722901c4a84b41fa1676c1719ddd;hpb=7a1ba8bdc62a701ef7b8ec39191ba526e067071f;p=p5sagit%2FClass-Accessor-Grouped.git diff --git a/t/accessors_xs_cachedwarn.t b/t/accessors_xs_cachedwarn.t index 42f0ebf..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; @@ -19,28 +27,33 @@ BEGIN { } use AccessorGroupsSubclass; -$Class::Accessor::Grouped::USE_XS = 1; - -my $obj = AccessorGroupsSubclass->new; -my $obj2 = AccessorGroups->new; -my $deferred_stub = AccessorGroupsSubclass->can('singlefield'); 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'); is ( - scalar (grep { $_ =~ /^\QDeferred version of method AccessorGroups::singlefield invoked more than once/ } @w), + scalar (grep { $_ =~ /^\QDeferred version of method AccessorGroupsParent::singlefield invoked more than once/ } @w), 3, '3 warnings produced as expected on cached invocation during testing', ) or do {