X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FAccessorGroup.pm;h=31cdcb0e817304f58217231e2d727436c635fac6;hb=6c5aa1fbffdc9e5679d2f68780b11a9569ec1993;hp=01a5559d1ca033ef9d8faa7089eb36b32f21b464;hpb=e50536940adf2ebaef907a0c29ae37fbd5ce95b1;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm
index 01a5559..31cdcb0 100644
--- a/lib/DBIx/Class/AccessorGroup.pm
+++ b/lib/DBIx/Class/AccessorGroup.pm
@@ -3,17 +3,18 @@ package DBIx::Class::AccessorGroup;
 use strict;
 use warnings;
 
-use base qw/Class::Accessor::Grouped/;
-use Scalar::Util qw/weaken blessed/;
+use base qw( DBIx::Class::MethodAttributes Class::Accessor::Grouped );
+
+use Scalar::Util 'blessed';
 use DBIx::Class::_Util 'fail_on_internal_call';
 use namespace::clean;
 
-sub mk_classdata {
+sub mk_classdata :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->mk_classaccessor(@_);
 }
 
-sub mk_classaccessor {
+sub mk_classaccessor :DBIC_method_is_indirect_sugar {
   my $self = shift;
   $self->mk_group_accessors('inherited', $_[0]);
   (@_ > 1)
@@ -22,31 +23,83 @@ sub mk_classaccessor {
   ;
 }
 
-my $successfully_loaded_components;
+sub mk_group_accessors {
+  my $class = shift;
+  my $type = shift;
+
+  $class->next::method($type, @_);
+
+  # label things
+  if( $type =~ /^ ( inflated_ | filtered_ )? column $/x ) {
+
+    $class = ref $class
+      if length ref $class;
+
+    for my $acc_pair  (
+      map
+        { [ $_, "_${_}_accessor" ] }
+        map
+          { ref $_ ? $_->[0] : $_ }
+          @_
+    ) {
+
+      for my $i (0, 1) {
+
+        my $acc_name = $acc_pair->[$i];
+
+        attributes->import(
+          $class,
+          (
+            $class->can($acc_name)
+              ||
+            Carp::confess("Accessor '$acc_name' we just created on $class can't be found...?")
+          ),
+          'DBIC_method_is_generated_from_resultsource_metadata',
+          ($i
+            ? "DBIC_method_is_${type}_extra_accessor"
+            : "DBIC_method_is_${type}_accessor"
+          ),
+        )
+      }
+    }
+  }
+  elsif( $type eq 'inherited_ro_instance' ) {
+    DBIx::Class::Exception->throw(
+      "The 'inherted_ro_instance' CAG group has been retired - use 'inherited' instead"
+    );
+  }
+}
 
 sub get_component_class {
   my $class = $_[0]->get_inherited($_[1]);
 
-  # It's already an object, just go for it.
-  return $class if blessed $class;
-
-  if (defined $class and ! $successfully_loaded_components->{$class} ) {
+  no strict 'refs';
+  if (
+    defined $class
+      and
+    # inherited CAG can't be set to undef effectively, so people may use ''
+    length $class
+      and
+    # It's already an object, just go for it.
+    ! defined blessed $class
+      and
+    ! ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
+  ) {
     $_[0]->ensure_class_loaded($class);
 
-    mro::set_mro( $class, 'c3' );
-
-    no strict 'refs';
-    $successfully_loaded_components->{$class}
-      = ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
-        = do { \(my $anon = 'loaded') };
-    weaken($successfully_loaded_components->{$class});
+    ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
+      = do { \(my $anon = 'loaded') };
   }
 
   $class;
 };
 
 sub set_component_class {
-  shift->set_inherited(@_);
+  $_[0]->set_inherited($_[1], $_[2]);
+
+  # trigger a load for the case of $foo->component_accessor("bar")->new
+  $_[0]->get_component_class($_[1])
+    if defined wantarray;
 }
 
 1;