t/extras.t

   1 BEGIN { delete $ENV{PERL_STRICTURES_EXTRA} }
   2 use strict;
   3 use warnings;
   4 use Test::More $] >= 5.008_004 ? qw(no_plan)
   5   : (skip_all => 'Extra tests disabled on perls <= 5.008003');
   6
   7 use File::Temp;
   8 use Cwd 'cwd';
   9
  10 my %extras;
  11 BEGIN {
  12   %extras = map { $_ => 1 } qw(
  13     indirect.pm
  14     multidimensional.pm
  15     bareword/filehandles.pm
  16   );
  17   $INC{$_} = __FILE__
  18     for keys %extras;
  19 }
  20
  21 use strictures ();
  22
  23 my $indirect = 0;
  24 sub indirect::unimport {
  25   $indirect++;
  26 };
  27
  28 my $cwd = cwd;
  29 for my $version ( 1, 2 ) {
  30
  31   my $tempdir = File::Temp::tempdir('strictures-XXXXXX', CLEANUP => 1, TMPDIR => 1);
  32   chdir $tempdir;
  33
  34   local $strictures::Smells_Like_VCS = undef;
  35   eval qq{
  36 #line 1 "t/nogit.t"
  37 use strictures $version;
  38 1;
  39 } or die "$@";
  40   ok defined $strictures::Smells_Like_VCS, "VCS dir has been checked (v$version)";
  41   ok !$strictures::Smells_Like_VCS,        "VCS dir not detected with no .git (v$version)";
  42
  43   mkdir '.git';
  44
  45   {
  46     local $strictures::Smells_Like_VCS = undef;
  47     eval qq{
  48 #line 1 "t/withgit.t"
  49 use strictures $version;
  50   1;
  51   } or die "$@";
  52     ok defined $strictures::Smells_Like_VCS, "VCS dir has been checked (v$version)";
  53     ok $strictures::Smells_Like_VCS,         "VCS dir detected with .git (v$version)";
  54   }
  55
  56   chdir $cwd;
  57   rmdir $tempdir;
  58
  59   local $strictures::Smells_Like_VCS = 1;
  60
  61   for my $check (
  62     ["file.pl"            => 0],
  63     ["test.pl"            => 0],
  64     ["library.pm"         => 0],
  65     ["t/test.t"           => 1],
  66     ["xt/test.t"          => 1],
  67     ["t/one.faket"        => 1],
  68     ["lib/module.pm"      => 1],
  69     ["other/one.pl"       => 0],
  70     ["other/t/test.t"     => 0],
  71     ["blib/module.pm"     => 1],
  72   ) {
  73     my ($file, $want) = @$check;
  74     $indirect = 0;
  75     eval qq{
  76 #line 1 "$file"
  77 use strictures $version;
  78 1;
  79     } or die "$@";
  80     my $not = $want ? '' : ' not';
  81     is $indirect, $want,
  82       "file named $file does$not get extras (v$version)";
  83   }
  84
  85   {
  86     local $ENV{PERL_STRICTURES_EXTRA} = 1;
  87     local %strictures::extra_load_states = ();
  88     local @INC = (sub {
  89       die "Can't locate $_[1] in \@INC (...).\n"
  90         if $extras{$_[1]};
  91     }, @INC);
  92     local %INC = %INC;
  93     delete $INC{$_}
  94       for keys %extras;
  95
  96     {
  97       open my $fh, '>', \(my $str = '');
  98       my $e;
  99       {
 100         local *STDERR = $fh;
 101         eval qq{
 102 #line 1 "t/load_fail.t"
 103 use strictures $version;
 104 1;
 105         } or $e = "$@";
 106       }
 107       die $e if defined $e;
 108
 109       like(
 110         $str,
 111         qr/Missing were:\n\n  indirect multidimensional bareword::filehandles/,
 112         "failure to load all three extra deps is reported (v$version)"
 113       );
 114     }
 115
 116     {
 117       open my $fh, '>', \(my $str = '');
 118       my $e;
 119       {
 120         local *STDERR = $fh;
 121         eval qq{
 122 #line 1 "t/load_fail.t"
 123 use strictures $version;
 124 1;
 125         } or $e = "$@";
 126       }
 127       die $e if defined $e;
 128
 129       is $str, '', "extra dep load failure is not reported a second time (v$version)";
 130     }
 131   }
 132 }