t/strictures.t

   1 BEGIN { $ENV{PERL_STRICTURES_EXTRA} = 0 }
   2
   3 sub _eval { eval $_[0] }
   4
   5 use strict;
   6 use warnings;
   7 use Test::More qw(no_plan);
   8
   9 sub capture_hints {
  10   my $code = shift;
  11   $code .= q{
  12     ;
  13     my @h;
  14     BEGIN { @h = ( $^H, ${^WARNING_BITS} ) }
  15     @h;
  16   };
  17   my ($hints, $warning_bits) = _eval $code or die $@;
  18   # ignore lexicalized hints
  19   $hints &= ~ 0x20000;
  20   $warning_bits = unpack "H*", $warning_bits
  21     if defined $warning_bits;
  22   return ($hints, $warning_bits);
  23 }
  24
  25 sub compare_hints {
  26   my ($code_want, $code_got, $name) = @_;
  27   my ($want_hints, $want_warnings) = capture_hints $code_want;
  28   my ($hints, $warnings) = capture_hints $code_got;
  29   is($hints,    $want_hints, "Hints correct for $name");
  30   is($warnings, $want_warnings,  "Warnings correct for $name");
  31 }
  32
  33 compare_hints q{
  34   use strict;
  35   use warnings FATAL => 'all';
  36 },
  37 q{
  38   use strictures 1;
  39 },
  40   'version 1';
  41
  42 compare_hints q{
  43   use strict;
  44   use warnings 'all';
  45   use warnings FATAL => @strictures::WARNING_CATEGORIES;
  46   no warnings FATAL => @strictures::V2_NONFATAL;
  47   use warnings @strictures::V2_NONFATAL;
  48   no warnings @strictures::V2_DISABLE;
  49 },
  50 q{
  51   use strictures 2;
  52 },
  53   'version 2';
  54
  55 my $v;
  56 eval { $v = strictures->VERSION; 1 } or diag $@;
  57 is $v, $strictures::VERSION, '->VERSION returns version correctly';
  58
  59 my $next = int $strictures::VERSION + 1;
  60 eval qq{ use strictures $next; };
  61
  62 like $@, qr/strictures version $next required/,
  63   "Can't use strictures $next (this is version $v)";