From: Peter Rabbitson Date: Wed, 1 Jun 2016 08:46:28 +0000 (+0200) Subject: Introduce the describe_class_methods() utility function X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=296248c3;p=dbsrgits%2FDBIx-Class.git Introduce the describe_class_methods() utility function This code will be needed several commits later to tie together the hierarchy validation work. Returns a comprehensive list of methods and related trivia. This required way more code than one would hope, this part of perl is *really* hateful. Read test changes under -w Everything is implemented on "bare metal" (no Package::Stash, very aggressive caching) as this needs to be as efficient as possible. Currently timings on old and new MRO are roughly such on a downclocked X201 / M540: ~/devel/dbic$ perlbrew exec --with 5.8.5,5.16.2,5.24.0_rc1 \ perl -T -Ilib -It/lib -MDBICTest -MTime::HiRes=time -e ' my $t0 = time; sub tstamp { printf "%.6f\n", time - $t0; $t0 = time; } tstamp(); for ( (qw( DBICTest::Schema::Artist DBICTest::Schema::CD DBICTest::Schema::Track main )) x 2 ) { print "describing $_\n"; DBIx::Class::_Util::describe_class_methods($_); tstamp(); } ' 5.8.5 ========== 0.000005 describing DBICTest::Schema::Artist 0.224748 describing DBICTest::Schema::CD 0.066118 describing DBICTest::Schema::Track 0.090433 describing main 0.003152 describing DBICTest::Schema::Artist 0.038846 describing DBICTest::Schema::CD 0.038390 describing DBICTest::Schema::Track 0.043453 describing main 0.002128 5.16.2 ========== 0.000005 describing DBICTest::Schema::Artist 0.077804 describing DBICTest::Schema::CD 0.007684 describing DBICTest::Schema::Track 0.013071 describing main 0.001073 describing DBICTest::Schema::Artist 0.000109 describing DBICTest::Schema::CD 0.000096 describing DBICTest::Schema::Track 0.000098 describing main 0.000041 5.24.0_rc1 ========== 0.000005 describing DBICTest::Schema::Artist 0.044058 describing DBICTest::Schema::CD 0.006093 describing DBICTest::Schema::Track 0.011004 describing main 0.000735 describing DBICTest::Schema::Artist 0.000118 describing DBICTest::Schema::CD 0.000114 describing DBICTest::Schema::Track 0.000113 describing main 0.000059 Additional sanity-checking of this deceptively simple code was performed by sad brute-forcing of the entire test schema set ( at the time of this commit the cumulative sum output was 0x1a65e78e316348104ab9cdc3e474c79096 ) perlbrew exec --with 5.8.5,5.10.0,5.16.2,5.18.0,5.20.0,5.24.0_rc1 \ perl -T -Ilib -It/lib -MDBICTest -e ' use Math::BigInt; use Digest::MD5 "md5_hex"; use List::Util 'shuffle'; use Data::Dumper::Concise; use DBIx::Class::_Util qw( describe_class_methods uniq ); my $sum = Math::BigInt->new(0); for ( shuffle uniq sort map { ( defined Scalar::Util::blessed $_ ) ? ref $_ : $_ } ( qw( DBIx::Class::ResultSource DBIx::Class::Core DBIx::Class::ResultSet DBICTest::Schema ), ( map { $_, $_->result_class, $_->resultset_class, } map { DBICTest::Schema->source($_) } DBICTest::Schema->sources ), ) ) { my $desc = describe_class_methods($_); # unstable between invocations delete $desc->{cumulative_gen}; # only available on 5.10+ delete $desc->{methods}{DOES}; # only available on 5.18+ delete $desc->{methods}{"(("}; $sum += Math::BigInt->new( "0x" . md5_hex(Dumper($desc)) ); } print $sum->as_hex; ' --- diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm index cea3961..1b50ac9 100644 --- a/lib/DBIx/Class/MethodAttributes.pm +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -76,6 +76,16 @@ sub MODIFY_CODE_ATTRIBUTES { weaken( $attr_cref_registry->{$code}{weakref} = $code ) } + + # increment the pkg gen, this ensures the sanity checkers will re-evaluate + # this class when/if the time comes + mro::method_changed_in($class) if ( + ! DBIx::Class::_ENV_::OLD_MRO + and + ( $attrs->{dbic} or $attrs->{misc} ) + ); + + # handle legacy attrs if( $attrs->{misc} ) { @@ -94,6 +104,7 @@ sub MODIFY_CODE_ATTRIBUTES { ))]; } + # handle DBIC_* attrs if( $attrs->{dbic} ) { my $slot = $attr_cref_registry->{$code}; @@ -108,6 +119,7 @@ sub MODIFY_CODE_ATTRIBUTES { ]; } + # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on: # decidedly not cool # diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index a713ee7..11034e2 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -8,6 +8,8 @@ use strict; use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( "$]" < 5.010 ? 1 : 0); +my $mro_recursor_stack; + BEGIN { package # hide from pause DBIx::Class::_ENV_; @@ -49,10 +51,71 @@ BEGIN { if ( "$]" < 5.009_005) { require MRO::Compat; constant->import( OLD_MRO => 1 ); + + # + # Yes, I know this is a rather PHP-ish name, but please first read + # https://metacpan.org/source/BOBTFISH/MRO-Compat-0.12/lib/MRO/Compat.pm#L363-368 + # + # Even if we are using Class::C3::XS it still won't work, as doing + # defined( *{ "SubClass::"->{$_} }{CODE} ) + # will set pkg_gen to the same value for SubClass and *ALL PARENTS* + # + *DBIx::Class::_Util::get_real_pkg_gen = sub ($) { + require Digest::MD5; + require Math::BigInt; + + # the non-assign-unless-there-is-a-hash is deliberate + ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{gen} ||= ( + Math::BigInt->new( '0x' . ( Digest::MD5::md5_hex( join "\0", map { + + ( $mro_recursor_stack->{cache} || {} )->{$_}{methlist} ||= do { + + my $class = $_; + + no strict 'refs'; + my %methlist = + map + # this is essentially a uniq_by step + # it is crucial on OLD_MRO + {( Scalar::Util::refaddr($_) => $_ )} + map + { + ( + ref(\ "${class}::"->{$_} ) ne 'GLOB' + or + defined( *{ "${class}::"->{$_} }{CODE} ) + ) + ? ( \&{"${class}::$_"} ) + : () + } + keys %{ "${class}::" } + ; + + # RV to be hashed up and turned into a number + join "\0", ( + $class, + map {( + $_, # refaddr is sufficient, ignore names entirely + @{ + ( $mro_recursor_stack->{cache} || {} )->{attrs}{$_} + ||= + [ attributes::get( $methlist{$_} ) ] + }, + )} sort keys %methlist + ), + } + } ( 'UNIVERSAL', @{ + ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{linear_isa} + ||= + mro::get_linear_isa($_[0]) + } ) ) ) ) + ); + }; } else { require mro; constant->import( OLD_MRO => 0 ); + *DBIx::Class::_Util::get_real_pkg_gen = \&mro::get_pkg_gen; } # Both of these are no longer used for anything. However bring @@ -84,6 +147,7 @@ use Storable 'nfreeze'; use Scalar::Util qw(weaken blessed reftype refaddr); use Sub::Quote qw(qsub); use Sub::Name (); +use attributes (); # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone' BEGIN { *deep_clone = \&Storable::dclone } @@ -92,7 +156,7 @@ use base 'Exporter'; our @EXPORT_OK = qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_wantarray fail_on_internal_call - refdesc refcount hrefaddr set_subname + refdesc refcount hrefaddr set_subname describe_class_methods scope_guard detected_reinvoked_destructor is_exception dbic_internal_try visit_namespaces quote_sub qsub perlstring serialize deep_clone dump_value uniq @@ -107,7 +171,6 @@ BEGIN { # FIXME FIXME FIXME # To be revisited when Moo with proper attr support ships Sub::Quote->VERSION(2.002); - require attributes; } # Override forcing no_defer, and adding naming consistency checks sub quote_sub { @@ -575,6 +638,187 @@ sub modver_gt_or_eq_and_lt ($$$) { ) ? 1 : 0; } +{ + # FIXME - should be a private my(), but I'm too uncertain whether + # all bases are covered + our $describe_class_query_cache; + + sub describe_class_methods { + + croak "Expecting a class name" + if not defined $_[0] or $_[0] !~ $module_name_rx; + + # use a cache on old MRO, since while we are recursing in this function + # nothing can possibly change (the speedup is immense) + # (yes, people could be tie()ing the stash and adding methods on access + # but there is a limit to how much crazy can be supported here) + # + # we use the cache for linear_isa lookups on new MRO as well - it adds + # a *tiny* speedup, and simplifies the code a lot + # + local $mro_recursor_stack->{cache} = {} + unless $mro_recursor_stack->{cache}; + + my $my_gen = 0; + + $my_gen += get_real_pkg_gen($_) for ( + 'UNIVERSAL', + my ($class, @my_ISA) = @{ + $mro_recursor_stack->{cache}{$_[0]}{linear_isa} + ||= + mro::get_linear_isa($_[0]) + } + ); + + my $slot = $describe_class_query_cache->{$class} ||= {}; + + unless ( ($slot->{cumulative_gen}||0) == $my_gen ) { + + # reset + %$slot = ( + class => $class, + isa => [ @my_ISA ], # copy before we shove UNIVERSAL into it + mro => { + type => mro::get_mro($class), + }, + cumulative_gen => $my_gen, + ); + $slot->{mro}{is_c3} = ($slot->{mro}{type} eq 'c3') ? 1 : 0; + + push @my_ISA, 'UNIVERSAL'; + + # ensure the cache is populated for the parents, code below can then + # efficiently operate over the query_cache directly + for (reverse @my_ISA) { + my ($parent_gen, @parent_ISA); + + # and even more skips before calling out recursively + describe_class_methods($_) unless ( + $describe_class_query_cache->{$_}{cumulative_gen} + and + $parent_gen = get_real_pkg_gen($_) + and + ( + ( + (undef, @parent_ISA) = @{ + $mro_recursor_stack->{cache}{$_}{linear_isa} + ||= + mro::get_linear_isa($_) + } + ) == 1 + or + do { + $parent_gen += get_real_pkg_gen($_) for @parent_ISA; + 1; + } + ) + and + $describe_class_query_cache->{$_}{cumulative_gen} == $parent_gen + ); + } + + my ($methods_seen_via_ISA_on_old_mro, $current_node_refaddr); + no strict 'refs'; + + # combine full ISA-order inherited and local method list into a + # "shadowing stack" + + ( + $current_node_refaddr = refaddr($_) + + and + + # on complex MI herarchies the method can be anywhere in the + # shadow stack - look through the entire slot, not just [0] + ( ! grep { + refaddr($_) == $current_node_refaddr + } @{ $slot->{methods}{ $_->{name} } || [] } ) + + and + + unshift @{ $slot->{methods}{$_->{name}} }, $_ + + and + + @{ $slot->{methods}{$_->{name}} } > 1 + + and + + $slot->{methods_with_supers}{$_->{name}} = $slot->{methods}{$_->{name}} + + ) for ( + + # what describe_class_methods for @my_ISA produced above + ( map { $_->[0] } map { + values %{ $describe_class_query_cache->{$_}{methods} } + } reverse @my_ISA ), + + # our own non-cleaned subs + their attributes + ( map { + ( + # these 2 OR-ed checks are sufficient for 5.10+ + ( + ref(\ "${class}::"->{$_} ) ne 'GLOB' + or + defined( *{ "${class}::"->{$_} }{CODE} ) + ) + and + # need to account for dummy helper crefs under OLD_MRO + ( + ! DBIx::Class::_ENV_::OLD_MRO + or + ( + $methods_seen_via_ISA_on_old_mro ||= do { + my $rv = {}; + $rv->{$_->{name}}->{ refaddr( \&{ "$_->{via_class}::$_->{name}"} ) } = 1 for + map { @$_ } map + { values %{ $describe_class_query_cache->{$_}{methods} } } + @my_ISA; + $rv; + } + and + ( + ! $methods_seen_via_ISA_on_old_mro->{$_} + or + ! $methods_seen_via_ISA_on_old_mro->{$_}{ refaddr( \&{"${class}::${_}"} ) } + ) + ) + ) + ) ? { + via_class => $class, + name => $_, + attributes => { map { $_ => 1 } @{ + $mro_recursor_stack->{cache}{attrs}{ refaddr \&{"${class}::${_}"} } + ||= + [ attributes::get( \&{"${class}::${_}"} ) ] + } }, + } + : () + } keys %{"${class}::"} ) + ); + + + # recalculate the pkg_gen on newer perls under Taint mode, + # because of shit like: + # perl -T -Mmro -e 'package Foo; sub bar {}; defined( *{ "Foo::"->{bar}}{CODE} ) and warn mro::get_pkg_gen("Foo") for (1,2,3)' + # + if ( + ! DBIx::Class::_ENV_::OLD_MRO + and + ${^TAINT} + ) { + + $slot->{cumulative_gen} = 0; + $slot->{cumulative_gen} += get_real_pkg_gen($_) + for $class, @my_ISA; + } + } + + # RV + +{ %$slot }; + } +} + # # Why not just use some higher-level module or at least File::Spec here? diff --git a/t/52leaks.t b/t/52leaks.t index fffc942..ae96a21 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -108,6 +108,7 @@ if ( !$ENV{DBICTEST_VIA_REPLICATED} and !DBICTest::RunMode->is_plain ) { require DBI; require DBD::SQLite; require Moo; + require Math::BigInt; %$weak_registry = (); } diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index b107a21..b26f5d5 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -1,3 +1,5 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use warnings; use strict; @@ -22,12 +24,26 @@ BEGIN { use Test::More; use Test::Exception; -use DBIx::Class::_Util qw( quote_sub ); +use DBIx::Class::_Util qw( quote_sub describe_class_methods serialize refdesc ); +use List::Util 'shuffle'; +use Errno (); + +use DBICTest; + +my $pkg_gen_history = {}; + +sub grab_pkg_gen ($) { + push @{ $pkg_gen_history->{$_[0]} }, [ + DBIx::Class::_Util::get_real_pkg_gen($_[0]), + 'line ' . ( (caller(0))[2] ), + ]; +} -require DBIx::Class; @DBICTest::AttrLegacy::ISA = 'DBIx::Class'; sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 } +grab_pkg_gen("DBICTest::AttrLegacy"); + my $var = \42; my $s = quote_sub( 'DBICTest::AttrLegacy::attr', @@ -39,6 +55,8 @@ my $s = quote_sub( }, ); +grab_pkg_gen("DBICTest::AttrLegacy"); + is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed'; is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable'; @@ -47,33 +65,52 @@ is_deeply [ sort( attributes::get( $s ) ) ], [qw( DBIC_random_attr ResultSet )], 'Attribute installed', -unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 +; +{ + package DBICTest::SomeGrandParentClass; + use base 'DBIx::Class::MethodAttributes'; + sub VALID_DBIC_CODE_ATTRIBUTE { shift->next::method(@_) }; +} +{ + package DBICTest::SomeParentClass; + use base qw(DBICTest::SomeGrandParentClass); +} +{ + package DBICTest::AnotherParentClass; + use base 'DBIx::Class::MethodAttributes'; + sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ }; +} -@DBICTest::AttrTest::ISA = 'DBIx::Class'; { - package DBICTest::AttrTest; + package DBICTest::AttrTest; + + @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass ); + use mro 'c3'; + + ::grab_pkg_gen("DBICTest::AttrTest"); - eval <<'EOS' or die $@; - sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ } + eval <<'EOS' or die $@; sub attr :lvalue :method :DBIC_attr1 { $$var} 1; EOS - ::throws_ok { - attributes->import( - 'DBICTest::AttrTest', - DBICTest::AttrTest->can('attr'), - 'DBIC_unknownattr', - ); - } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/; + ::grab_pkg_gen("DBICTest::AttrTest"); + + ::throws_ok { + attributes->import( + 'DBICTest::AttrTest', + DBICTest::AttrTest->can('attr'), + 'DBIC_unknownattr', + ); + } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/; } is_deeply [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], [qw( DBIC_attr1 lvalue method )], 'Attribute installed', -unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 +; ok( ! DBICTest::AttrTest->can('__attr_cache'), @@ -87,6 +124,7 @@ is_deeply( ); sub add_more_attrs { + # Test that secondary attribute application works attributes->import( 'DBICTest::AttrLegacy', @@ -101,11 +139,13 @@ sub add_more_attrs { 'SomethingNobodyUses', ); + grab_pkg_gen("DBICTest::AttrLegacy"); + is_deeply [ sort( attributes::get( $s ) )], [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ], 'Secondary attributes installed', - unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + ; is_deeply ( DBICTest::AttrLegacy->_attr_cache->{$s}, @@ -113,8 +153,6 @@ sub add_more_attrs { 'Attributes visible in legacy DBIC attribute API', ); - - # Test that secondary attribute application works attributes->import( 'DBICTest::AttrTest', @@ -122,6 +160,8 @@ sub add_more_attrs { 'DBIC_attr2', ); + grab_pkg_gen("DBICTest::AttrTest"); + # and that double-application also works attributes->import( 'DBICTest::AttrTest', @@ -130,11 +170,13 @@ sub add_more_attrs { 'DBIC_attr3', ); + grab_pkg_gen("DBICTest::AttrTest"); + is_deeply [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )], 'DBIC-specific attribute installed', - unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + ; ok( ! DBICTest::AttrTest->can('__attr_cache'), @@ -146,27 +188,257 @@ sub add_more_attrs { {}, 'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs' ); -} + # no point dragging in threads::shared, just do the check here + for my $class ( keys %$pkg_gen_history ) { + my $stack = $pkg_gen_history->{$class}; + + for my $i ( 1 .. $#$stack ) { + cmp_ok( + $stack->[$i-1][0], + ( DBIx::Class::_ENV_::OLD_MRO ? '!=' : '<' ), + $stack->[$i][0], + "pkg_gen for $class changed from $stack->[$i-1][1] to $stack->[$i][1]" + ); + } + } + + my $cnt; + # check that class description is stable, and changes when needed + for my $class (qw( + DBICTest::AttrTest + DBICTest::AttrLegacy + DBIx::Class + main + )) { + my $desc = describe_class_methods($class); + + is_deeply( + describe_class_methods($class), + $desc, + "describe_class_methods result is stable over '$class' (pass $_)" + ) for (1,2,3); + + my $desc2 = do { + no warnings 'once'; + no strict 'refs'; + + $cnt++; + + eval "sub UNIVERSAL::some_unimethod_$cnt {}; 1" or die $@; + + my $rv = describe_class_methods($class); + + delete ${"UNIVERSAL::"}{"some_unimethod_$cnt"}; + + $rv + }; + + delete $_->{cumulative_gen} for $desc, $desc2; + ok( + serialize( $desc ) + ne + serialize( $desc2 ), + "touching UNIVERSAL changed '$class' method availability" + ); + } + + my $bottom_most_V_D_C_A = refdesc( + describe_class_methods("DBIx::Class::MethodAttributes") + ->{methods} + ->{VALID_DBIC_CODE_ATTRIBUTE} + ->[0] + ); + + for my $class ( shuffle( qw( + DBICTest::AttrTest + DBICTest::AttrLegacy + DBICTest::SomeGrandParentClass + DBIx::Class::Schema + DBIx::Class::ResultSet + DBICTest::Schema::Track + ))) { + my $desc = describe_class_methods($class); + + is ( + refdesc( $desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ), + $bottom_most_V_D_C_A, + "Same physical structure returned for last VALID_DBIC_CODE_ATTRIBUTE via class $class" + ); + + is ( + refdesc( $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ), + $bottom_most_V_D_C_A, + "Same physical structure returned for bottom-most SUPER of VALID_DBIC_CODE_ATTRIBUTE via class $class" + ) if $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}; + } + + # check that describe_class_methods returns the right stuff + # ( on the simpler class ) + my $expected_AttrTest_ISA = [qw( + DBICTest::SomeParentClass + DBICTest::SomeGrandParentClass + DBICTest::AnotherParentClass + DBIx::Class::MethodAttributes + )]; + + my $expected_desc = { + class => "DBICTest::AttrTest", + + # sum and/or is_deeply are buggy on old List::Util/Test::More + # do the sum by hand ourselves to be sure + cumulative_gen => do { + require Math::BigInt; + my $gen = Math::BigInt->new(0); + + $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for ( + 'UNIVERSAL', + 'DBICTest::AttrTest', + @$expected_AttrTest_ISA, + ); + + $gen; + }, + mro => { + type => 'c3', + is_c3 => 1, + }, + isa => $expected_AttrTest_ISA, + methods => { + FETCH_CODE_ATTRIBUTES => [ + { + attributes => {}, + name => "FETCH_CODE_ATTRIBUTES", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + MODIFY_CODE_ATTRIBUTES => [ + { + attributes => {}, + name => "MODIFY_CODE_ATTRIBUTES", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + VALID_DBIC_CODE_ATTRIBUTE => [ + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBICTest::SomeGrandParentClass", + }, + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBICTest::AnotherParentClass" + }, + { + attributes => {}, + name => "VALID_DBIC_CODE_ATTRIBUTE", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + _attr_cache => [ + { + attributes => {}, + name => "_attr_cache", + via_class => "DBIx::Class::MethodAttributes" + }, + ], + attr => [ + { + attributes => { + DBIC_attr1 => 1, + DBIC_attr2 => 1, + DBIC_attr3 => 1, + lvalue => 1, + method => 1 + }, + name => "attr", + via_class => "DBICTest::AttrTest" + } + ], + can => [ + { + attributes => {}, + name => "can", + via_class => "UNIVERSAL", + }, + ], + isa => [ + { + attributes => {}, + name => "isa", + via_class => "UNIVERSAL", + }, + ], + VERSION => [ + { + attributes => {}, + name => "VERSION", + via_class => "UNIVERSAL", + }, + ], + ( DBIx::Class::_ENV_::OLD_MRO ? () : ( + DOES => [{ + attributes => {}, + name => "DOES", + via_class => "UNIVERSAL", + }], + ) ), + }, + }; + + $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE} + = $expected_desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}; + + is_deeply ( + describe_class_methods("DBICTest::AttrTest"), + $expected_desc, + 'describe_class_methods returns correct data', + ); +} if ($skip_threads) { SKIP: { skip "Skipping the thread test: $skip_threads", 1 } add_more_attrs(); } -else { - threads->create(sub { +else { SKIP: { + + my $t = threads->create(sub { - threads->create(sub { + my $t = threads->create(sub { add_more_attrs(); select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls - })->join; + 42; + + }) || do { + die "Unable to start thread: $!" + unless $! == Errno::EAGAIN(); + + SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 } + + return 42 ; + }; + + my $rv = $t->join; select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls - })->join; -} + $rv; + }) || do { + die "Unable to start thread: $!" + unless $! == Errno::EAGAIN(); + + skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1; + }; + + is ( + $t->join, + 42, + 'Thread stack exitted succesfully' + ); +}} done_testing;