X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FCarp.pm;h=e1c83a0caf39a92b01e6d439bcb08b42fd0370b8;hb=7474ed3b192693baa28d2f52de502f0ec3e8ac4e;hp=24ddd1317fcc1fd31cb2b41ad7bf094afbdd86d1;hpb=5e0e5426b36b5df5f9d1394068cd9f7f1c81087a;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm
index 24ddd13..e1c83a0 100644
--- a/lib/DBIx/Class/Carp.pm
+++ b/lib/DBIx/Class/Carp.pm
@@ -4,49 +4,88 @@ package # hide from pause
 use strict;
 use warnings;
 
-# This is here instead of DBIx::Class because of load-order issues
-BEGIN {
-  # something is tripping up V::M on 5.8.1, leading  to segfaults.
-  # A similar test in n::c itself is disabled on 5.8.1 for the same
-  # reason. There isn't much motivation to try to find why it happens
-  *DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN = ($] < 5.008005)
-    ? sub () { 1 }
-    : sub () { 0 }
-  ;
-}
-
+# load Carp early to prevent tickling of the ::Internal stash being
+# interpreted as "Carp is already loaded" by some braindead loader
 use Carp ();
-use namespace::clean ();
-
 $Carp::Internal{ (__PACKAGE__) }++;
 
+use Scalar::Util ();
+
+# Because... sigh
+# There are cases out there where a user provides a can() that won't actually
+# work as perl intends it. Since this is a reporting library, we *have* to be
+# extra paranoid ( e.g. https://rt.cpan.org/Ticket/Display.html?id=90715 )
+sub __safe_can ($$) {
+  local $@;
+  local $SIG{__DIE__} if $SIG{__DIE__};
+
+  my $cref;
+  eval {
+    $cref = $_[0]->can( $_[1] );
+
+    # in case the can() isn't an actual UNIVERSAL::can()
+    die "Return value of $_[0]" . "->can(q($_[1])) is true yet not a code reference...\n"
+      if $cref and Scalar::Util::reftype($cref) ne 'CODE';
+
+    1;
+  } or do {
+    undef $cref;
+
+    # can not use DBIC::_Util::emit_loud_diag - it uses us internally
+    printf STDERR
+      "\n$0: !!! INTERNAL PANIC !!!\nClass '%s' implements or inherits a broken can() - PLEASE FIX ASAP!: %s\n\n",
+      ( length ref $_[0] ? ref $_[0] : $_[0] ),
+      $@,
+    ;
+  };
+
+  $cref;
+}
+
 sub __find_caller {
   my ($skip_pattern, $class) = @_;
 
   my $skip_class_data = $class->_skip_namespace_frames
-    if ($class and $class->can('_skip_namespace_frames'));
+    if ($class and __safe_can($class, '_skip_namespace_frames') );
 
   $skip_pattern = qr/$skip_pattern|$skip_class_data/
     if $skip_class_data;
 
   my $fr_num = 1; # skip us and the calling carp*
 
-  my (@f, $origin);
-  while (@f = caller($fr_num++)) {
-
-    next if
-      ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ );
+  my (@f, $origin, $eval_src);
+  while (@f = CORE::caller($fr_num++)) {
+
+    undef $eval_src;
+
+    next if (
+      $f[2] == 0
+        or
+      # there is no value reporting a sourceless eval frame
+      (
+        ( $f[3] eq '(eval)' or $f[1] =~ /^\(eval \d+\)$/ )
+          and
+        not defined ( $eval_src = (CORE::caller($fr_num))[6] )
+      )
+        or
+      $f[3] =~ /::__ANON__$/
+    );
 
     $origin ||= (
       $f[3] =~ /^ (.+) :: ([^\:]+) $/x
         and
       ! $Carp::Internal{$1}
         and
-      $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once )$/x
+#############################
+# Need a way to parameterize this for Carp::Skip
+      $1 !~ /^(?: DBIx::Class::Storage::BlockRunner | Context::Preserve | Try::Tiny | Class::Accessor::Grouped | Class::C3::Componentised | Module::Runtime | Sub::Uplevel )$/x
+        and
+      $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks | __delicate_rollback | dbic_internal_try )$/x
+#############################
     ) ? $f[3] : undef;
 
     if (
-      $f[0]->can('_skip_namespace_frames')
+      __safe_can( $f[0], '_skip_namespace_frames' )
         and
       my $extra_skip = $f[0]->_skip_namespace_frames
     ) {
@@ -57,14 +96,18 @@ sub __find_caller {
   }
 
   my $site = @f # if empty - nothing matched - full stack
-    ? "at $f[1] line $f[2]"
+    ? ( "at $f[1] line $f[2]" . ( $eval_src ? "\n    === BEGIN $f[1]\n$eval_src\n    === END $f[1]" : '' ) )
     : Carp::longmess()
   ;
-  $origin ||= '{UNKNOWN}';
 
   return (
     $site,
-    $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan
+    (
+      # cargo-cult from Carp::Clan
+      ! defined $origin   ? ''
+    : $origin =~ /::/     ? "$origin(): "
+                          : "$origin: "
+    ),
   );
 };
 
@@ -125,13 +168,6 @@ sub import {
       $msg,
     );
   };
-
-  # cleanup after ourselves
-  namespace::clean->import(-cleanee => $into, qw/carp carp_once carp_unique/)
-    ## FIXME FIXME FIXME - something is tripping up V::M on 5.8.1, leading
-    # to segfaults. When n::c/B::H::EndOfScope is rewritten in terms of tie()
-    # see if this starts working
-    unless DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN;
 }
 
 sub unimport {
@@ -140,6 +176,8 @@ sub unimport {
 
 1;
 
+__END__
+
 =head1 NAME
 
 DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
@@ -192,4 +230,15 @@ same ruleset as L</carp>).
 Like L</carp> but warns only once for the life of the perl interpreter
 (regardless of callsite).
 
+=head1 FURTHER QUESTIONS?
+
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
+
+=head1 COPYRIGHT AND LICENSE
+
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
+
 =cut