Properly handle UNIVERSAL ancestry in describe_class_methods

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / _Util.pm

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 11034e2..1117d87 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -96,19 +96,29 @@ BEGIN {
               $class,
               map {(
                 $_, # refaddr is sufficient, ignore names entirely
-                @{
-                  ( $mro_recursor_stack->{cache} || {} )->{attrs}{$_}
-                    ||=
-                  [ attributes::get( $methlist{$_} ) ]
-                },
+                attributes::get( $methlist{$_} )
               )} 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")
+          } ),
+
+        ) ) ) )
       );
     };
   }
@@ -644,9 +654,10 @@ sub modver_gt_or_eq_and_lt ($$$) {
   our $describe_class_query_cache;
 
   sub describe_class_methods {
+    my ($class) = @_;
 
     croak "Expecting a class name"
-      if not defined $_[0] or $_[0] !~ $module_name_rx;
+      if not defined $class or $class !~ $module_name_rx;
 
     # use a cache on old MRO, since while we are recursing in this function
     # nothing can possibly change (the speedup is immense)
@@ -661,23 +672,40 @@ sub modver_gt_or_eq_and_lt ($$$) {
 
     my $my_gen = 0;
 
-    $my_gen += get_real_pkg_gen($_) for (
-      'UNIVERSAL',
-      my ($class, @my_ISA) = @{
-        $mro_recursor_stack->{cache}{$_[0]}{linear_isa}
+    $my_gen += get_real_pkg_gen($_) for ( my @full_ISA = (
+
+      @{
+        $mro_recursor_stack->{cache}{$class}{linear_isa}
           ||=
-        mro::get_linear_isa($_[0])
-      }
-    );
+        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),
         },
@@ -685,37 +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
-      for (reverse @my_ISA) {
-        my ($parent_gen, @parent_ISA);
-
-        # and even more skips before calling out recursively
-        describe_class_methods($_) unless (
-          $describe_class_query_cache->{$_}{cumulative_gen}
-            and
-          $parent_gen = get_real_pkg_gen($_)
-            and
-          (
-            (
-              (undef, @parent_ISA) = @{
-                $mro_recursor_stack->{cache}{$_}{linear_isa}
-                  ||=
-                mro::get_linear_isa($_)
-              }
-            ) == 1
-              or
-            do {
-              $parent_gen += get_real_pkg_gen($_) for @parent_ISA;
-              1;
-            }
-          )
-            and
-          $describe_class_query_cache->{$_}{cumulative_gen} == $parent_gen
-        );
-      }
+      describe_class_methods($_) for reverse @full_ISA;
 
       my ($methods_seen_via_ISA_on_old_mro, $current_node_refaddr);
       no strict 'refs';
@@ -728,15 +728,15 @@ sub modver_gt_or_eq_and_lt ($$$) {
 
           and
 
-        # on complex MI herarchies the method can be anywhere in the
-        # shadow stack - look through the entire slot, not just [0]
-        ( ! grep {
-          refaddr($_) == $current_node_refaddr
-        } @{ $slot->{methods}{ $_->{name} } || [] } )
+        unshift @{ $slot->{methods}{$_->{name}} }, $_
 
           and
 
-        unshift @{ $slot->{methods}{$_->{name}} }, $_
+        (
+          $_->{via_class} ne $class
+            or
+          $slot->{methods_defined_in_class}{$_->{name}} = $_
+        )
 
           and
 
@@ -748,10 +748,10 @@ sub modver_gt_or_eq_and_lt ($$$) {
 
       ) for (
 
-        # what describe_class_methods for @my_ISA produced above
-        ( map { $_->[0] } map {
-          values %{ $describe_class_query_cache->{$_}{methods} }
-        } reverse @my_ISA ),
+        # what describe_class_methods for @full_ISA produced above
+        ( map { values %{
+          $describe_class_query_cache->{$_}{methods_defined_in_class} || {}
+        } } reverse @full_ISA ),
 
         # our own non-cleaned subs + their attributes
         ( map {
@@ -773,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
@@ -787,11 +787,9 @@ sub modver_gt_or_eq_and_lt ($$$) {
           ) ? {
               via_class => $class,
               name => $_,
-              attributes => { map { $_ => 1 } @{
-                $mro_recursor_stack->{cache}{attrs}{ refaddr \&{"${class}::${_}"} }
-                  ||=
-                [ attributes::get( \&{"${class}::${_}"} ) ]
-              } },
+              attributes => {
+                map { $_ => 1 } attributes::get( \&{"${class}::${_}"} )
+              },
             }
             : ()
         } keys %{"${class}::"} )
@@ -810,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;
       }
     }
 
@@ -930,12 +928,29 @@ sub fail_on_internal_call {
     ;
   };
 
+  my @fr2;
+  # need to make allowance for a proxy-yet-direct call
+  my $check_fr = (
+    $fr->[0] eq 'DBIx::Class::ResultSourceProxy'
+      and
+    @fr2 = (CORE::caller(2))
+      and
+    (
+      ( $fr->[3] =~ /([^:])+$/ )[0]
+        eq
+      ( $fr2[3] =~ /([^:])+$/ )[0]
+    )
+  )
+    ? \@fr2
+    : $fr
+  ;
+
   if (
     $argdesc
       and
-    $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
+    $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
       and
-    $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/  # no point touching there
+    $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/  # no point touching there
   ) {
     DBIx::Class::Exception->throw( sprintf (
       "Illegal internal call of indirect proxy-method %s() with argument '%s': examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n    Stacktrace starts",