Tighten up code in ResultSetColumns, add INDIRECT annotations

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

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 7d26850..73f41e9 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
       )
@@ -202,14 +203,19 @@ our @EXPORT_OK = qw(
   refdesc refcount hrefaddr set_subname get_subname describe_class_methods
   scope_guard detected_reinvoked_destructor emit_loud_diag
   true false
-  is_exception dbic_internal_try visit_namespaces
-  quote_sub qsub perlstring serialize deep_clone dump_value uniq
+  is_exception dbic_internal_try dbic_internal_catch visit_namespaces
+  quote_sub qsub perlstring serialize deep_clone dump_value uniq bag_eq
   parent_dir mkdir_p
-  UNRESOLVABLE_CONDITION
+  UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR
 );
 
 use constant UNRESOLVABLE_CONDITION => \ '1 = 0';
 
+use constant DUMMY_ALIASPAIR => (
+  foreign_alias => "!!!\xFF()!!!_DUMMY_FOREIGN_ALIAS_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFF!!!",
+  self_alias => "!!!\xFE()!!!_DUMMY_SELF_ALIAS_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFE!!!",
+);
+
 # Override forcing no_defer, and adding naming consistency checks
 our %refs_closed_over_by_quote_sub_installed_crefs;
 sub quote_sub {
@@ -381,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
@@ -608,10 +642,10 @@ sub is_exception ($) {
 {
   my $callstack_state;
 
-  # Recreate the logic of try(), while reusing the catch()/finally() as-is
-  #
-  # FIXME: We need to move away from Try::Tiny entirely (way too heavy and
-  # yes, shows up ON TOP of profiles) but this is a batle for another maint
+  # Recreate the logic of Try::Tiny, but without the crazy Sub::Name
+  # invocations and without support for finally() altogether
+  # ( yes, these days Try::Tiny is so "tiny" it shows *ON TOP* of most
+  #   random profiles https://youtu.be/PYCbumw0Fis?t=1919 )
   sub dbic_internal_try (&;@) {
 
     my $try_cref = shift;
@@ -619,30 +653,30 @@ sub is_exception ($) {
 
     for my $arg (@_) {
 
-      if( ref($arg) eq 'Try::Tiny::Catch' ) {
+      croak 'dbic_internal_try() may not be followed by multiple dbic_internal_catch() blocks'
+        if $catch_cref;
 
-        croak 'dbic_internal_try() may not be followed by multiple catch() blocks'
-          if $catch_cref;
+      ($catch_cref = $$arg), next
+        if ref($arg) eq 'DBIx::Class::_Util::Catch';
 
-        $catch_cref = $$arg;
-      }
-      elsif ( ref($arg) eq 'Try::Tiny::Finally' ) {
-        croak 'dbic_internal_try() does not support finally{}';
-      }
-      else {
-        croak(
-          'dbic_internal_try() encountered an unexpected argument '
-        . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps "
-        . 'a missing semi-colon before or ' # trailing space important
-        );
-      }
+      croak( 'Mixing dbic_internal_try() with Try::Tiny::catch() is not supported' )
+        if ref($arg) eq 'Try::Tiny::Catch';
+
+      croak( 'dbic_internal_try() does not support finally{}' )
+        if ref($arg) eq 'Try::Tiny::Finally';
+
+      croak(
+        'dbic_internal_try() encountered an unexpected argument '
+      . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps "
+      . 'a missing semi-colon before or ' # trailing space important
+      );
     }
 
     my $wantarray = wantarray;
     my $preexisting_exception = $@;
 
     my @ret;
-    my $all_good = eval {
+    my $saul_goodman = eval {
       $@ = $preexisting_exception;
 
       local $callstack_state->{in_internal_try} = 1
@@ -667,7 +701,7 @@ sub is_exception ($) {
     my $exception = $@;
     $@ = $preexisting_exception;
 
-    if ( $all_good ) {
+    if ( $saul_goodman ) {
       return $wantarray ? @ret : $ret[0]
     }
     elsif ( $catch_cref ) {
@@ -679,7 +713,23 @@ sub is_exception ($) {
     return;
   }
 
-  sub in_internal_try { !! $callstack_state->{in_internal_try} }
+  sub dbic_internal_catch (&;@) {
+
+    croak( 'Useless use of bare dbic_internal_catch()' )
+      unless wantarray;
+
+    croak( 'dbic_internal_catch() must receive exactly one argument at end of expression' )
+      if @_ > 1;
+
+    bless(
+      \( $_[0] ),
+      'DBIx::Class::_Util::Catch'
+    ),
+  }
+
+  sub in_internal_try () {
+    !! $callstack_state->{in_internal_try}
+  }
 }
 
 {
@@ -1146,6 +1196,17 @@ sub fail_on_internal_call {
     $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
       and
     $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/  # no point touching there
+      and
+    # one step higher
+    @fr2 = CORE::caller(@fr2 ? 3 : 2)
+      and
+    # 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] })
+      }
   ) {
     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",