The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strictures 1;
use Test::More;
use Test::Fatal;
use File::Temp;

delete $ENV{PERL_STRICTURES_EXTRA}; # ensure the env doesn't break the tests
$strictures::Smells_Like_VCS = 1;

# make sure these are really loaded
no indirect 'fatal';
no multidimensional;
no bareword::filehandles;

our %test_hash;

# inc hook to separate context
my $header = q{
#line 1 "%1$s/_t/%2$s.pm"
package %1$s::_t::%2$s;
use Moo;
};

my %checks = (
  multi => 'my $f = $::test_hash{1,2};',
  indirect => 'my $f = new Test::Builder;',
  bareword => 'open IO, ">", \(my $f);',
);

unshift @INC, sub {
  if ($_[1] =~ m{(.*)/_t/(.*)\.pm}) {
    my $content = sprintf($header, $1, $2) . $checks{$2} . "\n1;\n";
    open my $fh, '<', \$content;
    return $fh;
  }
  return;
};

my $multi_re = qr/Use of multidimensional array emulation/;
like exception { require t::_t::multi; }, $multi_re,
  'files in t get multidimensional strictures';
like exception { require lib::_t::multi; }, $multi_re,
  'files in lib get multidimensional strictures';
like exception { require xt::_t::multi; }, $multi_re,
  'files in xt get multidimensional strictures';
is exception { require other::_t::multi; }, undef,
  'files elsewhere don\'t get multidimensional strictures';

my $indirect_re = qr/Indirect call of method/;
like exception { require t::_t::indirect; }, $indirect_re,
  'files in t get indirect strictures';
like exception { require lib::_t::indirect; }, $indirect_re,
  'files in lib get indirect strictures';
like exception { require xt::_t::indirect; }, $indirect_re,
  'files in xt get indirect strictures';
is exception { require other::_t::indirect; }, undef,
  'files elsewhere don\'t get indirect strictures';

my $bareword_re = qr/Use of bareword filehandle/;
like exception { require t::_t::bareword; }, $bareword_re,
  'files in t get bareword strictures';
like exception { require lib::_t::bareword; }, $bareword_re,
  'files in lib get bareword strictures';
like exception { require xt::_t::bareword; }, $bareword_re,
  'files in xt get bareword strictures';
is exception { require other::_t::bareword; }, undef,
  'files elsewhere don\'t get bareword strictures';

done_testing;