From: Peter Rabbitson Date: Mon, 23 May 2016 17:42:56 +0000 (+0200) Subject: Force no_defer on DBIC-internal quote_sub() invocations X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e85eb407cd475abef6c489dfd36b4866785e00be;p=dbsrgits%2FDBIx-Class-Historic.git Force no_defer on DBIC-internal quote_sub() invocations --- diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index a20705d..933aa79 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -82,7 +82,7 @@ use B (); use Carp 'croak'; use Storable 'nfreeze'; use Scalar::Util qw(weaken blessed reftype refaddr); -use Sub::Quote qw(qsub quote_sub); +use Sub::Quote qw(qsub); use Sub::Name (); # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone' @@ -102,6 +102,45 @@ our @EXPORT_OK = qw( use constant UNRESOLVABLE_CONDITION => \ '1 = 0'; +BEGIN { + Sub::Quote->VERSION(2.002); +} +# Override forcing no_defer, and adding naming consistency checks +sub quote_sub { + Carp::confess( "Anonymous quoting not supported by the DBIC sub_quote override - supply a sub name" ) if + @_ < 2 + or + ! defined $_[1] + or + length ref $_[1] + ; + + Carp::confess( "The DBIC sub_quote override expects sub name '$_[0]' to be fully qualified" ) + unless $_[0] =~ /::/; + + Carp::confess( "The DBIC sub_quote override expects the sub name '$_[0]' to match the supplied 'package' argument" ) if + $_[3] + and + defined $_[3]->{package} + and + index( $_[0], $_[3]->{package} ) != 0 + ; + + my @caller = caller(0); + my $sq_opts = { + package => $caller[0], + hints => $caller[8], + warning_bits => $caller[9], + hintshash => $caller[10], + %{ $_[3] || {} }, + + # explicitly forced for everything + no_defer => 1, + }; + + my $cref = Sub::Quote::quote_sub( $_[0], $_[1], $_[2]||{}, $sq_opts ); +} + sub sigwarn_silencer ($) { my $pattern = shift; diff --git a/xt/extra/internals/namespaces_cleaned.t b/xt/extra/internals/namespaces_cleaned.t index 8584bd3..e5d74ac 100644 --- a/xt/extra/internals/namespaces_cleaned.t +++ b/xt/extra/internals/namespaces_cleaned.t @@ -109,8 +109,6 @@ my $skip_idx = { map { $_ => 1 } ( my $has_moose = eval { require Moose::Util }; -Sub::Defer::undefer_all(); - my $seen; #inheritance means we will see the same method multiple times for my $mod (@modules) { diff --git a/xt/extra/internals/quote_sub.t b/xt/extra/internals/quote_sub.t index 77b4905..23fb057 100644 --- a/xt/extra/internals/quote_sub.t +++ b/xt/extra/internals/quote_sub.t @@ -6,9 +6,11 @@ use Test::Warn; use DBIx::Class::_Util 'quote_sub'; +### Test for strictures leakage my $q = do { no strict 'vars'; - quote_sub '$x = $x . "buh"; $x += 42'; + quote_sub 'DBICTest::QSUB::nostrict' + => '$x = $x . "buh"; $x += 42'; }; warnings_exist { @@ -23,10 +25,10 @@ warnings_exist { } ; -my $no_nothing_q = do { +my $no_nothing_q = sub { no strict; no warnings; - quote_sub <<'EOC'; + quote_sub 'DBICTest::QSUB::nowarn', <<'EOC'; BEGIN { warn "-->${^WARNING_BITS}<--\n" }; my $n = "Test::Warn::warnings_exist"; warn "-->@{[ *{$n}{CODE} ]}<--\n"; @@ -35,7 +37,7 @@ EOC my $we_cref = Test::Warn->can('warnings_exist'); -warnings_exist { $no_nothing_q->() } [ +warnings_exist { $no_nothing_q->()->() } [ qr/^\-\-\>\0+\<\-\-$/m, qr/^\Q-->$we_cref<--\E$/m, ], 'Expected warnings, strict did not leak inside the qsub'