t/strictures.t

   1 BEGIN { delete $ENV{PERL_STRICTURES_EXTRA} }
   2
   3 # -e is sufficient here.
   4 -e 't/smells-of-vcs/.git'
   5   or mkdir('t/smells-of-vcs/.git')
   6   or die "Couldn't create fake .git: $!";
   7
   8 use Test::More qw(no_plan);
   9
  10 our (@us, @expect);
  11
  12 sub capture_stuff { [ $^H, ${^WARNING_BITS} ] }
  13
  14 sub capture_us { push @us, capture_stuff }
  15 sub capture_expect { push @expect, capture_stuff }
  16
  17 {
  18   BEGIN { $ENV{PERL_STRICTURES_EXTRA} = 0 }
  19   use strictures 1;
  20   BEGIN { capture_us }
  21   BEGIN { delete $ENV{PERL_STRICTURES_EXTRA} }
  22 }
  23
  24 {
  25   use strict;
  26   use warnings FATAL => 'all';
  27   BEGIN { capture_expect }
  28 }
  29
  30 # I'm assuming here we'll have more cases later. maybe not. eh.
  31
  32 foreach my $idx (0 .. $#us) {
  33   is($us[$idx][0], $expect[$idx][0], 'Hints ok for case '.($idx+1));
  34   is($us[$idx][1], $expect[$idx][1], 'Warnings ok for case '.($idx+1));
  35 }
  36
  37 SKIP: {
  38   skip 'Extra tests disabled on perls <= 5.008003', 1
  39     if $] < 5.008004;
  40   skip 'Not got all the modules to do this', 1
  41     unless eval {
  42       require indirect;
  43       require multidimensional;
  44       require bareword::filehandles;
  45       1;
  46     };
  47   sub Foo::new { 1 }
  48   chdir("t/smells-of-vcs");
  49   local $strictures::Smells_Like_VCS = 1;
  50   foreach my $file (qw(lib/one.pm t/one.faket)) {
  51     ok(!eval { require $file; 1 }, "Failed to load ${file}");
  52     like($@, qr{Indirect call of method}, "Failed due to indirect.pm, ok");
  53   }
  54   ok(eval { require "other/one.pl"; 1 }, "Loaded other/one.pl ok");
  55   chdir("../..");
  56 }
  57
  58 ok(!eval q{use strictures 2; 1; }, "Can't use strictures 2 (this is version 1)");
  59
  60 SKIP: {
  61   skip 'Extra tests disabled on perls <= 5.008003', 1
  62     if $] < 5.008004;
  63   local $ENV{PERL_STRICTURES_EXTRA} = 1;
  64   local $strictures::extra_load_states = undef;
  65   local @INC = ("t/dep_constellations/broken", @INC);
  66   local %INC = %INC;
  67   delete $INC{$_}
  68     for qw( indirect.pm multidimensional.pm bareword/filehandles.pm );
  69
  70   {
  71     open my $fh, '>', \my $str;
  72     local *STDERR = $fh;
  73     strictures->import;
  74     like(
  75       $str,
  76       qr/Missing were:\n\n  indirect multidimensional bareword::filehandles/,
  77       "failure to load all three extra deps is reported"
  78     );
  79   }
  80
  81   {
  82     open my $fh, '>', \my $str;
  83     local *STDERR = $fh;
  84     strictures->import;
  85     ok( !$str, "extra dep load failure is not reported a second time" );
  86   }
  87 }