t/strictures.t

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