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 DBIx::Class::_Util qw( quote_sub modver_gt_or_eq );
  25
  26 require DBIx::Class;
  27 @DBICTest::ATTRTEST::ISA  = 'DBIx::Class';
  28
  29 my $var = \42;
  30 my $s = quote_sub(
  31   'DBICTest::ATTRTEST::attr',
  32   '$v',
  33   { '$v' => $var },
  34   {
  35     attributes => [qw( ResultSet )],
  36     package => 'DBICTest::ATTRTEST',
  37   },
  38 );
  39
  40 is $s, \&DBICTest::ATTRTEST::attr, 'Same cref installed';
  41
  42 is DBICTest::ATTRTEST::attr(), 42, 'Sub properly installed and callable';
  43
  44 is_deeply
  45   [ attributes::get( $s ) ],
  46   [ 'ResultSet' ],
  47   'Attribute installed',
  48 unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
  49
  50 sub add_more_attrs {
  51   # Test that secondary attribute application works
  52   attributes->import(
  53     'DBICTest::ATTRTEST',
  54     DBICTest::ATTRTEST->can('attr'),
  55     'method',
  56     'SomethingNobodyUses',
  57   );
  58
  59   # and that double-application also works
  60   attributes->import(
  61     'DBICTest::ATTRTEST',
  62     DBICTest::ATTRTEST->can('attr'),
  63     'SomethingNobodyUses',
  64   );
  65
  66   is_deeply
  67     [ sort( attributes::get( $s ) )],
  68     [
  69       qw( ResultSet SomethingNobodyUses method ),
  70
  71       # before 5.10/5.8.9 internal reserved would get doubled, sigh
  72       #
  73       # FIXME - perhaps need to weed them out somehow at FETCH_CODE_ATTRIBUTES
  74       # time...? In any case - this is not important at this stage
  75       ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' )
  76     ],
  77     'Secondary attributes installed',
  78   unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
  79
  80   is_deeply (
  81     DBICTest::ATTRTEST->_attr_cache->{$s},
  82     [
  83       qw( ResultSet SomethingNobodyUses ),
  84
  85       # after 5.10/5.8.9 FETCH_CODE_ATTRIBUTES is never called for reserved
  86       # attribute names, so there is nothing for DBIC to see
  87       #
  88       # FIXME - perhaps need to teach ->_attr to reinvoke attributes::get() ?
  89       # In any case - this is not important at this stage
  90       ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' )
  91     ],
  92     'Attributes visible in DBIC-specific attribute API',
  93   );
  94 }
  95
  96
  97 if ($skip_threads) {
  98   SKIP: { skip "Skipping the thread test: $skip_threads", 1 }
  99
 100   add_more_attrs();
 101 }
 102 else {
 103   threads->create(sub {
 104
 105     threads->create(sub {
 106
 107       add_more_attrs();
 108       select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 109
 110     })->join;
 111
 112     select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
 113
 114   })->join;
 115 }
 116
 117 done_testing;