The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w

##
## Tests errors
## by creating files with incorrect syntax or no "use strict;"
## and run Test::Strict under an external perl interpreter.
## The output is parsed to check result.
##

use strict;
BEGIN {
  if ($^O =~ /win32/i) {
    require Test::More;
    Test::More->import(
      skip_all => "Windows does not allow two processes to access the same file."
    );
  }
}

use Test::More tests => 8;
use File::Temp qw( tempdir tempfile );

my $perl  = $^X || 'perl';
my $inc = join(' -I ', @INC) || '';
$inc = "-I $inc" if $inc;

test1();
test2();
test3();

exit;


sub test1 {
  my $dir = make_bad_file();
  my ($fh, $outfile) = tempfile();
  ok( `$perl $inc -MTest::Strict -e "all_perl_files_ok( '$dir' )" 2>&1 > $outfile` );
  local $/ = undef;
  my $content = <$fh>;
  like( $content, qr/^ok 1 - Syntax check /m, "Syntax ok" );
  like( $content, qr/not ok 2 - use strict /, "Does not have use strict" );
}

sub test2 {
  my $dir = make_another_bad_file();
  my ($fh, $outfile) = tempfile();
  ok( `$perl $inc -MTest::Strict -e "all_perl_files_ok( '$dir' )" 2>&1 > $outfile` );
  local $/ = undef;
  my $content = <$fh>;
  like( $content, qr/not ok 1 - Syntax check /, "Syntax error" );
  like( $content, qr/^ok 2 - use strict /m, "Does have use strict" );
}

sub test3 {
  my $file = make_bad_warning();
  my ($fh, $outfile) = tempfile();
  ok( `$perl $inc -e "use Test::Strict no_plan =>1; warnings_ok( '$file' )" 2>&1 > $outfile` );
  local $/ = undef;
  my $content = <$fh>;
  like( $content, qr/not ok 1 - use warnings /, "Does not have use warnings" );
}



sub make_bad_file {
  my $tmpdir = tempdir();
  my ($fh, $filename) = tempfile( DIR => $tmpdir, SUFFIX => '.pL' );
  print $fh <<'DUMMY';
print "Hello world without use strict";
# use strict;
=over
use strict;
=back

=for
use strict;
=end

=pod
use strict;
=cut

DUMMY
  return $tmpdir;
}

sub make_another_bad_file {
  my $tmpdir = tempdir();
  my ($fh, $filename) = tempfile( DIR => $tmpdir, SUFFIX => '.pm' );
  print $fh <<'DUMMY';
=pod
blah
=cut
# a comment
undef;use    strict ; foobarbaz + 1; # another comment
DUMMY
  return $tmpdir;
}


sub make_bad_warning {
  my $tmpdir = tempdir();
  my ($fh, $filename) = tempfile( DIR => $tmpdir, SUFFIX => '.pL' );
  print $fh <<'DUMMY';
print "Hello world without use warnings";
# use warnings;
=over
use warnings;
=back

=for
use warnings;
=end

=pod
use warnings;
=cut

DUMMY
  return $filename;
}