Protect DBIC as best we can from the failure mode in 7cb35852

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

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index bfb6a2a..c22a5c6 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -29,15 +29,21 @@ BEGIN {
     # add an escape for these perls ON SMOKERS - a user will still get death
     PEEPEENESS => ( eval { DBICTest::RunMode->is_smoker } && ( "$]" >= 5.013005 and "$]" <= 5.013006) ),
 
-    SHUFFLE_UNORDERED_RESULTSETS => $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} ? 1 : 0,
-
-    ASSERT_NO_INTERNAL_WANTARRAY => $ENV{DBIC_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0,
-
-    ASSERT_NO_INTERNAL_INDIRECT_CALLS => $ENV{DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS} ? 1 : 0,
-
-    STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE => $ENV{DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE} ? 1 : 0,
-
-    STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE => $ENV{DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE} ? 1 : 0,
+    ( map
+      #
+      # the "DBIC_" prefix below is crucial - this is what makes CI pick up
+      # all envvars without further adjusting its scripts
+      # DO NOT CHANGE to the more logical { $_ => !!( $ENV{"DBIC_$_"} ) }
+      #
+      { substr($_, 5) => !!( $ENV{$_} ) }
+      qw(
+        DBIC_SHUFFLE_UNORDERED_RESULTSETS
+        DBIC_ASSERT_NO_INTERNAL_WANTARRAY
+        DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS
+        DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE
+        DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE
+      )
+    ),
 
     IV_SIZE => $Config{ivsize},
 
@@ -73,7 +79,8 @@ our @EXPORT_OK = qw(
   sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
   fail_on_internal_wantarray fail_on_internal_call
   refdesc refcount hrefaddr
-  scope_guard is_exception detected_reinvoked_destructor
+  scope_guard detected_reinvoked_destructor
+  is_exception dbic_internal_try
   quote_sub qsub perlstring serialize deep_clone
   UNRESOLVABLE_CONDITION
 );
@@ -223,6 +230,85 @@ 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
+  sub dbic_internal_try (&;@) {
+
+    my $try_cref = shift;
+    my $catch_cref = undef;  # apparently this is a thing... https://rt.perl.org/Public/Bug/Display.html?id=119311
+
+    for my $arg (@_) {
+
+      if( ref($arg) eq 'Try::Tiny::Catch' ) {
+
+        croak 'dbic_internal_try() may not be followed by multiple catch() blocks'
+          if $catch_cref;
+
+        $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
+        );
+      }
+    }
+
+    my $wantarray = wantarray;
+    my $preexisting_exception = $@;
+
+    my @ret;
+    my $all_good = eval {
+      $@ = $preexisting_exception;
+
+      local $callstack_state->{in_internal_try} = 1
+        unless $callstack_state->{in_internal_try};
+
+      # always unset - someone may have snuck it in
+      local $SIG{__DIE__}
+        if $SIG{__DIE__};
+
+
+      if( $wantarray ) {
+        @ret = $try_cref->();
+      }
+      elsif( defined $wantarray ) {
+        $ret[0] = $try_cref->();
+      }
+      else {
+        $try_cref->();
+      }
+
+      1;
+    };
+
+    my $exception = $@;
+    $@ = $preexisting_exception;
+
+    if ( $all_good ) {
+      return $wantarray ? @ret : $ret[0]
+    }
+    elsif ( $catch_cref ) {
+      for ( $exception ) {
+        return $catch_cref->($exception);
+      }
+    }
+
+    return;
+  }
+
+  sub in_internal_try { !! $callstack_state->{in_internal_try} }
+}
+
+{
   my $destruction_registry = {};
 
   sub CLONE {