X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=4afa4c22599e7f900fa33dc00cf6ad6e0339216c;hb=d52fc26dd05b56a41494a5ec86cddecfe3587b96;hp=bfb6a2a8c9053b06f48412b533c4e0b72cd948e9;hpb=7302b3e0fadad3321a1e0ad681949b06c9c8601f;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index bfb6a2a..4afa4c2 100644
--- 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
 );
@@ -138,9 +145,11 @@ sub scope_guard (&) {
     eval {
       $_[0]->[0]->();
       1;
-    } or do {
-      Carp::cluck "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@";
-    };
+    }
+      or
+    Carp::cluck(
+      "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@"
+    );
   }
 }
 
@@ -223,6 +232,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 {
@@ -230,6 +318,11 @@ sub is_exception ($) {
       { defined $_ ? ( refaddr($_) => $_ ) : () }
       values %$destruction_registry
     };
+
+    # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+    # collected before leaving this scope. Depending on the code above, this
+    # may very well be just a preventive measure guarding future modifications
+    undef;
   }
 
   # This is almost invariably invoked from within DESTROY