xt/extra/internals/attributes.t

   1 use warnings;
   2 use strict;
   3
   4 use Config;
   5 my $skip_threads;
   6 BEGIN {
   7   if( ! $Config{useithreads} ) {
   8     $skip_threads = 'your perl does not support ithreads';
   9   }
  10   elsif( "$]" < 5.008005 ) {
  11     $skip_threads = 'DBIC does not actively support threads before perl 5.8.5';
  12   }
  13   elsif( $INC{'Devel/Cover.pm'} ) {
  14     $skip_threads = 'Devel::Cover does not work with ithreads yet';
  15   }
  16
  17   unless( $skip_threads ) {
  18     require threads;
  19     threads->import;
  20   }
  21 }
  22
  23 use Test::More;
  24 use Test::Exception;
  25 use DBIx::Class::_Util qw( quote_sub );
  26
  27 require DBIx::Class;
  28 @DBICTest::AttrLegacy::ISA  = 'DBIx::Class';
  29 sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 }
  30
  31 my $var = \42;
  32 my $s = quote_sub(
  33   'DBICTest::AttrLegacy::attr',
  34   '$v',
  35   { '$v' => $var },
  36   {
  37     attributes => [qw( ResultSet DBIC_random_attr )],
  38     package => 'DBICTest::AttrLegacy',
  39   },
  40 );
  41
  42 is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed';
  43
  44 is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable';
  45
  46 is_deeply
  47   [ sort( attributes::get( $s ) ) ],
  48   [qw( DBIC_random_attr ResultSet )],
  49   'Attribute installed',
  50 unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
  51
  52
  53 @DBICTest::AttrTest::ISA  = 'DBIx::Class';
  54 {
  55     package DBICTest::AttrTest;
  56
  57     eval <<'EOS' or die $@;
  58       sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ }
  59       sub attr :lvalue :method :DBIC_attr1 { $$var}
  60       1;
  61 EOS
  62
  63     ::throws_ok {
  64       attributes->import(
  65         'DBICTest::AttrTest',
  66         DBICTest::AttrTest->can('attr'),
  67         'DBIC_unknownattr',
  68       );
  69     } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/;
  70 }
  71
  72 is_deeply
  73   [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
  74   [qw( DBIC_attr1 lvalue method )],
  75   'Attribute installed',
  76 unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
  77
  78 ok(
  79   ! DBICTest::AttrTest->can('__attr_cache'),
  80   'Inherited classdata never created on core attrs'
  81 );
  82
  83 is_deeply(
  84   DBICTest::AttrTest->_attr_cache,
  85   {},
  86   'Cache never instantiated on core attrs'
  87 );
  88
  89 sub add_more_attrs {
  90   # Test that secondary attribute application works
  91   attributes->import(
  92     'DBICTest::AttrLegacy',
  93     DBICTest::AttrLegacy->can('attr'),
  94     'SomethingNobodyUses',
  95   );
  96
  97   # and that double-application also works
  98   attributes->import(
  99     'DBICTest::AttrLegacy',
 100     DBICTest::AttrLegacy->can('attr'),
 101     'SomethingNobodyUses',
 102   );
 103
 104   is_deeply
 105     [ sort( attributes::get( $s ) )],
 106     [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ],
 107     'Secondary attributes installed',
 108   unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
 109
 110   is_deeply (
 111     DBICTest::AttrLegacy->_attr_cache->{$s},
 112     [ qw( ResultSet SomethingNobodyUses ) ],
 113     'Attributes visible in legacy DBIC attribute API',
 114   );
 115
 116
 117
 118   # Test that secondary attribute application works
 119   attributes->import(
 120     'DBICTest::AttrTest',
 121     DBICTest::AttrTest->can('attr'),
 122     'DBIC_attr2',
 123   );
 124
 125   # and that double-application also works
 126   attributes->import(
 127     'DBICTest::AttrTest',
 128     DBICTest::AttrTest->can('attr'),
 129     'DBIC_attr2',
 130     'DBIC_attr3',
 131   );
 132
 133   is_deeply
 134     [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
 135     [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )],
 136     'DBIC-specific attribute installed',
 137   unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
 138
 139   ok(
 140     ! DBICTest::AttrTest->can('__attr_cache'),
 141     'Inherited classdata never created on core+DBIC-specific attrs'
 142   );
 143
 144   is_deeply(
 145     DBICTest::AttrTest->_attr_cache,
 146     {},
 147     'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs'
 148   );
 149 }
 150
 151
 152 if ($skip_threads) {
 153   SKIP: { skip "Skipping the thread test: $skip_threads", 1 }
 154
 155   add_more_attrs();
 156 }
 157 else {
 158   threads->create(sub {
 159
 160     threads->create(sub {
 161
 162       add_more_attrs();
 163       select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 164
 165     })->join;
 166
 167     select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 168
 169   })->join;
 170 }
 171
 172 done_testing;