Standardize the Moo import block, move quote_sub/qsub into ::_Util

This way we will have less boilerplate in subsequent commits where we
will use quote_sub standalone

Add yet another test to make absolutely sure quote_sub won't leak any of the
strictures insanity

diff --git a/lib/DBIx/Class/Storage/BlockRunner.pm b/lib/DBIx/Class/Storage/BlockRunner.pm
index 70ded7e..d65595c 100644 (file)
--- a/lib/DBIx/Class/Storage/BlockRunner.pm
+++ b/lib/DBIx/Class/Storage/BlockRunner.pm
@@ -1,22 +1,26 @@
 package # hide from pause until we figure it all out
   DBIx::Class::Storage::BlockRunner;
 
+use warnings;
 use strict;
 
+# DO NOT edit away without talking to riba first, he will just put it back
+# BEGIN pre-Moo2 import block
+BEGIN {
+  my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all};
+  local $ENV{PERL_STRICTURES_EXTRA} = 0;
+  require Moo; Moo->import;
+  ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} );
+}
+# END pre-Moo2 import block
+
 use DBIx::Class::Exception;
 use DBIx::Class::Carp;
 use Context::Preserve 'preserve_context';
-use DBIx::Class::_Util 'is_exception';
+use DBIx::Class::_Util qw(is_exception qsub);
 use Scalar::Util qw(weaken blessed reftype);
 use Try::Tiny;
 
-# DO NOT edit away without talking to riba first, he will just put it back
-BEGIN {
-  local $ENV{PERL_STRICTURES_EXTRA} = 0;
-  require Moo; Moo->import;
-  require Sub::Quote; Sub::Quote->import('quote_sub');
-}
-use warnings NONFATAL => 'all';
 use namespace::clean;
 
 =head1 NAME
@@ -43,16 +47,16 @@ has wrap_txn => (
 has retry_handler => (
   is => 'ro',
   required => 1,
-  isa => quote_sub( q{
+  isa => qsub q{
     (Scalar::Util::reftype($_[0])||'') eq 'CODE'
       or DBIx::Class::Exception->throw('retry_handler must be a CODE reference')
-  }),
+  },
 );
 
 has retry_debug => (
   is => 'rw',
   # use a sub - to be evaluated on the spot lazily
-  default => quote_sub( '$ENV{DBIC_STORAGE_RETRY_DEBUG}' ),
+  default => qsub '$ENV{DBIC_STORAGE_RETRY_DEBUG}',
   lazy => 1,
 );
 
@@ -67,19 +71,19 @@ has failed_attempt_count => (
   writer => '_set_failed_attempt_count',
   default => 0,
   lazy => 1,
-  trigger => quote_sub(q{
+  trigger => qsub q{
     $_[0]->throw_exception( sprintf (
       'Reached max_attempts amount of %d, latest exception: %s',
       $_[0]->max_attempts, $_[0]->last_exception
     )) if $_[0]->max_attempts <= ($_[1]||0);
-  }),
+  },
 );
 
 has exception_stack => (
   is => 'ro',
   init_arg => undef,
   clearer => '_reset_exception_stack',
-  default => quote_sub(q{ [] }),
+  default => qsub q{ [] },
   lazy => 1,
 );
 

diff --git a/lib/DBIx/Class/Storage/Statistics.pm b/lib/DBIx/Class/Storage/Statistics.pm
index 0248936..e241ad4 100644 (file)
--- a/lib/DBIx/Class/Storage/Statistics.pm
+++ b/lib/DBIx/Class/Storage/Statistics.pm
@@ -1,21 +1,20 @@
 package DBIx::Class::Storage::Statistics;
+
 use strict;
 use warnings;
 
 # DO NOT edit away without talking to riba first, he will just put it back
 # BEGIN pre-Moo2 import block
 BEGIN {
-  require warnings;
   my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all};
   local $ENV{PERL_STRICTURES_EXTRA} = 0;
   require Moo; Moo->import;
-  require Sub::Quote; Sub::Quote->import('quote_sub');
   ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} );
 }
 # END pre-Moo2 import block
 
 extends 'DBIx::Class';
-use DBIx::Class::_Util 'sigwarn_silencer';
+use DBIx::Class::_Util qw(sigwarn_silencer qsub);
 use namespace::clean;
 
 =head1 NAME
@@ -64,7 +63,7 @@ sub debugfh {
 has _debugfh => (
   is => 'rw',
   lazy => 1,
-  trigger => quote_sub( '$_[0]->_defaulted_to_stderr(undef)' ),
+  trigger => qsub '$_[0]->_defaulted_to_stderr(undef)',
   builder => '_build_debugfh',
 );
 

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 8c2ef12..384d3e0 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -55,12 +55,23 @@ use Carp 'croak';
 use Scalar::Util qw(weaken blessed reftype);
 use List::Util qw(first);
 
+# DO NOT edit away without talking to riba first, he will just put it back
+# BEGIN pre-Moo2 import block
+BEGIN {
+  my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all};
+  local $ENV{PERL_STRICTURES_EXTRA} = 0;
+  require Sub::Quote; Sub::Quote->import('quote_sub');
+  ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} );
+}
+sub qsub ($) { goto &quote_sub }  # no point depping on new Moo just for this
+# END pre-Moo2 import block
+
 use base 'Exporter';
 our @EXPORT_OK = qw(
   sigwarn_silencer modver_gt_or_eq
   fail_on_internal_wantarray fail_on_internal_call
   refdesc refcount hrefaddr is_exception
-  perlstring
+  quote_sub qsub perlstring
   UNRESOLVABLE_CONDITION
 );
 

diff --git a/t/53lean_startup.t b/t/53lean_startup.t
index 6868191..27a4dd4 100644 (file)
--- a/t/53lean_startup.t
+++ b/t/53lean_startup.t
@@ -99,6 +99,7 @@ BEGIN {
     namespace::clean
     Try::Tiny
     Sub::Name
+    Sub::Quote
 
     Scalar::Util
     List::Util
@@ -117,7 +118,6 @@ BEGIN {
 {
   register_lazy_loadable_requires(qw(
     Moo
-    Sub::Quote
     Context::Preserve
   ));
 

diff --git a/xt/quote_sub.t b/xt/quote_sub.t
new file mode 100644 (file)
index 0000000..7918cc5
--- /dev/null
+++ b/xt/quote_sub.t
@@ -0,0 +1,48 @@
+use warnings;
+use strict;
+
+use Test::More;
+use Test::Warn;
+
+use DBIx::Class::_Util 'quote_sub';
+
+my $q = do {
+  no strict 'vars';
+  quote_sub '$x = $x . "buh"; $x += 42';
+};
+
+warnings_exist {
+  is $q->(), 42, 'Expected result after uninit and string/num conversion'
+} [
+  qr/Use of uninitialized value/i,
+  qr/isn't numeric in addition/,
+], 'Expected warnings, strict did not leak inside the qsub'
+  or do {
+    require B::Deparse;
+    diag( B::Deparse->new->coderef2text( Sub::Quote::unquote_sub($q) ) )
+  }
+;
+
+my $no_nothing_q = do {
+  no strict;
+  no warnings;
+  quote_sub <<'EOC';
+    my $n = "Test::Warn::warnings_exist";
+    warn "-->@{[ *{$n}{CODE} ]}<--\n";
+    warn "-->@{[ ${^WARNING_BITS} || '' ]}<--\n";
+EOC
+};
+
+my $we_cref = Test::Warn->can('warnings_exist');
+
+warnings_exist { $no_nothing_q->() } [
+  qr/^\Q-->$we_cref<--\E$/m,
+  qr/^\-\-\>\0*\<\-\-$/m, # some perls have a string of nulls, some just an empty string
+], 'Expected warnings, strict did not leak inside the qsub'
+  or do {
+    require B::Deparse;
+    diag( B::Deparse->new->coderef2text( Sub::Quote::unquote_sub($no_nothing_q) ) )
+  }
+;
+
+done_testing;