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

diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm
index d27df5d..24ddd13 100644
--- a/lib/DBIx/Class/Carp.pm
+++ b/lib/DBIx/Class/Carp.pm
@@ -18,6 +18,8 @@ BEGIN {
 use Carp ();
 use namespace::clean ();
 
+$Carp::Internal{ (__PACKAGE__) }++;
+
 sub __find_caller {
   my ($skip_pattern, $class) = @_;
 
@@ -28,8 +30,21 @@ sub __find_caller {
     if $skip_class_data;
 
   my $fr_num = 1; # skip us and the calling carp*
-  my @f;
+
+  my (@f, $origin);
   while (@f = caller($fr_num++)) {
+
+    next if
+      ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ );
+
+    $origin ||= (
+      $f[3] =~ /^ (.+) :: ([^\:]+) $/x
+        and
+      ! $Carp::Internal{$1}
+        and
+      $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once )$/x
+    ) ? $f[3] : undef;
+
     if (
       $f[0]->can('_skip_namespace_frames')
         and
@@ -41,14 +56,15 @@ sub __find_caller {
     last if $f[0] !~ $skip_pattern;
   }
 
-  my ($ln, $calling) = @f # if empty - nothing matched - full stack
-    ? ( "at $f[1] line $f[2]", $f[3] )
-    : ( Carp::longmess(), '{UNKNOWN}' )
+  my $site = @f # if empty - nothing matched - full stack
+    ? "at $f[1] line $f[2]"
+    : Carp::longmess()
   ;
+  $origin ||= '{UNKNOWN}';
 
   return (
-    $ln,
-    $calling =~ /::/ ? "$calling(): " : "$calling: ", # cargo-cult from Carp::Clan
+    $site,
+    $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan
   );
 };