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