t/strictures.t

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