t/extras.t

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