Centralize all user-side rsrc calls to go through result_source()

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

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 6a93f65..c459c73 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -49,6 +49,7 @@ BEGIN {
         DBIC_SHUFFLE_UNORDERED_RESULTSETS
         DBIC_ASSERT_NO_INTERNAL_WANTARRAY
         DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS
+        DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
         DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE
         DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE
       )
@@ -175,10 +176,17 @@ use B ();
 use Carp 'croak';
 use Storable 'nfreeze';
 use Scalar::Util qw(weaken blessed reftype refaddr);
-use Sub::Quote qw(qsub);
 use Sub::Name ();
 use attributes ();
 
+# Usually versions are not specified anywhere aside the Makefile.PL
+# (writing them out in-code is extremely obnoxious)
+# However without a recent enough Moo the quote_sub override fails
+# in very puzzling and hard to detect ways: so add a version check
+# just this once
+use Sub::Quote qw(qsub);
+BEGIN { Sub::Quote->VERSION('2.002002') }
+
 # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone'
 BEGIN { *deep_clone = \&Storable::dclone }
 
@@ -1030,9 +1038,10 @@ sub fail_on_internal_call {
   {
     package DB;
     $fr = [ CORE::caller(1) ];
-    $argdesc = ref $DB::args[0]
-      ? DBIx::Class::_Util::refdesc($DB::args[0])
-      : ( $DB::args[0] . '' )
+    $argdesc =
+      ( not defined $DB::args[0] )  ? 'UNAVAILABLE'
+    : ( length ref $DB::args[0] )   ? DBIx::Class::_Util::refdesc($DB::args[0])
+    : $DB::args[0] . ''
     ;
   };
 
@@ -1054,7 +1063,7 @@ sub fail_on_internal_call {
   ;
 
   if (
-    $argdesc
+    defined $fr->[0]
       and
     $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
       and
@@ -1071,4 +1080,59 @@ sub fail_on_internal_call {
   }
 }
 
+if (DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE) {
+
+  no warnings 'redefine';
+
+  my $next_bless = defined(&CORE::GLOBAL::bless)
+    ? \&CORE::GLOBAL::bless
+    : sub { CORE::bless($_[0], $_[1]) }
+  ;
+
+  *CORE::GLOBAL::bless = sub {
+    my $class = (@_ > 1) ? $_[1] : CORE::caller();
+
+    # allow for reblessing (role application)
+    return $next_bless->( $_[0], $class )
+      if defined blessed $_[0];
+
+    my $obj = $next_bless->( $_[0], $class );
+
+    my $calling_sub = (CORE::caller(1))[3] || '';
+
+    (
+      # before 5.18 ->isa() will choke on the "0" package
+      # which we test for in several obscure cases, sigh...
+      !( DBIx::Class::_ENV_::PERL_VERSION < 5.018 )
+        or
+      $class
+    )
+      and
+    (
+      (
+        $calling_sub !~ /^ (?:
+          DBIx::Class::Schema::clone
+            |
+          DBIx::Class::DB::setup_schema_instance
+        )/x
+          and
+        $class->isa("DBIx::Class::Schema")
+      )
+        or
+      (
+        $calling_sub ne 'DBIx::Class::ResultSource::new'
+          and
+        $class->isa("DBIx::Class::ResultSource")
+      )
+    )
+      and
+    local $Carp::CarpLevel = $Carp::CarpLevel + 1
+      and
+    Carp::confess("Improper instantiation of '$obj': you *MUST* call the corresponding constructor");
+
+
+    $obj;
+  };
+}
+
 1;