X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=xt%2Fextra%2Finternals%2Fattributes.t;fp=xt%2Fextra%2Finternals%2Fattributes.t;h=5c9b50d4d3ef8db67663bf6dfe7e70169efb5a04;hb=7bd921c01e7ad780f701c30d53300c610a7202b9;hp=0000000000000000000000000000000000000000;hpb=10be570e51ef741ead5f0e8d5ceca78499a8965c;p=dbsrgits%2FDBIx-Class.git

diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t
new file mode 100644
index 0000000..5c9b50d
--- /dev/null
+++ b/xt/extra/internals/attributes.t
@@ -0,0 +1,111 @@
+use warnings;
+use strict;
+
+use Config;
+my $skip_threads;
+BEGIN {
+  if( ! $Config{useithreads} ) {
+    $skip_threads = 'your perl does not support ithreads';
+  }
+  elsif( "$]" < 5.008005 ) {
+    $skip_threads = 'DBIC does not actively support threads before perl 5.8.5';
+  }
+  elsif( $INC{'Devel/Cover.pm'} ) {
+    $skip_threads = 'Devel::Cover does not work with ithreads yet';
+  }
+
+  unless( $skip_threads ) {
+    require threads;
+    threads->import;
+  }
+}
+
+use Test::More;
+use DBIx::Class::_Util qw( quote_sub modver_gt_or_eq );
+
+### Test the upcoming attributes support
+require DBIx::Class;
+@DBICTest::ATTRTEST::ISA  = 'DBIx::Class';
+
+my $var = \42;
+my $s = quote_sub(
+  'DBICTest::ATTRTEST::attr',
+  '$v',
+  { '$v' => $var },
+  {
+    attributes => [qw( ResultSet )],
+    package => 'DBICTest::ATTRTEST',
+  },
+);
+
+is $s, \&DBICTest::ATTRTEST::attr, 'Same cref installed';
+
+is DBICTest::ATTRTEST::attr(), 42, 'Sub properly installed and callable';
+
+is_deeply
+  [ attributes::get( $s ) ],
+  [ 'ResultSet' ],
+  'Attribute installed',
+unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
+
+sub add_more_attrs {
+  # Test that secondary attribute application works
+  attributes->import(
+    'DBICTest::ATTRTEST',
+    DBICTest::ATTRTEST->can('attr'),
+    'method',
+    'SomethingNobodyUses',
+  );
+
+  # and that double-application also works
+  attributes->import(
+    'DBICTest::ATTRTEST',
+    DBICTest::ATTRTEST->can('attr'),
+    'SomethingNobodyUses',
+  );
+
+  is_deeply
+    [ sort( attributes::get( $s ) )],
+    [
+      qw( ResultSet SomethingNobodyUses method ),
+
+      # before 5.10/5.8.9 internal reserved would get doubled, sigh
+      #
+      # FIXME - perhaps need to weed them out somehow at FETCH_CODE_ATTRIBUTES
+      # time...? In any case - this is not important at this stage
+      ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' )
+    ],
+    'Secondary attributes installed',
+  unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
+
+  is_deeply (
+    DBICTest::ATTRTEST->_attr_cache->{$s},
+    [
+      qw( ResultSet SomethingNobodyUses ),
+
+      # after 5.10/5.8.9 FETCH_CODE_ATTRIBUTES is never called for reserved
+      # attribute names, so there is nothing for DBIC to see
+      #
+      # FIXME - perhaps need to teach ->_attr to reinvoke attributes::get() ?
+      # In any case - this is not important at this stage
+      ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' )
+    ],
+    'Attributes visible in DBIC-specific attribute API',
+  );
+}
+
+
+if ($skip_threads) {
+  SKIP: { skip "Skipping the thread test: $skip_threads", 1 }
+
+  add_more_attrs();
+}
+else {
+  threads->create(sub {
+    add_more_attrs();
+    select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
+  })->join;
+}
+
+
+done_testing;