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