Audit and annotate all context-sensitive spots in ::Ordered

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

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 6b71ceb..147614f 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -52,6 +52,7 @@ BEGIN {
         DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS
         DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
         DBIC_ASSERT_NO_FAILING_SANITY_CHECKS
+        DBIC_ASSERT_NO_INCONSISTENT_RELATIONSHIP_RESOLUTION
         DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE
         DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE
       )
@@ -203,7 +204,7 @@ our @EXPORT_OK = qw(
   scope_guard detected_reinvoked_destructor emit_loud_diag
   true false
   is_exception dbic_internal_try dbic_internal_catch visit_namespaces
-  quote_sub qsub perlstring serialize deep_clone dump_value uniq
+  quote_sub qsub perlstring serialize deep_clone dump_value uniq bag_eq
   parent_dir mkdir_p
   UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR
 );
@@ -386,6 +387,34 @@ sub uniq {
   ) } @_;
 }
 
+sub bag_eq ($$) {
+  croak "bag_eq() requiress two arrayrefs as arguments" if (
+    ref($_[0]) ne 'ARRAY'
+      or
+    ref($_[1]) ne 'ARRAY'
+  );
+
+  return '' unless @{$_[0]} == @{$_[1]};
+
+  my( %seen, $numeric_preserving_copy );
+
+  ( defined $_
+    ? $seen{'value' . ( $numeric_preserving_copy = $_ )}++
+    : $seen{'undef'}++
+  ) for @{$_[0]};
+
+  ( defined $_
+    ? $seen{'value' . ( $numeric_preserving_copy = $_ )}--
+    : $seen{'undef'}--
+  ) for @{$_[1]};
+
+  return (
+    (grep { $_ } values %seen)
+      ? ''
+      : 1
+  );
+}
+
 my $dd_obj;
 sub dump_value ($) {
   local $Data::Dumper::Indent = 1
@@ -1097,34 +1126,7 @@ sub mkdir_p ($) {
 }
 
 sub fail_on_internal_call {
-  my ($fr, $argdesc);
-  {
-    package DB;
-    $fr = [ CORE::caller(1) ];
-    $argdesc =
-      ( not defined $DB::args[0] )  ? 'UNAVAILABLE'
-    : ( length ref $DB::args[0] )   ? DBIx::Class::_Util::refdesc($DB::args[0])
-    : $DB::args[0] . ''
-    ;
-  };
-
-  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
-  ;
-
+  my $fr = [ CORE::caller(1) ];
 
   die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless (
 
@@ -1161,13 +1163,66 @@ sub fail_on_internal_call {
   );
 
 
+  my @fr2;
+  # need to make allowance for a proxy-yet-direct call
+  # or for an exception wrapper
+  $fr = \@fr2 if (
+    (
+      $fr->[3] eq '(eval)'
+        and
+      @fr2 = (CORE::caller(2))
+    )
+      or
+    (
+      $fr->[0] eq 'DBIx::Class::ResultSourceProxy'
+        and
+      @fr2 = (CORE::caller(2))
+        and
+      (
+        ( $fr->[3] =~ /([^:])+$/ )[0]
+          eq
+        ( $fr2[3] =~ /([^:])+$/ )[0]
+      )
+    )
+  );
+
+
   if (
     defined $fr->[0]
       and
-    $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
+    $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
+      and
+    $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/  # no point touching there
+      and
+    # one step higher
+    @fr2 = CORE::caller(@fr2 ? 3 : 2)
       and
-    $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/  # no point touching there
+    # if the frame that called us is an indirect itself - nothing to see here
+    ! grep
+      { $_ eq 'DBIC_method_is_indirect_sugar' }
+      do {
+        no strict 'refs';
+        attributes::get( \&{ $fr2[3] })
+      }
   ) {
+
+    my $argdesc;
+
+    {
+      package DB;
+
+      my @throwaway = caller( @fr2 ? 2 : 1 );
+
+      # screwing with $DB::args is rather volatile - be extra careful
+      no warnings 'uninitialized';
+
+      $argdesc =
+        ( not defined $DB::args[0] )  ? 'UNAVAILABLE'
+      : ( length ref $DB::args[0] )   ? DBIx::Class::_Util::refdesc($DB::args[0])
+      : $DB::args[0] . ''
+      ;
+    };
+
     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",
       $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do {