From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sun, 29 May 2016 14:50:02 +0000 (+0200)
Subject: Attribute handling got too complex - move it into a component
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5f48fa565dc31b9d22762488afdec8502b8ca515;p=dbsrgits%2FDBIx-Class.git

Attribute handling got too complex - move it into a component

No functional changes, just c/p code around
For some reason git diff -C -C -M doesn't work here...
---

diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index 61c09b1..f76419d 100644
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -23,12 +23,9 @@ 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::');
+__PACKAGE__->mk_classaccessor( _skip_namespace_frames =>
+  '^DBIx::Class|^SQL::Abstract|^Try::Tiny|^Class::Accessor::Grouped|^Context::Preserve|^Moose::Meta::'
+);
 
 # FIXME - this is not really necessary, and is in
 # fact going to slow things down a bit
@@ -44,98 +41,6 @@ BEGIN {
 
 sub component_base_class { 'DBIx::Class' }
 
-
-my $attr_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->{ $attr_cref_registry->{$_}{weakref} } = delete $attr_stash->{$_}
-        for keys %$attr_stash;
-    }
-
-    return 1;
-  });
-
-  # renumber the cref registry itself
-  %$attr_cref_registry = map {
-    ( defined $_->{weakref} )
-      ? (
-        # because of how __attr_cache works, ugh
-        "$_->{weakref}"         => $_,
-      )
-      : ()
-  } values %$attr_cref_registry;
-}
-
-sub MODIFY_CODE_ATTRIBUTES {
-  my ($class,$code,@attrs) = @_;
-  $class->mk_classaccessor('__attr_cache' => {})
-    unless $class->can('__attr_cache');
-
-  # compaction step
-  defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_}
-    for keys %$attr_cref_registry;
-
-  # The original API used stringification instead of refaddr - can't change that now
-  if( $attr_cref_registry->{$code} ) {
-    Carp::confess( sprintf
-      "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work",
-      refdesc($code),
-      refdesc($attr_cref_registry->{$code}{weakref}),
-      "$code"
-    ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code);
-  }
-  else {
-    weaken( $attr_cref_registry->{$code}{weakref} = $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 ();
-}
-
-sub FETCH_CODE_ATTRIBUTES {
-  my ($class,$code) = @_;
-  @{ $class->_attr_cache->{$code} || [] }
-}
-
-sub _attr_cache {
-  my $self = shift;
-  +{
-    %{ $self->can('__attr_cache') ? $self->__attr_cache : {} },
-    %{ $self->maybe::next::method || {} },
-  };
-}
-
 # *DO NOT* change this URL nor the identically named =head1 below
 # it is linked throughout the ecosystem
 sub DBIx::Class::_ENV_::HELP_URL () {
diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm
index 7c6dece..0ae4b5b 100644
--- a/lib/DBIx/Class/AccessorGroup.pm
+++ b/lib/DBIx/Class/AccessorGroup.pm
@@ -3,7 +3,7 @@ package DBIx::Class::AccessorGroup;
 use strict;
 use warnings;
 
-use base qw/Class::Accessor::Grouped/;
+use base qw( DBIx::Class::MethodAttributes Class::Accessor::Grouped );
 use mro 'c3';
 
 use Scalar::Util qw/weaken blessed/;
diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm
new file mode 100644
index 0000000..6dac252
--- /dev/null
+++ b/lib/DBIx/Class/MethodAttributes.pm
@@ -0,0 +1,104 @@
+package # hide from PAUSE
+    DBIx::Class::MethodAttributes;
+
+use strict;
+use warnings;
+
+use DBIx::Class::_Util qw( uniq refdesc visit_namespaces );
+use Scalar::Util qw( weaken refaddr );
+
+use mro 'c3';
+use namespace::clean;
+
+my $attr_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->{ $attr_cref_registry->{$_}{weakref} } = delete $attr_stash->{$_}
+        for keys %$attr_stash;
+    }
+
+    return 1;
+  });
+
+  # renumber the cref registry itself
+  %$attr_cref_registry = map {
+    ( defined $_->{weakref} )
+      ? (
+        # because of how __attr_cache works, ugh
+        "$_->{weakref}"         => $_,
+      )
+      : ()
+  } values %$attr_cref_registry;
+}
+
+sub MODIFY_CODE_ATTRIBUTES {
+  my ($class,$code,@attrs) = @_;
+  $class->mk_classaccessor('__attr_cache' => {})
+    unless $class->can('__attr_cache');
+
+  # compaction step
+  defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_}
+    for keys %$attr_cref_registry;
+
+  # The original misc-attr API used stringification instead of refaddr - can't change that now
+  if( $attr_cref_registry->{$code} ) {
+    Carp::confess( sprintf
+      "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work",
+      refdesc($code),
+      refdesc($attr_cref_registry->{$code}{weakref}),
+      "$code"
+    ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code);
+  }
+  else {
+    weaken( $attr_cref_registry->{$code}{weakref} = $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 ();
+}
+
+sub FETCH_CODE_ATTRIBUTES {
+  my ($class,$code) = @_;
+  @{ $class->_attr_cache->{$code} || [] }
+}
+
+sub _attr_cache {
+  my $self = shift;
+  +{
+    %{ $self->can('__attr_cache') ? $self->__attr_cache : {} },
+    %{ $self->maybe::next::method || {} },
+  };
+}
+
+1;
diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t
index b98a555..4f46824 100644
--- a/xt/dist/pod_coverage.t
+++ b/xt/dist/pod_coverage.t
@@ -29,11 +29,7 @@ require Test::Pod::Coverage;
 my $exceptions = {
     'DBIx::Class' => {
         ignore => [qw/
-            MODIFY_CODE_ATTRIBUTES
             component_base_class
-            inject_base
-            mk_classdata
-            mk_classaccessor
         /]
     },
     'DBIx::Class::Optional::Dependencies' => {
@@ -120,6 +116,7 @@ my $exceptions = {
 
     'DBIx::Class::Admin::*'                         => { skip => 1 },
     'DBIx::Class::ClassResolver::PassThrough'       => { skip => 1 },
+    'DBIx::Class::MethodAttributes'                 => { skip => 1 },
     'DBIx::Class::Componentised'                    => { skip => 1 },
     'DBIx::Class::AccessorGroup'                    => { skip => 1 },
     'DBIx::Class::Relationship::*'                  => { skip => 1 },
diff --git a/xt/extra/c3_mro.t b/xt/extra/c3_mro.t
index fad386a..398f51e 100644
--- a/xt/extra/c3_mro.t
+++ b/xt/extra/c3_mro.t
@@ -12,6 +12,7 @@ my @global_ISA_tail = qw(
   DBIx::Class::Componentised
   Class::C3::Componentised
   DBIx::Class::AccessorGroup
+  DBIx::Class::MethodAttributes
   Class::Accessor::Grouped
 );