From: Peter Rabbitson <ribasushi@cpan.org>
Date: Mon, 13 Jun 2016 16:43:31 +0000 (+0200)
Subject: Properly handle UNIVERSAL ancestry in describe_class_methods
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d01688ccb3f9455ee7caeacc27d8ff106d7cad1c;p=dbsrgits%2FDBIx-Class.git

Properly handle UNIVERSAL ancestry in describe_class_methods

Obscure but possible nevertheless.
---

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 35d11df..1117d87 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -100,11 +100,25 @@ BEGIN {
               )} sort keys %methlist
             ),
           }
-        } ( 'UNIVERSAL', @{
-          ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{linear_isa}
-            ||=
-           mro::get_linear_isa($_[0])
-        } ) ) ) )
+        } (
+
+          @{
+            ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{linear_isa}
+              ||=
+            mro::get_linear_isa($_[0])
+          },
+
+          ((
+            ( $mro_recursor_stack->{cache} || {} )->{$_[0]}{is_universal}
+              ||=
+            mro::is_universal($_[0])
+          ) ? () : @{
+            ( $mro_recursor_stack->{cache} || {} )->{UNIVERSAL}{linear_isa}
+              ||=
+            mro::get_linear_isa("UNIVERSAL")
+          } ),
+
+        ) ) ) )
       );
     };
   }
@@ -658,23 +672,40 @@ sub modver_gt_or_eq_and_lt ($$$) {
 
     my $my_gen = 0;
 
-    $my_gen += get_real_pkg_gen($_) for (
-      'UNIVERSAL',
-      ( $class, my @my_ISA ) = @{
+    $my_gen += get_real_pkg_gen($_) for ( my @full_ISA = (
+
+      @{
         $mro_recursor_stack->{cache}{$class}{linear_isa}
           ||=
         mro::get_linear_isa($class)
-      }
-    );
+      },
+
+      ((
+        $mro_recursor_stack->{cache}{$class}{is_universal}
+          ||=
+        mro::is_universal($class)
+      ) ? () : @{
+        $mro_recursor_stack->{cache}{UNIVERSAL}{linear_isa}
+          ||=
+        mro::get_linear_isa("UNIVERSAL")
+      }),
+
+    ));
 
     my $slot = $describe_class_query_cache->{$class} ||= {};
 
     unless ( ($slot->{cumulative_gen}||0) == $my_gen ) {
 
+      # remove ourselves from ISA
+      shift @full_ISA;
+
       # reset
       %$slot = (
         class => $class,
-        isa => [ @my_ISA ], # copy before we shove UNIVERSAL into it
+        isa => [
+          @{ $mro_recursor_stack->{cache}{$class}{linear_isa} }
+            [ 1 .. $#{$mro_recursor_stack->{cache}{$class}{linear_isa}} ]
+        ],
         mro => {
           type => mro::get_mro($class),
         },
@@ -682,11 +713,9 @@ sub modver_gt_or_eq_and_lt ($$$) {
       );
       $slot->{mro}{is_c3} = ($slot->{mro}{type} eq 'c3') ? 1 : 0;
 
-      push @my_ISA, 'UNIVERSAL';
-
       # ensure the cache is populated for the parents, code below can then
       # efficiently operate over the query_cache directly
-      describe_class_methods($_) for reverse @my_ISA;
+      describe_class_methods($_) for reverse @full_ISA;
 
       my ($methods_seen_via_ISA_on_old_mro, $current_node_refaddr);
       no strict 'refs';
@@ -719,10 +748,10 @@ sub modver_gt_or_eq_and_lt ($$$) {
 
       ) for (
 
-        # what describe_class_methods for @my_ISA produced above
+        # what describe_class_methods for @full_ISA produced above
         ( map { values %{
           $describe_class_query_cache->{$_}{methods_defined_in_class} || {}
-        } } reverse @my_ISA ),
+        } } reverse @full_ISA ),
 
         # our own non-cleaned subs + their attributes
         ( map {
@@ -744,7 +773,7 @@ sub modver_gt_or_eq_and_lt ($$$) {
                   $rv->{$_->{name}}->{ refaddr( \&{ "$_->{via_class}::$_->{name}"} ) } = 1 for
                     map { @$_ } map
                       { values %{ $describe_class_query_cache->{$_}{methods} } }
-                      @my_ISA;
+                      @full_ISA;
                   $rv;
                 }
                   and
@@ -779,7 +808,7 @@ sub modver_gt_or_eq_and_lt ($$$) {
 
         $slot->{cumulative_gen} = 0;
         $slot->{cumulative_gen} += get_real_pkg_gen($_)
-          for $class, @my_ISA;
+          for $class, @full_ISA;
       }
     }
 
diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t
index bed8efd..0bd2e47 100644
--- a/xt/extra/internals/attributes.t
+++ b/xt/extra/internals/attributes.t
@@ -32,6 +32,9 @@ use DBICTest;
 
 my $pkg_gen_history = {};
 
+{ package UEBERVERSAL; sub ueber {} }
+@UNIVERSAL::ISA = "UEBERVERSAL";
+
 sub grab_pkg_gen ($) {
   push @{ $pkg_gen_history->{$_[0]} }, [
     DBIx::Class::_Util::get_real_pkg_gen($_[0]),
@@ -225,11 +228,11 @@ sub add_more_attrs {
 
       $cnt++;
 
-      eval "sub UNIVERSAL::some_unimethod_$cnt {}; 1" or die $@;
+      eval "sub UEBERVERSAL::some_unimethod_$cnt {}; 1" or die $@;
 
       my $rv = describe_class_methods($class);
 
-      delete ${"UNIVERSAL::"}{"some_unimethod_$cnt"};
+      delete ${"UEBERVERSAL::"}{"some_unimethod_$cnt"};
 
       $rv
     };
@@ -292,6 +295,7 @@ sub add_more_attrs {
       my $gen = Math::BigInt->new(0);
 
       $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for (
+        'UEBERVERSAL',
         'UNIVERSAL',
         'DBICTest::AttrTest',
         @$expected_AttrTest_ISA,
@@ -356,6 +360,13 @@ sub add_more_attrs {
           via_class => "DBICTest::AttrTest"
         }
       ],
+      ueber => [
+        {
+          attributes => {},
+          name => "ueber",
+          via_class => "UEBERVERSAL",
+        }
+      ],
       can => [
         {
           attributes => {},