X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=7e0520b233de516fe242ed094dc190a3142d0a02;hb=367eaf50970dd3fd223ce5e1f0337703f2a6c70e;hp=b4fa5fb55135503d1dc1846cdcf4b82e9408b6f2;hpb=92705f7f05161f7dba36d9b09dc6e893af7b2773;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index b4fa5fb..7e0520b 100644
--- 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;
@@ -34,6 +35,8 @@ BEGIN {
 
     HAS_ITHREADS => $Config{useithreads} ? 1 : 0,
 
+    TAINT_MODE => 0 + ${^TAINT}, # tri-state: 0, 1, -1
+
     UNSTABLE_DOLLARAT => ( PERL_VERSION < 5.013002 ) ? 1 : 0,
 
     ( map
@@ -45,8 +48,10 @@ BEGIN {
       { substr($_, 5) => !!( $ENV{$_} ) }
       qw(
         DBIC_SHUFFLE_UNORDERED_RESULTSETS
-        DBIC_ASSERT_NO_INTERNAL_WANTARRAY
         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
       )
@@ -151,13 +156,11 @@ BEGIN {
   # to be outfits with *COPY PASTED* pieces of lib/DBIx/Class/Storage/*
   # in their production codebases. There is no point in breaking these
   # if whatever they used actually continues to work
-  my $warned;
   my $sigh = sub {
-
-    require Carp;
-    my $cluck = "The @{[ (caller(1))[3] ]} constant is no more - adjust your code" . Carp::longmess();
-
-    warn $cluck unless $warned->{$cluck}++;
+    DBIx::Class::_Util::emit_loud_diag(
+      skip_frames => 1,
+      msg => "The @{[ (caller(1))[3] ]} constant is no more - adjust your code"
+    );
 
     0;
   };
@@ -171,32 +174,46 @@ 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';
 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 }
 
 use base 'Exporter';
 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 set_subname describe_class_methods
-  scope_guard detected_reinvoked_destructor
+  sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_call
+  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 {
@@ -325,7 +342,14 @@ sub visit_namespaces {
   $visited_count;
 }
 
-# FIXME In another life switch this to a polyfill like the one in namespace::clean
+# FIXME In another life switch these to a polyfill like the ones in namespace::clean
+sub get_subname ($) {
+  my $gv = B::svref_2object( $_[0] )->GV;
+  wantarray
+    ? ( $gv->STASH->NAME, $gv->NAME )
+    : ( join '::', $gv->STASH->NAME, $gv->NAME )
+  ;
+}
 sub set_subname ($$) {
 
   # fully qualify name
@@ -336,7 +360,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]);
 }
 
@@ -349,6 +385,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
@@ -372,9 +436,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;
     }
@@ -385,6 +460,64 @@ sub dump_value ($) {
   $dump_str;
 }
 
+my $seen_loud_screams;
+sub emit_loud_diag {
+  my $args = { ref $_[0] eq 'HASH' ? %{$_[0]} : @_ };
+
+  unless ( defined $args->{msg} and length $args->{msg} ) {
+    emit_loud_diag(
+      msg => "No 'msg' value supplied to emit_loud_diag()"
+    );
+    exit 70;
+  }
+
+  my $msg = "\n" . join( ': ',
+    ( $0 eq '-e' ? () : $0 ),
+    $args->{msg}
+  );
+
+  # when we die - we usually want to keep doing it
+  $args->{emit_dups} = !!$args->{confess}
+    unless exists $args->{emit_dups};
+
+  local $Carp::CarpLevel =
+    ( $args->{skip_frames} || 0 )
+      +
+    $Carp::CarpLevel
+      +
+    # hide our own frame
+    1
+  ;
+
+  my $longmess = Carp::longmess();
+
+  # different object references will thwart deduplication without this
+  ( my $key = "${msg}\n${longmess}" ) =~ s/\b0x[0-9a-f]+\b/0x.../gi;
+
+  return $seen_loud_screams->{$key} if
+    $seen_loud_screams->{$key}++
+      and
+    ! $args->{emit_dups}
+  ;
+
+  $msg .= $longmess
+    unless $msg =~ /\n\z/;
+
+  print STDERR "$msg\n"
+    or
+  print STDOUT "\n!!!STDERR ISN'T WRITABLE!!!:$msg\n";
+
+  return $seen_loud_screams->{$key}
+    unless $args->{confess};
+
+  # increment *again*, because... Carp.
+  $Carp::CarpLevel++;
+
+  # not $msg - Carp will reapply the longmess on its own
+  Carp::confess($args->{msg});
+}
+
+
 ###
 ### This is *NOT* boolean.pm - deliberately not using a singleton
 ###
@@ -420,8 +553,9 @@ sub scope_guard (&) {
       1;
     }
       or
-    Carp::cluck(
-      "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@"
+    DBIx::Class::_Util::emit_loud_diag(
+      emit_dups => 1,
+      msg => "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@\n "
     );
   }
 }
@@ -486,18 +620,16 @@ sub is_exception ($) {
       and
     length( my $class = ref $e )
   ) {
-    carp_unique( sprintf(
-      "Objects of external exception class '%s' stringify to '' (the "
+    carp_unique(
+      "Objects of external exception class '$class' stringify to '' (the "
     . 'empty string), implementing the so called null-object-pattern. '
     . 'Given Perl\'s "globally cooperative" exception handling using this '
     . 'class of exceptions is extremely dangerous, as it may (and often '
     . 'does) result in silent discarding of errors. DBIx::Class tries to '
     . 'work around this as much as possible, but other parts of your '
     . 'software stack may not be even aware of the problem. Please submit '
-    . 'a bugreport against the distribution containing %s',
-
-      ($class) x 2,
-    ));
+    . "a bugreport against the distribution containing '$class'",
+    );
 
     $not_blank = 1;
   }
@@ -508,10 +640,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;
@@ -519,30 +651,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
@@ -567,7 +699,7 @@ sub is_exception ($) {
     my $exception = $@;
     $@ = $preexisting_exception;
 
-    if ( $all_good ) {
+    if ( $saul_goodman ) {
       return $wantarray ? @ret : $ret[0]
     }
     elsif ( $catch_cref ) {
@@ -579,7 +711,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}
+  }
 }
 
 {
@@ -610,10 +758,10 @@ sub is_exception ($) {
       for keys %$destruction_registry;
 
     if (! length ref $_[0]) {
-      printf STDERR '%s() expects a blessed reference %s',
-        (caller(0))[3],
-        Carp::longmess,
-      ;
+      emit_loud_diag(
+        emit_dups => 1,
+        msg => (caller(0))[3] . '() expects a blessed reference'
+      );
       return undef; # don't know wtf to do
     }
     elsif (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) {
@@ -621,7 +769,7 @@ sub is_exception ($) {
       return 0;
     }
     else {
-      carp_unique ( sprintf (
+      emit_loud_diag( msg => sprintf (
         'Preventing *MULTIPLE* DESTROY() invocations on %s - an *EXTREMELY '
       . 'DANGEROUS* condition which is *ALMOST CERTAINLY GLOBAL* within your '
       . 'application, affecting *ALL* classes without active protection against '
@@ -650,11 +798,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
@@ -663,6 +810,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;
@@ -698,6 +857,16 @@ sub modver_gt_or_eq_and_lt ($$$) {
     croak "Expecting a class name either as the sole argument or a 'class' option"
       if not defined $class or $class !~ $module_name_rx;
 
+    croak(
+      "The supplied 'class' argument is tainted: this is *extremely* "
+    . 'dangerous, fix your code ASAP!!! ( for more details read through '
+    . 'https://is.gd/perl_mro_taint_wtf )'
+    ) if (
+      DBIx::Class::_ENV_::TAINT_MODE
+        and
+      Scalar::Util::tainted($class)
+    );
+
     $requested_mro ||= mro::get_mro($class);
 
     # mro::set_mro() does not bump pkg_gen - WHAT THE FUCK?!
@@ -840,7 +1009,7 @@ sub modver_gt_or_eq_and_lt ($$$) {
       if (
         ! DBIx::Class::_ENV_::OLD_MRO
           and
-        ${^TAINT}
+        DBIx::Class::_ENV_::TAINT_MODE
       ) {
 
         $slot->{cumulative_gen} = 0;
@@ -902,93 +1071,112 @@ sub mkdir_p ($) {
 }
 
 
-{
-  my $list_ctx_ok_stack_marker;
-
-  sub fail_on_internal_wantarray () {
-    return if $list_ctx_ok_stack_marker;
+sub fail_on_internal_call {
+  my $fr = [ CORE::caller(1) ];
 
-    if (! defined wantarray) {
-      croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard');
-    }
+  die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless (
 
-    my $cf = 1;
-    while ( ( (CORE::caller($cf+1))[3] || '' ) =~ / :: (?:
+    # unlikely but who knows...
+    ! @$fr
 
-      # these are public API parts that alter behavior on wantarray
-      search | search_related | slice | search_literal
+      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'
 
-      # these are explicitly prefixed, since we only recognize them as valid
-      # escapes when they come from the guts of CDBICompat
-      CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all )
+      or
 
-    ) $/x ) {
-      $cf++;
-    }
+    # 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::[^:]+$/
 
-    my ($fr, $want, $argdesc);
-    {
-      package DB;
-      $fr = [ CORE::caller($cf) ];
-      $want = ( CORE::caller($cf-1) )[5];
-      $argdesc = ref $DB::args[0]
-        ? DBIx::Class::_Util::refdesc($DB::args[0])
-        : 'non '
-      ;
-    };
+      or
 
-    if (
-      $want and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
-    ) {
-      DBIx::Class::Exception->throw( sprintf (
-        "Improper use of %s instance in list context at %s line %d\n\n    Stacktrace starts",
-        $argdesc, @{$fr}[1,2]
-      ), 'with_stacktrace');
-    }
+    # 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::/
 
-    weaken( $list_ctx_ok_stack_marker = my $mark = [] );
+      or
 
-    $mark;
-  }
-}
+    grep
+      { $_ eq 'DBIC_method_is_indirect_sugar' }
+      do { no strict 'refs'; attributes::get( \&{ $fr->[3] }) }
+  );
 
-sub fail_on_internal_call {
-  my ($fr, $argdesc);
-  {
-    package DB;
-    $fr = [ CORE::caller(1) ];
-    $argdesc = ref $DB::args[0]
-      ? DBIx::Class::_Util::refdesc($DB::args[0])
-      : ( $DB::args[0] . '' )
-    ;
-  };
 
   my @fr2;
   # need to make allowance for a proxy-yet-direct call
-  my $check_fr = (
-    $fr->[0] eq 'DBIx::Class::ResultSourceProxy'
-      and
-    @fr2 = (CORE::caller(2))
-      and
+  # or for an exception wrapper
+  $fr = \@fr2 if (
     (
-      ( $fr->[3] =~ /([^:])+$/ )[0]
-        eq
-      ( $fr2[3] =~ /([^:])+$/ )[0]
+      $fr->[3] eq '(eval)'
+        and
+      @fr2 = (CORE::caller(2))
     )
-  )
-    ? \@fr2
-    : $fr
-  ;
+      or
+    (
+      $fr->[0] eq 'DBIx::Class::ResultSourceProxy'
+        and
+      @fr2 = (CORE::caller(2))
+        and
+      (
+        ( $fr->[3] =~ /([^:])+$/ )[0]
+          eq
+        ( $fr2[3] =~ /([^:])+$/ )[0]
+      )
+    )
+  );
+
 
   if (
-    $argdesc
+    defined $fr->[0]
+      and
+    $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
+      and
+    $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/  # no point touching there
       and
-    $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/
+    # one step higher
+    @fr2 = CORE::caller(@fr2 ? 3 : 2)
       and
-    $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/  # no point touching there
+    # 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] })
+      }
+    )
+      and
+    (
+      $fr->[3] ne 'DBIx::Class::ResultSet::search'
+        or
+      # these are explicit wantarray-passthrough callsites for search() due to old silly API choice
+      $fr2[3] !~ /^DBIx::Class::Ordered::(?: _group_rs | (?: _ | next_ | previous_ )? siblings )/x
+    )
   ) {
+
+    my $argdesc;
+
+    {
+      package DB;
+
+      my @throwaway = caller( @fr2 ? 2 : 1 );
+
+      # screwing with $DB::args is rather volatile - be extra careful
+      no warnings 'uninitialized';
+
+      $argdesc =
+        ( not defined $DB::args[0] )  ? 'UNAVAILABLE'
+      : ( length ref $DB::args[0] )   ? DBIx::Class::_Util::refdesc($DB::args[0])
+      : $DB::args[0] . ''
+      ;
+    };
+
     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",
       $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do {
@@ -1000,4 +1188,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;