X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FCarp.pm;h=e1c83a0caf39a92b01e6d439bcb08b42fd0370b8;hb=7474ed3b192693baa28d2f52de502f0ec3e8ac4e;hp=6bec374ee748e0ae5087d75ba88bbd3d2b4967f3;hpb=dee99c2433a9f090cba9dd0349459a1df0b25c3a;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm index 6bec374..e1c83a0 100644 --- a/lib/DBIx/Class/Carp.pm +++ b/lib/DBIx/Class/Carp.pm @@ -1,53 +1,113 @@ -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: " + ), ); }; @@ -68,8 +128,8 @@ sub import { 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'; @@ -81,10 +141,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), @@ -108,13 +168,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 DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN(); } sub unimport { @@ -123,6 +176,8 @@ sub unimport { 1; +__END__ + =head1 NAME DBIx::Class::Carp - Provides advanced Carp::Clan-like warning functions for DBIx::Class internals @@ -175,4 +230,15 @@ same ruleset as L). Like L but warns only once for the life of the perl interpreter (regardless of callsite). +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. + =cut