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