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_linear_ISA = [qw(
 290     DBICTest::SomeParentClass
 291     DBICTest::SomeGrandParentClass
 292     DBICTest::AnotherParentClass
 293     DBIx::Class::MethodAttributes
 294   )];
 295
 296   my $expected_AttrTest_full_ISA = { map { $_ => 1 } (
 297     qw( UEBERVERSAL UNIVERSAL DBICTest::AttrTest ),
 298     @$expected_AttrTest_linear_ISA,
 299   )};
 300
 301   my $expected_desc = {
 302     class => "DBICTest::AttrTest",
 303
 304     # sum and/or is_deeply are buggy on old List::Util/Test::More
 305     # do the sum by hand ourselves to be sure
 306     cumulative_gen => do {
 307       require Math::BigInt;
 308       my $gen = Math::BigInt->new(0);
 309
 310       $gen += DBIx::Class::_Util::get_real_pkg_gen($_)
 311         for keys %$expected_AttrTest_full_ISA;
 312
 313       $gen;
 314     },
 315     mro => {
 316       type => 'c3',
 317       is_c3 => 1,
 318     },
 319     linear_isa => $expected_AttrTest_linear_ISA,
 320     isa => $expected_AttrTest_full_ISA,
 321     methods => {
 322       FETCH_CODE_ATTRIBUTES => [
 323         {
 324           attributes => {},
 325           name => "FETCH_CODE_ATTRIBUTES",
 326           via_class => "DBIx::Class::MethodAttributes"
 327         },
 328       ],
 329       MODIFY_CODE_ATTRIBUTES => [
 330         {
 331           attributes => {},
 332           name => "MODIFY_CODE_ATTRIBUTES",
 333           via_class => "DBIx::Class::MethodAttributes"
 334         },
 335       ],
 336       VALID_DBIC_CODE_ATTRIBUTE => ( my $V_D_C_A_stack = [
 337         {
 338           attributes => {},
 339           name => 'VALID_DBIC_CODE_ATTRIBUTE',
 340           via_class => 'DBICTest::AttrTest'
 341         },
 342         {
 343           attributes => {},
 344           name => "VALID_DBIC_CODE_ATTRIBUTE",
 345           via_class => "DBICTest::SomeGrandParentClass",
 346         },
 347         {
 348           attributes => {},
 349           name => "VALID_DBIC_CODE_ATTRIBUTE",
 350           via_class => "DBICTest::AnotherParentClass"
 351         },
 352         {
 353           attributes => {},
 354           name => "VALID_DBIC_CODE_ATTRIBUTE",
 355           via_class => "DBIx::Class::MethodAttributes"
 356         },
 357       ]),
 358       _attr_cache => [
 359         {
 360           attributes => {},
 361           name => "_attr_cache",
 362           via_class => "DBIx::Class::MethodAttributes"
 363         },
 364       ],
 365       attr => [
 366         {
 367           attributes => {
 368             DBIC_attr1 => 1,
 369             DBIC_attr2 => 1,
 370             DBIC_attr3 => 1,
 371             lvalue => 1,
 372             method => 1
 373           },
 374           name => "attr",
 375           via_class => "DBICTest::AttrTest"
 376         }
 377       ],
 378       ueber => [
 379         {
 380           attributes => {},
 381           name => "ueber",
 382           via_class => "UEBERVERSAL",
 383         }
 384       ],
 385       uni => [
 386         {
 387           attributes => {},
 388           name => "uni",
 389           via_class => "UNIVERSAL",
 390         }
 391       ],
 392       can => [
 393         {
 394           attributes => {},
 395           name => "can",
 396           via_class => "UNIVERSAL",
 397         },
 398       ],
 399       isa => [
 400         {
 401           attributes => {},
 402           name => "isa",
 403           via_class => "UNIVERSAL",
 404         },
 405       ],
 406       VERSION => [
 407         {
 408           attributes => {},
 409           name => "VERSION",
 410           via_class => "UNIVERSAL",
 411         },
 412       ],
 413       ( DBIx::Class::_ENV_::OLD_MRO ? () : (
 414         DOES => [{
 415           attributes => {},
 416           name => "DOES",
 417           via_class => "UNIVERSAL",
 418         }],
 419       ) ),
 420     },
 421   };
 422
 423   $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}
 424     = $V_D_C_A_stack;
 425
 426   $expected_desc->{methods_defined_in_class}{VALID_DBIC_CODE_ATTRIBUTE}
 427     = $V_D_C_A_stack->[0];
 428
 429   $expected_desc->{methods_defined_in_class}{attr}
 430     = $expected_desc->{methods}{attr}[0];
 431
 432   is_deeply (
 433     describe_class_methods("DBICTest::AttrTest"),
 434     $expected_desc,
 435     'describe_class_methods returns correct data',
 436   );
 437
 438   # ensure that asking with a different MRO will not perturb the cache
 439   my $cached_desc = serialize(
 440     $DBIx::Class::_Util::describe_class_query_cache->{"DBICTest::AttrTest|c3"}
 441   );
 442
 443   # now try to ask for DFS explicitly, adjust our expectations
 444   $expected_desc->{mro} = { type => 'dfs', is_c3 => 0 };
 445
 446   # due to DFS the last 2 entries of ISA and the VALID_DBIC_CODE_ATTRIBUTE
 447   # sourcing-list will change places
 448   splice @$_, -2, 2, @{$_}[-1, -2]
 449     for $V_D_C_A_stack, $expected_AttrTest_linear_ISA;
 450
 451   is_deeply (
 452     # work around taint, see TODO below
 453     {
 454       %{ describe_class_methods({ class => "DBICTest::AttrTest", use_mro => "dfs" }) },
 455       cumulative_gen => $expected_desc->{cumulative_gen},
 456     },
 457     $expected_desc,
 458     'describing with explicit mro returns correct data'
 459   );
 460
 461   # FIXME: TODO does not work on new T::B under threads sigh
 462   # https://github.com/Test-More/test-more/issues/683
 463   unless(
 464     ! DBIx::Class::_ENV_::OLD_MRO
 465       and
 466     ${^TAINT}
 467   ) {
 468     #local $TODO = "On 5.10+ -T combined with stash peeking invalidates the pkg_gen (wtf)" if ...
 469
 470     ok(
 471       (
 472         serialize( describe_class_methods("DBICTest::AttrTest") )
 473           eq
 474         $cached_desc
 475       ),
 476       "Asking for alternative mro type did not invalidate cache"
 477     );
 478   }
 479
 480   # setting mro explicitly still matches what we expect
 481   mro::set_mro("DBICTest::AttrTest", "dfs");
 482
 483   is_deeply (
 484     # in case set_mro starts increasing pkg_gen...
 485     {
 486       %{describe_class_methods("DBICTest::AttrTest")},
 487       cumulative_gen => $expected_desc->{cumulative_gen},
 488     },
 489     $expected_desc,
 490     'describing with implicit mro returns correct data'
 491   );
 492
 493   # check that a UNIVERSAL-parent interrogation makes sense
 494   # ( it should not list anything from UNIVERSAL itself )
 495   is_deeply (
 496     describe_class_methods("UEBERVERSAL"),
 497     {
 498       # should be cached by now, thus safe to rely on...?
 499       cumulative_gen => DBIx::Class::_Util::get_real_pkg_gen('UEBERVERSAL'),
 500
 501       class => 'UEBERVERSAL',
 502       mro => { is_c3 => 0, type => 'dfs' },
 503       isa => { UEBERVERSAL => 1 },
 504       linear_isa => [],
 505       methods => {
 506         ueber => $expected_desc->{methods}{ueber}
 507       },
 508       methods_defined_in_class => {
 509         ueber => $expected_desc->{methods}{ueber}[0]
 510       },
 511     },
 512     "Expected description of a parent-of-UNIVERSAL class (pathological case)",
 513   );
 514 }
 515
 516 if ($skip_threads) {
 517   SKIP: { skip "Skipping the thread test: $skip_threads", 1 }
 518
 519   add_more_attrs();
 520 }
 521 else { SKIP: {
 522
 523   my $t = threads->create(sub {
 524
 525     my $t = threads->create(sub {
 526
 527       add_more_attrs();
 528       select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 529
 530       42;
 531
 532     }) || do {
 533       die "Unable to start thread: $!"
 534         unless $! == Errno::EAGAIN();
 535
 536       SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 }
 537
 538       return 42 ;
 539     };
 540
 541     my $rv = $t->join;
 542
 543     select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 544
 545     $rv;
 546   }) || do {
 547     die "Unable to start thread: $!"
 548       unless $! == Errno::EAGAIN();
 549
 550     skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1;
 551   };
 552
 553   is (
 554     $t->join,
 555     42,
 556     'Thread stack exitted succesfully'
 557   );
 558 }}
 559
 560 # this doesn't really belong in this test, but screw it
 561 {
 562   package DBICTest::WackyDFS;
 563   use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass );
 564 }
 565
 566 is_deeply
 567   describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE},
 568   [
 569     {
 570       attributes => {},
 571       name => "VALID_DBIC_CODE_ATTRIBUTE",
 572       via_class => "DBICTest::SomeGrandParentClass",
 573     },
 574     {
 575       attributes => {},
 576       name => "VALID_DBIC_CODE_ATTRIBUTE",
 577       via_class => "DBIx::Class::MethodAttributes"
 578     },
 579   ],
 580   'Expected description on unusable inheritance hierarchy'
 581 ;
 582
 583 done_testing;