Expand/fortify the handling of attributes

Now works properly under ithreads, and allows multiple attributes->import()
calls to be made on the same cref

diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index a4b8654..ef1c60e 100644 (file)
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -23,6 +23,10 @@ use mro 'c3';
 use base qw/DBIx::Class::Componentised DBIx::Class::AccessorGroup/;
 use DBIx::Class::Exception;
 
+use DBIx::Class::_Util qw( uniq refdesc visit_namespaces );
+use Scalar::Util qw( weaken refaddr );
+use namespace::clean;
+
 __PACKAGE__->mk_group_accessors(inherited => '_skip_namespace_frames');
 __PACKAGE__->_skip_namespace_frames('^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve|^Moose::Meta::');
 
@@ -40,11 +44,72 @@ BEGIN {
 
 sub component_base_class { 'DBIx::Class' }
 
+
+my $cref_registry;
+sub DBIx::Class::__Attr_iThreads_handler__::CLONE {
+
+  # this is disgusting, but the best we can do without even more surgery
+  visit_namespaces( action => sub {
+    my $pkg = shift;
+
+    # skip dangerous namespaces
+    return 1 if $pkg =~ /^ (?:
+      DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
+    ) $/x;
+
+    no strict 'refs';
+
+    if (
+      exists ${"${pkg}::"}{__cag___attr_cache}
+        and
+      ref( my $attr_stash = ${"${pkg}::__cag___attr_cache"} ) eq 'HASH'
+    ) {
+      $attr_stash->{ $cref_registry->{$_} } = delete $attr_stash->{$_}
+        for keys %$attr_stash;
+    }
+
+    return 1;
+  })
+}
+
 sub MODIFY_CODE_ATTRIBUTES {
   my ($class,$code,@attrs) = @_;
   $class->mk_classaccessor('__attr_cache' => {})
     unless $class->can('__attr_cache');
-  $class->__attr_cache->{$code} = [@attrs];
+
+  # compaction step
+  defined $cref_registry->{$_} or delete $cref_registry->{$_}
+    for keys %$cref_registry;
+
+  # The original API used stringification instead of refaddr - can't change that now
+  if( $cref_registry->{$code} ) {
+    Carp::confess( sprintf
+      "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work",
+      refdesc($code),
+      refdesc($cref_registry->{$code}),
+      "$code"
+    ) if refaddr($cref_registry->{$code}) != refaddr($code);
+  }
+  else {
+    weaken( $cref_registry->{$code} = $code )
+  }
+
+  $class->__attr_cache->{$code} = [ sort( uniq(
+    @{ $class->__attr_cache->{$code} || [] },
+    @attrs,
+  ))];
+
+  # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on:
+  # decidedly not cool
+  #
+  # There should be some sort of warning on unrecognized attributes or
+  # somesuch... OTOH people do use things in the wild hence the plan of action
+  # is anything but clear :/
+  #
+  # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/lib/DBIx/Class/Service.pm#L93-110
+  # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29
+  # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36
+  #
   return ();
 }
 
@@ -55,10 +120,8 @@ sub FETCH_CODE_ATTRIBUTES {
 
 sub _attr_cache {
   my $self = shift;
-  my $cache = $self->can('__attr_cache') ? $self->__attr_cache : {};
-
-  return {
-    %$cache,
+  +{
+    %{ $self->can('__attr_cache') ? $self->__attr_cache : {} },
     %{ $self->maybe::next::method || {} },
   };
 }

diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t
new file mode 100644 (file)
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;

diff --git a/xt/extra/internals/quote_sub.t b/xt/extra/internals/quote_sub.t
index dcadd20..23fb057 100644 (file)
--- a/xt/extra/internals/quote_sub.t
+++ b/xt/extra/internals/quote_sub.t
@@ -47,30 +47,4 @@ warnings_exist { $no_nothing_q->()->() } [
   }
 ;
 
-### Test the upcoming attributes support
-require DBIx::Class;
-@DBICTest::QSUB::ISA  = 'DBIx::Class';
-
-my $var = \42;
-my $s = quote_sub(
-  'DBICTest::QSUB::attr',
-  '$v',
-  { '$v' => $var },
-  {
-    # use grandfathered 'ResultSet' attribute for starters
-    attributes => [qw( ResultSet )],
-    package => 'DBICTest::QSUB',
-  },
-);
-
-is $s, \&DBICTest::QSUB::attr, 'Same cref installed';
-
-is DBICTest::QSUB::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
-
 done_testing;