X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FCarp.pm;h=49c75fb59cf3198f74599a6d6f85ff9cbbd5f665;hb=84efb6d7f74f92330bf03e923a5386bbf5e7cf7e;hp=62170ff821675c578fd5c40cb2ac3bc92899b892;hpb=90cfe42b94a798be8ee5498fd57e2e76adff5156;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm
index 62170ff..49c75fb 100644
--- a/lib/DBIx/Class/Carp.pm
+++ b/lib/DBIx/Class/Carp.pm
@@ -1,10 +1,13 @@
-package DBIx::Class::Carp;
+package # hide from pause
+  DBIx::Class::Carp;
 
 use strict;
 use warnings;
 
+# 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__) }++;
 
 sub __find_caller {
   my ($skip_pattern, $class) = @_;
@@ -16,19 +19,50 @@ sub __find_caller {
     if $skip_class_data;
 
   my $fr_num = 1; # skip us and the calling carp*
-  my @f;
-  while (@f = caller($fr_num++)) {
-    last unless $f[0] =~ $skip_pattern;
+
+  my (@f, $origin);
+  while (@f = CORE::caller($fr_num++)) {
+
+    next if
+      ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ );
+
+    $origin ||= (
+      $f[3] =~ /^ (.+) :: ([^\:]+) $/x
+        and
+      ! $Carp::Internal{$1}
+        and
+#############################
+# 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 )$/x
+#############################
+    ) ? $f[3] : undef;
+
+    if (
+      $f[0]->can('_skip_namespace_frames')
+        and
+      my $extra_skip = $f[0]->_skip_namespace_frames
+    ) {
+      $skip_pattern = qr/$skip_pattern|$extra_skip/;
+    }
+
+    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()
   ;
 
   return (
-    $ln,
-    $calling =~ /::/ ? "$calling(): " : "$calling: ", # cargo-cult from Carp::Clan
+    $site,
+    (
+      # cargo-cult from Carp::Clan
+      ! defined $origin   ? ''
+    : $origin =~ /::/     ? "$origin(): "
+                          : "$origin: "
+    ),
   );
 };
 
@@ -44,20 +78,13 @@ my $warn = sub {
   );
 };
 
-# FIXME - see below
-BEGIN {
-  *__BROKEN_NC = ($] < 5.008003)
-    ? sub () { 1 }
-    : sub () { 0 }
-  ;
-}
 sub import {
   my (undef, $skip_pattern) = @_;
   my $into = caller;
 
   $skip_pattern = $skip_pattern
-    ? qr/ ^ $into $ | $skip_pattern /xo
-    : qr/ ^ $into $ /xo
+    ? qr/ ^ $into $ | $skip_pattern /x
+    : qr/ ^ $into $ /x
   ;
 
   no strict 'refs';
@@ -69,10 +96,10 @@ sub import {
     );
   };
 
-  my $fired;
+  my $fired = {};
   *{"${into}::carp_once"} = sub {
-    return if $fired;
-    $fired = 1;
+    return if $fired->{$_[0]};
+    $fired->{$_[0]} = 1;
 
     $warn->(
       __find_caller($skip_pattern, $into),
@@ -96,13 +123,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 __BROKEN_NC();
 }
 
 sub unimport {
@@ -111,6 +131,8 @@ sub unimport {
 
 1;
 
+__END__
+
 =head1 NAME
 
 DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
@@ -129,7 +151,8 @@ In addition to the classic interface:
 this module also supports a class-data based way to specify the exclusion
 regex. A message is only carped from a callsite that matches neither the
 closed over string, nor the value of L</_skip_namespace_frames> as declared
-on the B<first> callframe origin.
+on any callframe already skipped due to the same mechanism. This is to ensure
+that intermediate callsites can declare their own additional skip-namespaces.
 
 =head1 CLASS ATTRIBUTES
 
@@ -162,4 +185,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