xt/extra/internals/attributes.t

   1 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
   2
   3 use warnings;
   4 use strict;
   5
   6 use Config;
   7 my $skip_threads;
   8 BEGIN {
   9   if( ! $Config{useithreads} ) {
  10     $skip_threads = 'your perl does not support ithreads';
  11   }
  12   elsif( "$]" < 5.008005 ) {
  13     $skip_threads = 'DBIC does not actively support threads before perl 5.8.5';
  14   }
  15   elsif( $INC{'Devel/Cover.pm'} ) {
  16     $skip_threads = 'Devel::Cover does not work with ithreads yet';
  17   }
  18
  19   unless( $skip_threads ) {
  20     require threads;
  21     threads->import;
  22   }
  23 }
  24
  25 use Test::More;
  26 use Test::Exception;
  27 use DBIx::Class::_Util qw( quote_sub describe_class_methods serialize refdesc );
  28 use List::Util 'shuffle';
  29 use Errno ();
  30
  31 use DBICTest;
  32
  33 my $pkg_gen_history = {};
  34
  35 { package UEBERVERSAL; sub ueber {} }
  36 @UNIVERSAL::ISA = "UEBERVERSAL";
  37
  38 sub grab_pkg_gen ($) {
  39   push @{ $pkg_gen_history->{$_[0]} }, [
  40     DBIx::Class::_Util::get_real_pkg_gen($_[0]),
  41     'line ' . ( (caller(0))[2] ),
  42   ];
  43 }
  44
  45 @DBICTest::AttrLegacy::ISA  = 'DBIx::Class';
  46 sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 }
  47
  48 grab_pkg_gen("DBICTest::AttrLegacy");
  49
  50 my $var = \42;
  51 my $s = quote_sub(
  52   'DBICTest::AttrLegacy::attr',
  53   '$v',
  54   { '$v' => $var },
  55   {
  56     attributes => [qw( ResultSet DBIC_random_attr )],
  57     package => 'DBICTest::AttrLegacy',
  58   },
  59 );
  60
  61 grab_pkg_gen("DBICTest::AttrLegacy");
  62
  63 is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed';
  64
  65 is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable';
  66
  67 is_deeply
  68   [ sort( attributes::get( $s ) ) ],
  69   [qw( DBIC_random_attr ResultSet )],
  70   'Attribute installed',
  71 ;
  72
  73 {
  74   package DBICTest::SomeGrandParentClass;
  75   use base 'DBIx::Class::MethodAttributes';
  76   sub VALID_DBIC_CODE_ATTRIBUTE { shift->next::method(@_) };
  77 }
  78 {
  79   package DBICTest::SomeParentClass;
  80   use base qw(DBICTest::SomeGrandParentClass);
  81 }
  82 {
  83   package DBICTest::AnotherParentClass;
  84   use base 'DBIx::Class::MethodAttributes';
  85   sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ };
  86 }
  87
  88 {
  89   package DBICTest::AttrTest;
  90
  91   @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass );
  92   use mro 'c3';
  93
  94   ::grab_pkg_gen("DBICTest::AttrTest");
  95
  96   eval <<'EOS' or die $@;
  97       sub attr :lvalue :method :DBIC_attr1 { $$var}
  98       1;
  99 EOS
 100
 101   ::grab_pkg_gen("DBICTest::AttrTest");
 102
 103   ::throws_ok {
 104     attributes->import(
 105       'DBICTest::AttrTest',
 106       DBICTest::AttrTest->can('attr'),
 107       'DBIC_unknownattr',
 108     );
 109   } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/;
 110 }
 111
 112 is_deeply
 113   [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
 114   [qw( DBIC_attr1 lvalue method )],
 115   'Attribute installed',
 116 ;
 117
 118 ok(
 119   ! DBICTest::AttrTest->can('__attr_cache'),
 120   'Inherited classdata never created on core attrs'
 121 );
 122
 123 is_deeply(
 124   DBICTest::AttrTest->_attr_cache,
 125   {},
 126   'Cache never instantiated on core attrs'
 127 );
 128
 129 sub add_more_attrs {
 130
 131   # Test that secondary attribute application works
 132   attributes->import(
 133     'DBICTest::AttrLegacy',
 134     DBICTest::AttrLegacy->can('attr'),
 135     'SomethingNobodyUses',
 136   );
 137
 138   # and that double-application also works
 139   attributes->import(
 140     'DBICTest::AttrLegacy',
 141     DBICTest::AttrLegacy->can('attr'),
 142     'SomethingNobodyUses',
 143   );
 144
 145   grab_pkg_gen("DBICTest::AttrLegacy");
 146
 147   is_deeply
 148     [ sort( attributes::get( $s ) )],
 149     [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ],
 150     'Secondary attributes installed',
 151   ;
 152
 153   is_deeply (
 154     DBICTest::AttrLegacy->_attr_cache->{$s},
 155     [ qw( ResultSet SomethingNobodyUses ) ],
 156     'Attributes visible in legacy DBIC attribute API',
 157   );
 158
 159   # Test that secondary attribute application works
 160   attributes->import(
 161     'DBICTest::AttrTest',
 162     DBICTest::AttrTest->can('attr'),
 163     'DBIC_attr2',
 164   );
 165
 166   grab_pkg_gen("DBICTest::AttrTest");
 167
 168   # and that double-application also works
 169   attributes->import(
 170     'DBICTest::AttrTest',
 171     DBICTest::AttrTest->can('attr'),
 172     'DBIC_attr2',
 173     'DBIC_attr3',
 174   );
 175
 176   grab_pkg_gen("DBICTest::AttrTest");
 177
 178   is_deeply
 179     [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
 180     [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )],
 181     'DBIC-specific attribute installed',
 182   ;
 183
 184   ok(
 185     ! DBICTest::AttrTest->can('__attr_cache'),
 186     'Inherited classdata never created on core+DBIC-specific attrs'
 187   );
 188
 189   is_deeply(
 190     DBICTest::AttrTest->_attr_cache,
 191     {},
 192     'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs'
 193   );
 194
 195   # no point dragging in threads::shared, just do the check here
 196   for my $class ( keys %$pkg_gen_history ) {
 197     my $stack = $pkg_gen_history->{$class};
 198
 199     for my $i ( 1 .. $#$stack ) {
 200       cmp_ok(
 201         $stack->[$i-1][0],
 202           ( DBIx::Class::_ENV_::OLD_MRO ? '!=' : '<' ),
 203         $stack->[$i][0],
 204         "pkg_gen for $class changed from $stack->[$i-1][1] to $stack->[$i][1]"
 205       );
 206     }
 207   }
 208
 209   my $cnt;
 210   # check that class description is stable, and changes when needed
 211   for my $class (qw(
 212     DBICTest::AttrTest
 213     DBICTest::AttrLegacy
 214     DBIx::Class
 215     main
 216   )) {
 217     my $desc = describe_class_methods($class);
 218
 219     is_deeply(
 220       describe_class_methods($class),
 221       $desc,
 222       "describe_class_methods result is stable over '$class' (pass $_)"
 223     ) for (1,2,3);
 224
 225     my $desc2 = do {
 226       no warnings 'once';
 227       no strict 'refs';
 228
 229       $cnt++;
 230
 231       eval "sub UEBERVERSAL::some_unimethod_$cnt {}; 1" or die $@;
 232
 233       my $rv = describe_class_methods($class);
 234
 235       delete ${"UEBERVERSAL::"}{"some_unimethod_$cnt"};
 236
 237       $rv
 238     };
 239
 240     delete $_->{cumulative_gen} for $desc, $desc2;
 241     ok(
 242       serialize( $desc )
 243         ne
 244       serialize( $desc2 ),
 245       "touching UNIVERSAL changed '$class' method availability"
 246     );
 247   }
 248
 249   my $bottom_most_V_D_C_A = refdesc(
 250     describe_class_methods("DBIx::Class::MethodAttributes")
 251      ->{methods}
 252       ->{VALID_DBIC_CODE_ATTRIBUTE}
 253        ->[0]
 254   );
 255
 256   for my $class ( shuffle( qw(
 257     DBICTest::AttrTest
 258     DBICTest::AttrLegacy
 259     DBICTest::SomeGrandParentClass
 260     DBIx::Class::Schema
 261     DBIx::Class::ResultSet
 262     DBICTest::Schema::Track
 263   ))) {
 264     my $desc = describe_class_methods($class);
 265
 266     is (
 267       refdesc( $desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
 268       $bottom_most_V_D_C_A,
 269       "Same physical structure returned for last VALID_DBIC_CODE_ATTRIBUTE via class $class"
 270     );
 271
 272     is (
 273       refdesc( $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
 274       $bottom_most_V_D_C_A,
 275       "Same physical structure returned for bottom-most SUPER of VALID_DBIC_CODE_ATTRIBUTE via class $class"
 276     ) if $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE};
 277   }
 278
 279   # check that describe_class_methods returns the right stuff
 280   # ( on the simpler class )
 281   my $expected_AttrTest_ISA = [qw(
 282     DBICTest::SomeParentClass
 283     DBICTest::SomeGrandParentClass
 284     DBICTest::AnotherParentClass
 285     DBIx::Class::MethodAttributes
 286   )];
 287
 288   my $expected_desc = {
 289     class => "DBICTest::AttrTest",
 290
 291     # sum and/or is_deeply are buggy on old List::Util/Test::More
 292     # do the sum by hand ourselves to be sure
 293     cumulative_gen => do {
 294       require Math::BigInt;
 295       my $gen = Math::BigInt->new(0);
 296
 297       $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for (
 298         'UEBERVERSAL',
 299         'UNIVERSAL',
 300         'DBICTest::AttrTest',
 301         @$expected_AttrTest_ISA,
 302       );
 303
 304       $gen;
 305     },
 306     mro => {
 307       type => 'c3',
 308       is_c3 => 1,
 309     },
 310     isa => $expected_AttrTest_ISA,
 311     methods => {
 312       FETCH_CODE_ATTRIBUTES => [
 313         {
 314           attributes => {},
 315           name => "FETCH_CODE_ATTRIBUTES",
 316           via_class => "DBIx::Class::MethodAttributes"
 317         },
 318       ],
 319       MODIFY_CODE_ATTRIBUTES => [
 320         {
 321           attributes => {},
 322           name => "MODIFY_CODE_ATTRIBUTES",
 323           via_class => "DBIx::Class::MethodAttributes"
 324         },
 325       ],
 326       VALID_DBIC_CODE_ATTRIBUTE => [
 327         {
 328           attributes => {},
 329           name => "VALID_DBIC_CODE_ATTRIBUTE",
 330           via_class => "DBICTest::SomeGrandParentClass",
 331         },
 332         {
 333           attributes => {},
 334           name => "VALID_DBIC_CODE_ATTRIBUTE",
 335           via_class => "DBICTest::AnotherParentClass"
 336         },
 337         {
 338           attributes => {},
 339           name => "VALID_DBIC_CODE_ATTRIBUTE",
 340           via_class => "DBIx::Class::MethodAttributes"
 341         },
 342       ],
 343       _attr_cache => [
 344         {
 345           attributes => {},
 346           name => "_attr_cache",
 347           via_class => "DBIx::Class::MethodAttributes"
 348         },
 349       ],
 350       attr => [
 351         {
 352           attributes => {
 353             DBIC_attr1 => 1,
 354             DBIC_attr2 => 1,
 355             DBIC_attr3 => 1,
 356             lvalue => 1,
 357             method => 1
 358           },
 359           name => "attr",
 360           via_class => "DBICTest::AttrTest"
 361         }
 362       ],
 363       ueber => [
 364         {
 365           attributes => {},
 366           name => "ueber",
 367           via_class => "UEBERVERSAL",
 368         }
 369       ],
 370       can => [
 371         {
 372           attributes => {},
 373           name => "can",
 374           via_class => "UNIVERSAL",
 375         },
 376       ],
 377       isa => [
 378         {
 379           attributes => {},
 380           name => "isa",
 381           via_class => "UNIVERSAL",
 382         },
 383       ],
 384       VERSION => [
 385         {
 386           attributes => {},
 387           name => "VERSION",
 388           via_class => "UNIVERSAL",
 389         },
 390       ],
 391       ( DBIx::Class::_ENV_::OLD_MRO ? () : (
 392         DOES => [{
 393           attributes => {},
 394           name => "DOES",
 395           via_class => "UNIVERSAL",
 396         }],
 397       ) ),
 398     },
 399   };
 400
 401   $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}
 402     = $expected_desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE};
 403
 404   $expected_desc->{methods_defined_in_class}{attr}
 405     = $expected_desc->{methods}{attr}[0];
 406
 407   is_deeply (
 408     describe_class_methods("DBICTest::AttrTest"),
 409     $expected_desc,
 410     'describe_class_methods returns correct data',
 411   );
 412 }
 413
 414 if ($skip_threads) {
 415   SKIP: { skip "Skipping the thread test: $skip_threads", 1 }
 416
 417   add_more_attrs();
 418 }
 419 else { SKIP: {
 420
 421   my $t = threads->create(sub {
 422
 423     my $t = threads->create(sub {
 424
 425       add_more_attrs();
 426       select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 427
 428       42;
 429
 430     }) || do {
 431       die "Unable to start thread: $!"
 432         unless $! == Errno::EAGAIN();
 433
 434       SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 }
 435
 436       return 42 ;
 437     };
 438
 439     my $rv = $t->join;
 440
 441     select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 442
 443     $rv;
 444   }) || do {
 445     die "Unable to start thread: $!"
 446       unless $! == Errno::EAGAIN();
 447
 448     skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1;
 449   };
 450
 451   is (
 452     $t->join,
 453     42,
 454     'Thread stack exitted succesfully'
 455   );
 456 }}
 457
 458 # this doesn't really belong in this test, but screw it
 459 {
 460   package DBICTest::WackyDFS;
 461   use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass );
 462 }
 463
 464 is_deeply
 465   describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE},
 466   [
 467     {
 468       attributes => {},
 469       name => "VALID_DBIC_CODE_ATTRIBUTE",
 470       via_class => "DBICTest::SomeGrandParentClass",
 471     },
 472     {
 473       attributes => {},
 474       name => "VALID_DBIC_CODE_ATTRIBUTE",
 475       via_class => "DBIx::Class::MethodAttributes"
 476     },
 477   ],
 478   'Expected description on unusable inheritance hierarchy'
 479 ;
 480
 481 done_testing;