From: Peter Rabbitson Date: Thu, 8 Oct 2015 19:18:49 +0000 (+0200) Subject: Switch several caller() invocations to explicit CORE::caller() X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=821edc0964a64b9d20b7d02c4a738b87e806f32d;p=dbsrgits%2FDBIx-Class-Historic.git Switch several caller() invocations to explicit CORE::caller() This not only fixes an obscure test failure due to an older Sub::Uplevel (it would be too obnoxious to bump the dep just for the test case), but also makes the entire codebase more robust in light of possible rogue/incomplete caller() overrides This was not a simple s/// job - each change was manually evaluated before carrying out Also while at it - fix the utterly annoying *UNKNOWN* eception site-marker: it does not add any information and only confuses things. The heuristics in Carp::Skip is supposed to be much much clearer, need to finish its tests... --- diff --git a/Changes b/Changes index e5c6368..e39994c 100644 --- a/Changes +++ b/Changes @@ -37,6 +37,8 @@ Revision history for DBIx::Class - Make the Optional::Dependencies error messages cpanm-friendly - Incompatibly change values (not keys) of the hash returned by Optional::Dependencies::req_group_list (no known users in the wild) + - Protect tests and codebase from incomplete caller() overrides, like + e.g. RT#32640 0.082820 2015-03-20 20:35 (UTC) * Fixes diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm index 6ae6199..2456d02 100644 --- a/lib/DBIx/Class/Carp.pm +++ b/lib/DBIx/Class/Carp.pm @@ -21,7 +21,7 @@ sub __find_caller { my $fr_num = 1; # skip us and the calling carp* my (@f, $origin); - while (@f = caller($fr_num++)) { + while (@f = CORE::caller($fr_num++)) { next if ( $f[3] eq '(eval)' or $f[3] =~ /::__ANON__$/ ); @@ -33,7 +33,7 @@ sub __find_caller { 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 + $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)$/x ############################# @@ -54,11 +54,15 @@ sub __find_caller { ? "at $f[1] line $f[2]" : Carp::longmess() ; - $origin ||= '{UNKNOWN}'; return ( $site, - $origin =~ /::/ ? "$origin(): " : "$origin: ", # cargo-cult from Carp::Clan + ( + # cargo-cult from Carp::Clan + ! defined $origin ? '' + : $origin =~ /::/ ? "$origin(): " + : "$origin: " + ), ); }; diff --git a/lib/DBIx/Class/Exception.pm b/lib/DBIx/Class/Exception.pm index c127b8e..a5e9945 100644 --- a/lib/DBIx/Class/Exception.pm +++ b/lib/DBIx/Class/Exception.pm @@ -61,7 +61,7 @@ sub throw { # skip all frames that match the original caller, or any of # the dbic-wide classdata patterns my ($ln, $calling) = DBIx::Class::Carp::__find_caller( - '^' . caller() . '$', + '^' . CORE::caller() . '$', 'DBIx::Class', ); diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 2d2de30..a10e50c 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -281,7 +281,7 @@ sub modver_gt_or_eq_and_lt ($$$) { } my $cf = 1; - while ( ( (caller($cf+1))[3] || '' ) =~ / :: (?: + while ( ( (CORE::caller($cf+1))[3] || '' ) =~ / :: (?: # these are public API parts that alter behavior on wantarray search | search_related | slice | search_literal @@ -299,8 +299,8 @@ sub modver_gt_or_eq_and_lt ($$$) { my ($fr, $want, $argdesc); { package DB; - $fr = [ caller($cf) ]; - $want = ( caller($cf-1) )[5]; + $fr = [ CORE::caller($cf) ]; + $want = ( CORE::caller($cf-1) )[5]; $argdesc = ref $DB::args[0] ? DBIx::Class::_Util::refdesc($DB::args[0]) : 'non ' @@ -326,7 +326,7 @@ sub fail_on_internal_call { my ($fr, $argdesc); { package DB; - $fr = [ caller(1) ]; + $fr = [ CORE::caller(1) ]; $argdesc = ref $DB::args[0] ? DBIx::Class::_Util::refdesc($DB::args[0]) : undef diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 985e072..c7aa432 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -53,7 +53,7 @@ sub stacktrace { $frame++; my (@stack, @frame); - while (@frame = caller($frame++)) { + while (@frame = CORE::caller($frame++)) { push @stack, [@frame[3,1,2]]; } diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 447d0ec..ebde9f5 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -207,7 +207,7 @@ sub assert_empty_weakregistry { # in case we hooked bless any extra object creation will wreak # havoc during the assert phase local *CORE::GLOBAL::bless; - *CORE::GLOBAL::bless = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ) }; + *CORE::GLOBAL::bless = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : CORE::caller() ) }; croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; @@ -299,7 +299,7 @@ sub assert_empty_weakregistry { } if (! $quiet and !$leaks_found and ! $tb->in_todo) { - $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] ); + $tb->ok(1, sprintf "No leaks found at %s line %d", (CORE::caller())[1,2] ); } } diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t index afe8c8e..8213a44 100644 --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -227,7 +227,7 @@ for my $post_poison (0,1) { local $SIG{__WARN__} = sub { package DB; my $frnum; - while (my @f = caller(++$frnum) ) { + while (my @f = CORE::caller(++$frnum) ) { push @arg_capture, @DB::args; } };