-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) = @_;
if $skip_class_data;
my $fr_num = 1; # skip us and the calling carp*
- my @f;
+
+ my (@f, $origin);
while (@f = caller($fr_num++)) {
- last unless $f[0] =~ $skip_pattern;
+
+ 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 )$/x
+ and
+ $2 !~ /^(?: throw_exception | carp | carp_unique | carp_once | dbh_do | txn_do | with_deferred_fk_checks)$/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()
;
+ $origin ||= '{UNKNOWN}';
return (
- $ln,
- $calling =~ /::/ ? "$calling(): " : "$calling: ", # cargo-cult from Carp::Clan
+ $site,
+ $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan
);
};
);
};
-# 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';
);
};
- 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),
$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 {
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