xt/extra/internals/attributes.t

   1 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
   2
   3 use strict;
   4 use warnings;
   5 no warnings 'once';
   6
   7 use Config;
   8 my $skip_threads;
   9 BEGIN {
  10   if( ! $Config{useithreads} ) {
  11     $skip_threads = 'your perl does not support ithreads';
  12   }
  13   elsif( "$]" < 5.008005 ) {
  14     $skip_threads = 'DBIC does not actively support threads before perl 5.8.5';
  15   }
  16   elsif( $INC{'Devel/Cover.pm'} ) {
  17     $skip_threads = 'Devel::Cover does not work with ithreads yet';
  18   }
  19
  20   unless( $skip_threads ) {
  21     require threads;
  22     threads->import;
  23   }
  24 }
  25
  26 use Test::More;
  27 use Test::Exception;
  28 use DBIx::Class::_Util qw( quote_sub describe_class_methods serialize refdesc );
  29 use List::Util 'shuffle';
  30 use Errno ();
  31
  32 use DBICTest;
  33
  34 my $pkg_gen_history = {};
  35
  36 { package UEBERVERSAL; sub ueber {} }
  37 @UNIVERSAL::ISA = "UEBERVERSAL";
  38 sub UNIVERSAL::uni { "unistuff" }
  39
  40 sub grab_pkg_gen ($) {
  41   push @{ $pkg_gen_history->{$_[0]} }, [
  42     DBIx::Class::_Util::get_real_pkg_gen($_[0]),
  43     'line ' . ( (caller(0))[2] ),
  44   ];
  45 }
  46
  47 @DBICTest::AttrLegacy::ISA  = 'DBIx::Class';
  48 sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 }
  49
  50 grab_pkg_gen("DBICTest::AttrLegacy");
  51
  52 my $var = \42;
  53 my $s = quote_sub(
  54   'DBICTest::AttrLegacy::attr',
  55   '$v',
  56   { '$v' => $var },
  57   {
  58     attributes => [qw( ResultSet DBIC_random_attr )],
  59     package => 'DBICTest::AttrLegacy',
  60   },
  61 );
  62
  63 grab_pkg_gen("DBICTest::AttrLegacy");
  64
  65 is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed';
  66
  67 is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable';
  68
  69 is_deeply
  70   [ sort( attributes::get( $s ) ) ],
  71   [qw( DBIC_random_attr ResultSet )],
  72   'Attribute installed',
  73 ;
  74
  75 {
  76   package DBICTest::SomeGrandParentClass;
  77   use base 'DBIx::Class::MethodAttributes';
  78   sub VALID_DBIC_CODE_ATTRIBUTE { shift->next::method(@_) };
  79 }
  80 {
  81   package DBICTest::SomeParentClass;
  82   use base qw(DBICTest::SomeGrandParentClass);
  83 }
  84 {
  85   package DBICTest::AnotherParentClass;
  86   use base 'DBIx::Class::MethodAttributes';
  87   sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ };
  88 }
  89
  90 {
  91   package DBICTest::AttrTest;
  92
  93   @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass );
  94   use mro 'c3';
  95
  96   # pathological case - but can (and sadly does) happen
  97   *VALID_DBIC_CODE_ATTRIBUTE = \&DBICTest::SomeGrandParentClass::VALID_DBIC_CODE_ATTRIBUTE;
  98
  99   ::grab_pkg_gen("DBICTest::AttrTest");
 100
 101   eval <<'EOS' or die $@;
 102       sub attr :lvalue :method :DBIC_attr1 { $$var}
 103       1;
 104 EOS
 105
 106   ::grab_pkg_gen("DBICTest::AttrTest");
 107
 108   ::throws_ok {
 109     attributes->import(
 110       'DBICTest::AttrTest',
 111       DBICTest::AttrTest->can('attr'),
 112       'DBIC_unknownattr',
 113     );
 114   } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/;
 115 }
 116
 117 is_deeply
 118   [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
 119   [qw( DBIC_attr1 lvalue method )],
 120   'Attribute installed',
 121 ;
 122
 123 ok(
 124   ! DBICTest::AttrTest->can('__attr_cache'),
 125   'Inherited classdata never created on core attrs'
 126 );
 127
 128 is_deeply(
 129   DBICTest::AttrTest->_attr_cache,
 130   {},
 131   'Cache never instantiated on core attrs'
 132 );
 133
 134 sub add_more_attrs {
 135
 136   # Test that secondary attribute application works
 137   attributes->import(
 138     'DBICTest::AttrLegacy',
 139     DBICTest::AttrLegacy->can('attr'),
 140     'SomethingNobodyUses',
 141   );
 142
 143   # and that double-application also works
 144   attributes->import(
 145     'DBICTest::AttrLegacy',
 146     DBICTest::AttrLegacy->can('attr'),
 147     'SomethingNobodyUses',
 148   );
 149
 150   grab_pkg_gen("DBICTest::AttrLegacy");
 151
 152   is_deeply
 153     [ sort( attributes::get( $s ) )],
 154     [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ],
 155     'Secondary attributes installed',
 156   ;
 157
 158   is_deeply (
 159     DBICTest::AttrLegacy->_attr_cache->{$s},
 160     [ qw( ResultSet SomethingNobodyUses ) ],
 161     'Attributes visible in legacy DBIC attribute API',
 162   );
 163
 164   # Test that secondary attribute application works
 165   attributes->import(
 166     'DBICTest::AttrTest',
 167     DBICTest::AttrTest->can('attr'),
 168     'DBIC_attr2',
 169   );
 170
 171   grab_pkg_gen("DBICTest::AttrTest");
 172
 173   # and that double-application also works
 174   attributes->import(
 175     'DBICTest::AttrTest',
 176     DBICTest::AttrTest->can('attr'),
 177     'DBIC_attr2',
 178     'DBIC_attr3',
 179   );
 180
 181   grab_pkg_gen("DBICTest::AttrTest");
 182
 183   is_deeply
 184     [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
 185     [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )],
 186     'DBIC-specific attribute installed',
 187   ;
 188
 189   ok(
 190     ! DBICTest::AttrTest->can('__attr_cache'),
 191     'Inherited classdata never created on core+DBIC-specific attrs'
 192   );
 193
 194   is_deeply(
 195     DBICTest::AttrTest->_attr_cache,
 196     {},
 197     'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs'
 198   );
 199
 200   # no point dragging in threads::shared, just do the check here
 201   for my $class ( keys %$pkg_gen_history ) {
 202     my $stack = $pkg_gen_history->{$class};
 203
 204     for my $i ( 1 .. $#$stack ) {
 205       cmp_ok(
 206         $stack->[$i-1][0],
 207           ( DBIx::Class::_ENV_::OLD_MRO ? '!=' : '<' ),
 208         $stack->[$i][0],
 209         "pkg_gen for $class changed from $stack->[$i-1][1] to $stack->[$i][1]"
 210       );
 211     }
 212   }
 213
 214   my $cnt;
 215   # check that class description is stable, and changes when needed
 216   #
 217   # FIXME - this list used to contain 'main', but that started failing as
 218   # of the commit introducing this line with bizarre "unstable gen" errors
 219   # Punting for the time being - will fix at some point in the future
 220   #
 221   for my $class (qw(
 222     DBICTest::AttrTest
 223     DBICTest::AttrLegacy
 224     DBIx::Class
 225   )) {
 226     my $desc = describe_class_methods($class);
 227
 228     is_deeply(
 229       describe_class_methods($class),
 230       $desc,
 231       "describe_class_methods result is stable over '$class' (pass $_)"
 232     ) for (1,2,3);
 233
 234     my $desc2 = do {
 235       no strict 'refs';
 236
 237       $cnt++;
 238
 239       eval "sub UEBERVERSAL::some_unimethod_$cnt {}; 1" or die $@;
 240
 241       my $rv = describe_class_methods($class);
 242
 243       delete ${"UEBERVERSAL::"}{"some_unimethod_$cnt"};
 244
 245       $rv
 246     };
 247
 248     delete $_->{cumulative_gen} for $desc, $desc2;
 249     ok(
 250       serialize( $desc )
 251         ne
 252       serialize( $desc2 ),
 253       "touching UNIVERSAL changed '$class' method availability"
 254     );
 255   }
 256
 257   my $bottom_most_V_D_C_A = refdesc(
 258     describe_class_methods("DBIx::Class::MethodAttributes")
 259      ->{methods}
 260       ->{VALID_DBIC_CODE_ATTRIBUTE}
 261        ->[0]
 262   );
 263
 264   for my $class ( shuffle( qw(
 265     DBICTest::AttrTest
 266     DBICTest::AttrLegacy
 267     DBICTest::SomeGrandParentClass
 268     DBIx::Class::Schema
 269     DBIx::Class::ResultSet
 270     DBICTest::Schema::Track
 271   ))) {
 272     my $desc = describe_class_methods($class);
 273
 274     is (
 275       refdesc( $desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
 276       $bottom_most_V_D_C_A,
 277       "Same physical structure returned for last VALID_DBIC_CODE_ATTRIBUTE via class $class"
 278     );
 279
 280     is (
 281       refdesc( $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
 282       $bottom_most_V_D_C_A,
 283       "Same physical structure returned for bottom-most SUPER of VALID_DBIC_CODE_ATTRIBUTE via class $class"
 284     ) if $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE};
 285   }
 286
 287   # check that describe_class_methods returns the right stuff
 288   # ( on the simpler class )
 289   my $expected_AttrTest_ISA = [qw(
 290     DBICTest::SomeParentClass
 291     DBICTest::SomeGrandParentClass
 292     DBICTest::AnotherParentClass
 293     DBIx::Class::MethodAttributes
 294   )];
 295
 296   my $expected_desc = {
 297     class => "DBICTest::AttrTest",
 298
 299     # sum and/or is_deeply are buggy on old List::Util/Test::More
 300     # do the sum by hand ourselves to be sure
 301     cumulative_gen => do {
 302       require Math::BigInt;
 303       my $gen = Math::BigInt->new(0);
 304
 305       $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for (
 306         'UEBERVERSAL',
 307         'UNIVERSAL',
 308         'DBICTest::AttrTest',
 309         @$expected_AttrTest_ISA,
 310       );
 311
 312       $gen;
 313     },
 314     mro => {
 315       type => 'c3',
 316       is_c3 => 1,
 317     },
 318     isa => $expected_AttrTest_ISA,
 319     methods => {
 320       FETCH_CODE_ATTRIBUTES => [
 321         {
 322           attributes => {},
 323           name => "FETCH_CODE_ATTRIBUTES",
 324           via_class => "DBIx::Class::MethodAttributes"
 325         },
 326       ],
 327       MODIFY_CODE_ATTRIBUTES => [
 328         {
 329           attributes => {},
 330           name => "MODIFY_CODE_ATTRIBUTES",
 331           via_class => "DBIx::Class::MethodAttributes"
 332         },
 333       ],
 334       VALID_DBIC_CODE_ATTRIBUTE => ( my $V_D_C_A_stack = [
 335         {
 336           attributes => {},
 337           name => 'VALID_DBIC_CODE_ATTRIBUTE',
 338           via_class => 'DBICTest::AttrTest'
 339         },
 340         {
 341           attributes => {},
 342           name => "VALID_DBIC_CODE_ATTRIBUTE",
 343           via_class => "DBICTest::SomeGrandParentClass",
 344         },
 345         {
 346           attributes => {},
 347           name => "VALID_DBIC_CODE_ATTRIBUTE",
 348           via_class => "DBICTest::AnotherParentClass"
 349         },
 350         {
 351           attributes => {},
 352           name => "VALID_DBIC_CODE_ATTRIBUTE",
 353           via_class => "DBIx::Class::MethodAttributes"
 354         },
 355       ]),
 356       _attr_cache => [
 357         {
 358           attributes => {},
 359           name => "_attr_cache",
 360           via_class => "DBIx::Class::MethodAttributes"
 361         },
 362       ],
 363       attr => [
 364         {
 365           attributes => {
 366             DBIC_attr1 => 1,
 367             DBIC_attr2 => 1,
 368             DBIC_attr3 => 1,
 369             lvalue => 1,
 370             method => 1
 371           },
 372           name => "attr",
 373           via_class => "DBICTest::AttrTest"
 374         }
 375       ],
 376       ueber => [
 377         {
 378           attributes => {},
 379           name => "ueber",
 380           via_class => "UEBERVERSAL",
 381         }
 382       ],
 383       uni => [
 384         {
 385           attributes => {},
 386           name => "uni",
 387           via_class => "UNIVERSAL",
 388         }
 389       ],
 390       can => [
 391         {
 392           attributes => {},
 393           name => "can",
 394           via_class => "UNIVERSAL",
 395         },
 396       ],
 397       isa => [
 398         {
 399           attributes => {},
 400           name => "isa",
 401           via_class => "UNIVERSAL",
 402         },
 403       ],
 404       VERSION => [
 405         {
 406           attributes => {},
 407           name => "VERSION",
 408           via_class => "UNIVERSAL",
 409         },
 410       ],
 411       ( DBIx::Class::_ENV_::OLD_MRO ? () : (
 412         DOES => [{
 413           attributes => {},
 414           name => "DOES",
 415           via_class => "UNIVERSAL",
 416         }],
 417       ) ),
 418     },
 419   };
 420
 421   $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}
 422     = $V_D_C_A_stack;
 423
 424   $expected_desc->{methods_defined_in_class}{VALID_DBIC_CODE_ATTRIBUTE}
 425     = $V_D_C_A_stack->[0];
 426
 427   $expected_desc->{methods_defined_in_class}{attr}
 428     = $expected_desc->{methods}{attr}[0];
 429
 430   is_deeply (
 431     describe_class_methods("DBICTest::AttrTest"),
 432     $expected_desc,
 433     'describe_class_methods returns correct data',
 434   );
 435
 436   # ensure that asking with a different MRO will not perturb the cache
 437   my $cached_desc = serialize(
 438     $DBIx::Class::_Util::describe_class_query_cache->{"DBICTest::AttrTest|c3"}
 439   );
 440
 441   # now try to ask for DFS explicitly, adjust our expectations
 442   $expected_desc->{mro} = { type => 'dfs', is_c3 => 0 };
 443
 444   # due to DFS the last 2 entries of ISA and the VALID_DBIC_CODE_ATTRIBUTE
 445   # sourcing-list will change places
 446   splice @$_, -2, 2, @{$_}[-1, -2]
 447     for $V_D_C_A_stack, $expected_AttrTest_ISA;
 448
 449   is_deeply (
 450     # work around taint, see TODO below
 451     {
 452       %{describe_class_methods("DBICTest::AttrTest", "dfs")},
 453       cumulative_gen => $expected_desc->{cumulative_gen},
 454     },
 455     $expected_desc,
 456     'describing with explicit mro returns correct data'
 457   );
 458
 459   # FIXME: TODO does not work on new T::B under threads sigh
 460   # https://github.com/Test-More/test-more/issues/683
 461   unless(
 462     ! DBIx::Class::_ENV_::OLD_MRO
 463       and
 464     ${^TAINT}
 465   ) {
 466     #local $TODO = "On 5.10+ -T combined with stash peeking invalidates the pkg_gen (wtf)" if ...
 467
 468     ok(
 469       (
 470         serialize( describe_class_methods("DBICTest::AttrTest") )
 471           eq
 472         $cached_desc
 473       ),
 474       "Asking for alternative mro type did not invalidate cache"
 475     );
 476   }
 477
 478   # setting mro explicitly still matches what we expect
 479   mro::set_mro("DBICTest::AttrTest", "dfs");
 480
 481   is_deeply (
 482     # in case set_mro starts increasing pkg_gen...
 483     {
 484       %{describe_class_methods("DBICTest::AttrTest")},
 485       cumulative_gen => $expected_desc->{cumulative_gen},
 486     },
 487     $expected_desc,
 488     'describing with implicit mro returns correct data'
 489   );
 490
 491   # check that a UNIVERSAL-parent interrogation makes sense
 492   # ( it should not list anything from UNIVERSAL itself )
 493   is_deeply (
 494     describe_class_methods("UEBERVERSAL"),
 495     {
 496       # should be cached by now, thus safe to rely on...?
 497       cumulative_gen => DBIx::Class::_Util::get_real_pkg_gen('UEBERVERSAL'),
 498
 499       class => 'UEBERVERSAL',
 500       mro => { is_c3 => 0, type => 'dfs' },
 501       isa => [],
 502       methods => {
 503         ueber => $expected_desc->{methods}{ueber}
 504       },
 505       methods_defined_in_class => {
 506         ueber => $expected_desc->{methods}{ueber}[0]
 507       },
 508     },
 509     "Expected description of a parent-of-UNIVERSAL class (pathological case)",
 510   );
 511 }
 512
 513 if ($skip_threads) {
 514   SKIP: { skip "Skipping the thread test: $skip_threads", 1 }
 515
 516   add_more_attrs();
 517 }
 518 else { SKIP: {
 519
 520   my $t = threads->create(sub {
 521
 522     my $t = threads->create(sub {
 523
 524       add_more_attrs();
 525       select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 526
 527       42;
 528
 529     }) || do {
 530       die "Unable to start thread: $!"
 531         unless $! == Errno::EAGAIN();
 532
 533       SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 }
 534
 535       return 42 ;
 536     };
 537
 538     my $rv = $t->join;
 539
 540     select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 541
 542     $rv;
 543   }) || do {
 544     die "Unable to start thread: $!"
 545       unless $! == Errno::EAGAIN();
 546
 547     skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1;
 548   };
 549
 550   is (
 551     $t->join,
 552     42,
 553     'Thread stack exitted succesfully'
 554   );
 555 }}
 556
 557 # this doesn't really belong in this test, but screw it
 558 {
 559   package DBICTest::WackyDFS;
 560   use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass );
 561 }
 562
 563 is_deeply
 564   describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE},
 565   [
 566     {
 567       attributes => {},
 568       name => "VALID_DBIC_CODE_ATTRIBUTE",
 569       via_class => "DBICTest::SomeGrandParentClass",
 570     },
 571     {
 572       attributes => {},
 573       name => "VALID_DBIC_CODE_ATTRIBUTE",
 574       via_class => "DBIx::Class::MethodAttributes"
 575     },
 576   ],
 577   'Expected description on unusable inheritance hierarchy'
 578 ;
 579
 580 done_testing;