X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=b640e7695b81a02d86379bd4ecd15dbd0fe5657f;hb=534aff61;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..b640e76 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -34,6 +34,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
@@ -47,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
       )
@@ -151,13 +154,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;
   };
@@ -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 }
 
@@ -186,8 +194,8 @@ 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
+  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
@@ -325,7 +333,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
@@ -385,6 +400,61 @@ 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$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 +490,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 +557,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;
   }
@@ -610,10 +679,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 +690,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 '
@@ -698,6 +767,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 +919,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;
@@ -1000,4 +1079,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;