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