-package DBIx::Class::Carp;
+package # hide from pause
+ DBIx::Class::Carp;
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;
- while (@f = caller($fr_num++)) {
- last unless $f[0] =~ $skip_pattern;
+
+ 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
+#############################
+# 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
) {
$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]" . ( $eval_src ? "\n === BEGIN $f[1]\n$eval_src\n === END $f[1]" : '' ) )
+ : Carp::longmess()
;
return (
- $ln,
- $calling =~ /::/ ? "$calling(): " : "$calling: ", # cargo-cult from Carp::Clan
+ $site,
+ (
+ # cargo-cult from Carp::Clan
+ ! defined $origin ? ''
+ : $origin =~ /::/ ? "$origin(): "
+ : "$origin: "
+ ),
);
};
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 DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN();
}
sub unimport {
1;
+__END__
+
=head1 NAME
DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals
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
projects / dbsrgits/DBIx-Class.git / blobdiff