Centralize loading of DBIx::Class::Exception

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

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 7f3549d..7d26850 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -1,7 +1,8 @@
 package # hide from PAUSE
   DBIx::Class::_Util;
 
-use DBIx::Class::StartupCheck;  # load es early as we can, usually a noop
+# load es early as we can, usually a noop
+use DBIx::Class::StartupCheck;
 
 use warnings;
 use strict;
@@ -50,6 +51,7 @@ BEGIN {
         DBIC_ASSERT_NO_INTERNAL_WANTARRAY
         DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS
         DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+        DBIC_ASSERT_NO_FAILING_SANITY_CHECKS
         DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE
         DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE
       )
@@ -172,6 +174,9 @@ use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( DBIx::Class::_ENV_::PERL_VERSI
 # Carp::Skip to the rescue soon
 use DBIx::Class::Carp '^DBIx::Class|^DBICTest';
 
+# Ensure it is always there, in case we need to do a $schema-less throw()
+use DBIx::Class::Exception ();
+
 use B ();
 use Carp 'croak';
 use Storable 'nfreeze';
@@ -351,7 +356,19 @@ sub set_subname ($$) {
 }
 
 sub serialize ($) {
+  # stable hash order
   local $Storable::canonical = 1;
+
+  # explicitly false - there is nothing sensible that can come out of
+  # an attempt at CODE serialization
+  local $Storable::Deparse;
+
+  # take no chances
+  local $Storable::forgive_me;
+
+  # FIXME
+  # A number of codepaths *expect* this to be Storable.pm-based so that
+  # the STORABLE_freeze hooks in the metadata subtree get executed properly
   nfreeze($_[0]);
 }
 
@@ -387,9 +404,20 @@ sub dump_value ($) {
         ->Deparse(1)
       ;
 
-      $d->Sparseseen(1) if modver_gt_or_eq (
-        'Data::Dumper', '2.136'
-      );
+      # FIXME - this is kinda ridiculous - there ought to be a
+      # Data::Dumper->new_with_defaults or somesuch...
+      #
+      if( modver_gt_or_eq ( 'Data::Dumper', '2.136' ) ) {
+        $d->Sparseseen(1);
+
+        if( modver_gt_or_eq ( 'Data::Dumper', '2.153' ) ) {
+          $d->Maxrecurse(1000);
+
+          if( modver_gt_or_eq ( 'Data::Dumper', '2.160' ) ) {
+            $d->Trailingcomma(1);
+          }
+        }
+      }
 
       $d;
     }
@@ -722,11 +750,10 @@ sub modver_gt_or_eq ($$) {
   croak "Nonsensical minimum version supplied"
     if ! defined $ver or $ver !~ $ver_rx;
 
-  no strict 'refs';
-  my $ver_cache = ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= ( $mod->VERSION
-    ? {}
-    : croak "$mod does not seem to provide a version (perhaps it never loaded)"
-  );
+  my $ver_cache = do {
+    no strict 'refs';
+    ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= {}
+  };
 
   ! defined $ver_cache->{$ver}
     and
@@ -735,6 +762,18 @@ sub modver_gt_or_eq ($$) {
     local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
       if SPURIOUS_VERSION_CHECK_WARNINGS;
 
+    # prevent captures by potential __WARN__ hooks or the like:
+    # there is nothing of value that can be happening here, and
+    # leaving a hook in-place can only serve to fail some test
+    local $SIG{__WARN__} if (
+      ! SPURIOUS_VERSION_CHECK_WARNINGS
+        and
+      $SIG{__WARN__}
+    );
+
+    croak "$mod does not seem to provide a version (perhaps it never loaded)"
+      unless $mod->VERSION;
+
     local $SIG{__DIE__} if $SIG{__DIE__};
     local $@;
     eval { $mod->VERSION($ver) } ? 1 : 0;
@@ -1065,6 +1104,42 @@ sub fail_on_internal_call {
     : $fr
   ;
 
+
+  die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless (
+
+    # unlikely but who knows...
+    ! @$fr
+
+      or
+
+    # This is a weird-ass double-purpose method, only one branch of which is marked
+    # as an illegal indirect call
+    # Hence the 'indirect' attribute makes no sense
+    # FIXME - likely need to mark this in some other manner
+    $fr->[3] eq 'DBIx::Class::ResultSet::new'
+
+      or
+
+    # RsrcProxy stuff is special and not attr-annotated on purpose
+    # Yet it is marked (correctly) as fail_on_internal_call(), as DBIC
+    # itself should not call these methods as first-entry
+    $fr->[3] =~ /^DBIx::Class::ResultSourceProxy::[^:]+$/
+
+      or
+
+    # FIXME - there is likely a more fine-graned way to escape "foreign"
+    # callers, based on annotations... (albeit a slower one)
+    # For the time being just skip in a dumb way
+    $fr->[3] !~ /^DBIx::Class|^DBICx::|^DBICTest::/
+
+      or
+
+    grep
+      { $_ eq 'DBIC_method_is_indirect_sugar' }
+      do { no strict 'refs'; attributes::get( \&{ $fr->[3] }) }
+  );
+
+
   if (
     defined $fr->[0]
       and