xt/extra/internals/quote_sub.t

   1 use warnings;
   2 use strict;
   3
   4 use Test::More;
   5 use Test::Warn;
   6
   7 use DBIx::Class::_Util 'quote_sub';
   8
   9 ### Test for strictures leakage
  10 my $q = do {
  11   no strict 'vars';
  12   quote_sub 'DBICTest::QSUB::nostrict'
  13     => '$x = $x . "buh"; $x += 42';
  14 };
  15
  16 warnings_exist {
  17   is $q->(), 42, 'Expected result after uninit and string/num conversion'
  18 } [
  19   qr/Use of uninitialized value/i,
  20   qr/isn't numeric in addition/,
  21 ], 'Expected warnings, strict did not leak inside the qsub'
  22   or do {
  23     require B::Deparse;
  24     diag( B::Deparse->new->coderef2text( Sub::Quote::unquote_sub($q) ) )
  25   }
  26 ;
  27
  28 my $no_nothing_q = sub {
  29   no strict;
  30   no warnings;
  31   quote_sub 'DBICTest::QSUB::nowarn', <<'EOC';
  32     BEGIN { warn "-->${^WARNING_BITS}<--\n" };
  33     my $n = "Test::Warn::warnings_exist";
  34     warn "-->@{[ *{$n}{CODE} ]}<--\n";
  35 EOC
  36 };
  37
  38 my $we_cref = Test::Warn->can('warnings_exist');
  39
  40 warnings_exist { $no_nothing_q->()->() } [
  41   qr/^\-\-\>\0+\<\-\-$/m,
  42   qr/^\Q-->$we_cref<--\E$/m,
  43 ], 'Expected warnings, strict did not leak inside the qsub'
  44   or do {
  45     require B::Deparse;
  46     diag( B::Deparse->new->coderef2text( Sub::Quote::unquote_sub($no_nothing_q) ) )
  47   }
  48 ;
  49
  50 ### Test the upcoming attributes support
  51 require DBIx::Class;
  52 @DBICTest::QSUB::ISA  = 'DBIx::Class';
  53
  54 my $var = \42;
  55 my $s = quote_sub(
  56   'DBICTest::QSUB::attr',
  57   '$v',
  58   { '$v' => $var },
  59   {
  60     # use grandfathered 'ResultSet' attribute for starters
  61     attributes => [qw( ResultSet )],
  62     package => 'DBICTest::QSUB',
  63   },
  64 );
  65
  66 is $s, \&DBICTest::QSUB::attr, 'Same cref installed';
  67
  68 is DBICTest::QSUB::attr(), 42, 'Sub properly installed and callable';
  69
  70 is_deeply
  71   [ attributes::get( $s ) ],
  72   [ 'ResultSet' ],
  73   'Attribute installed',
  74 unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
  75
  76 done_testing;