From: Peter Rabbitson <ribasushi@cpan.org>
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'