Fix incorrect warning/exception originator

Until now we would report the second to last function as the
exception originator, whereas we need to report the first after
skipping the usual suspects of throw_exception etc

diff --git a/Changes b/Changes
index 543988d..46bb344 100644 (file)
--- a/Changes
+++ b/Changes
@@ -10,6 +10,8 @@ Revision history for DBIx::Class
           DBD::SQLite - RT#79576
         - Audit and correct potential bugs associated with braindead reuse
           of $1 on unsuccessful matches
+        - Fix incorrect warning/exception originator reported by carp*() and
+          throw_exception()
 
 0.08209 2013-03-01 12:56 (UTC)
     * New Features / Changes

diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm
index d27df5d..24ddd13 100644 (file)
--- 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
   );
 };
 

diff --git a/lib/DBIx/Class/Exception.pm b/lib/DBIx/Class/Exception.pm
index 1f56cb5..58319d9 100644 (file)
--- a/lib/DBIx/Class/Exception.pm
+++ b/lib/DBIx/Class/Exception.pm
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 
 use DBIx::Class::Carp ();
+$Carp::Internal{ (__PACKAGE__) }++;
 
 use overload
     '""' => sub { shift->{msg} },

diff --git a/t/106dbic_carp.t b/t/106dbic_carp.t
index 8bd65eb..241fc5d 100644 (file)
--- a/t/106dbic_carp.t
+++ b/t/106dbic_carp.t
@@ -1,27 +1,78 @@
-#!/usr/bin/perl
-
 use strict;
 use warnings;
 
+# without this the stacktrace of $schema will be activated
+BEGIN { $ENV{DBIC_TRACE} = 0 }
+
 use Test::More;
 use Test::Warn;
+use Test::Exception;
 use DBIx::Class::Carp;
 use lib 't/lib';
 use DBICTest;
 
-warnings_exist {
-  DBIx::Class::frobnicate();
-} [
-  qr/carp1/,
-  qr/carp2/,
-], 'expected warnings from carp_once';
+{
+  sub DBICTest::DBICCarp::frobnicate {
+    DBICTest::DBICCarp::branch1();
+    DBICTest::DBICCarp::branch2();
+  }
 
-done_testing;
+  sub DBICTest::DBICCarp::branch1 { carp_once 'carp1' }
+  sub DBICTest::DBICCarp::branch2 { carp_once 'carp2' }
+
+
+  warnings_exist {
+    DBICTest::DBICCarp::frobnicate();
+  } [
+    qr/carp1/,
+    qr/carp2/,
+  ], 'expected warnings from carp_once';
+}
+
+{
+  {
+    package DBICTest::DBICCarp::Exempt;
+    use DBIx::Class::Carp;
 
-sub DBIx::Class::frobnicate {
-  DBIx::Class::branch1();
-  DBIx::Class::branch2();
+    sub _skip_namespace_frames { qr/^DBICTest::DBICCarp::Exempt/ }
+
+    sub thrower {
+      sub {
+        DBICTest->init_schema(no_deploy => 1)->throw_exception('time to die');
+      }->();
+    }
+
+    sub dcaller {
+      sub {
+        thrower();
+      }->();
+    }
+
+    sub warner {
+      eval {
+        sub {
+          eval {
+            carp ('time to warn')
+          }
+        }->()
+      }
+    }
+
+    sub wcaller {
+      warner();
+    }
+  }
+
+  # the __LINE__ relationship below is important - do not reformat
+  throws_ok { DBICTest::DBICCarp::Exempt::dcaller() }
+    qr/\QDBICTest::DBICCarp::Exempt::thrower(): time to die at @{[ __FILE__ ]} line @{[ __LINE__ - 1 ]}\E$/,
+    'Expected exception callsite and originator'
+  ;
+
+  # the __LINE__ relationship below is important - do not reformat
+  warnings_like { DBICTest::DBICCarp::Exempt::wcaller() }
+    qr/\QDBICTest::DBICCarp::Exempt::warner(): time to warn at @{[ __FILE__ ]} line @{[ __LINE__ - 1 ]}\E$/,
+  ;
 }
 
-sub DBIx::Class::branch1 { carp_once 'carp1' }
-sub DBIx::Class::branch2 { carp_once 'carp2' }
+done_testing;

diff --git a/t/61findnot.t b/t/61findnot.t
index d7dde4d..7a539d6 100644 (file)
--- a/t/61findnot.t
+++ b/t/61findnot.t
@@ -57,7 +57,7 @@ $artist_rs = $schema->resultset("Artist");
 
 warnings_exist {
   $artist_rs->find({})
-} qr/\QDBIx::Class::ResultSet::find(): Query returned more than one row.  SQL that returns multiple rows is DEPRECATED for ->find and ->single/
+} qr/\QQuery returned more than one row.  SQL that returns multiple rows is DEPRECATED for ->find and ->single/
     =>  "Non-unique find generated a cursor inexhaustion warning";
 
 throws_ok {