Test::Strict - Check syntax, presence of use strict; and test coverage

  use Test::Strict tests => 3;
  syntax_ok( 'bin/myscript.pl' );
  strict_ok( 'My::Module', "use strict; in My::Module" );
  warnings_ok( 'lib/My/Module.pm' );

  use Test::Strict;
  all_perl_files_ok(); # Syntax ok and use strict;

  use Test::Strict;
  all_perl_files_ok( @mydirs );

  use Test::Strict;
  all_cover_ok( 80 );  # at least 80% coverage

  use Test::Strict;
  all_cover_ok( 80, 't/' );

  use Test::Strict tests => 18;
  all_perl_files_ok();

  $Test::Strict::TEST_SYNTAX   (default = 1)
  $Test::Strict::TEST_STRICT   (default = 1)
  $Test::Strict::TEST_WARNINGS (default = 0)
  $Test::Strict::TEST_SKIP     (default = []) "Trusted" files to skip

package Test::Strict;

use strict;
use 5.004;
use Test::Builder;
use File::Spec;
use FindBin qw($Bin);
use File::Find;
use Config;

use vars qw( $VERSION $PERL $COVERAGE_THRESHOLD $COVER $UNTAINT_PATTERN $PERL_PATTERN $CAN_USE_WARNINGS $TEST_SYNTAX $TEST_STRICT $TEST_WARNINGS $TEST_SKIP $DEVEL_COVER_OPTIONS $DEVEL_COVER_DB );
$VERSION = '0.14';
$PERL    = $^X || 'perl';
$COVERAGE_THRESHOLD = 50; # 50%
$UNTAINT_PATTERN    = qr|^(.*)$|;
$PERL_PATTERN       = qr/^#!.*perl/;
$CAN_USE_WARNINGS   = ($] >= 5.006);
$TEST_SYNTAX   = 1;  # Check compile
$TEST_STRICT   = 1;  # Check use strict;
$TEST_WARNINGS = 0;  # Check use warnings;
$TEST_SKIP     = []; # List of files to skip check
$DEVEL_COVER_OPTIONS = '+ignore,".Test.Strict\b"';
$DEVEL_COVER_DB      = 'cover_db';
my $IS_WINDOWS = $^O =~ /win|dos/i;

my $Test  = Test::Builder->new;
my $updir = File::Spec->updir();
my %file_find_arg = ($] <= 5.006) ? ()
                                  : (
                                      untaint         => 1,
                                      untaint_pattern => $UNTAINT_PATTERN,
                                      untaint_skip    => 1,
                                    );


sub import {
  my $self   = shift;
  my $caller = caller;
  {
    no strict 'refs';
    *{$caller.'::strict_ok'}         = \&strict_ok;
    *{$caller.'::warnings_ok'}       = \&warnings_ok;
    *{$caller.'::syntax_ok'}         = \&syntax_ok;
    *{$caller.'::all_perl_files_ok'} = \&all_perl_files_ok;
    *{$caller.'::all_cover_ok'}      = \&all_cover_ok;
  }
  $Test->exported_to($caller);
  $Test->plan(@_);
}


##
## _all_perl_files( @dirs )
## Returns a list of perl files in @dir
## if @dir is not provided, it searches from one dir level above
##
sub _all_perl_files {
  my @all_files = _all_files(@_);
  return grep { _is_perl_module($_) || _is_perl_script($_) } @all_files;
}

sub _all_files {
  my @base_dirs = @_ ? @_
                     : File::Spec->catdir($Bin, $updir);
  my @found;
  my $want_sub = sub {
    return if ($File::Find::dir =~ m![\\/]?CVS[\\/]|[\\/]?.svn[\\/]!); # Filter out cvs or subversion dirs/
    return if ($File::Find::dir =~ m![\\/]?blib[\\/]libdoc$!); # Filter out pod doc in dist
    return if ($File::Find::dir =~ m![\\/]?blib[\\/]man\d$!); # Filter out pod doc in dist
    return unless (-f $File::Find::name && -r _);
    push @found, File::Spec->canonpath( File::Spec->no_upwards( $File::Find::name ) );
  };
  my $find_arg = {
                    %file_find_arg,
                    wanted   => $want_sub,
                    no_chdir => 1,
                 };
  find( $find_arg, @base_dirs); # Find all potential file candidates

  my $files_to_skip = $TEST_SKIP || [];
  my %skip = map { $_ => undef } @$files_to_skip;
  return grep { ! exists $skip{$_} } @found; # Exclude files to skip
}

sub syntax_ok {
  my $file     = shift;
  my $test_txt = shift || "Syntax check $file";

  $file = _module_to_path($file);
  unless (-f $file && -r _) {
    $Test->ok( 0, $test_txt );
    $Test->diag( "File $file not found or not readable" );
    return;
  }

  my $is_script = _is_perl_script($file);
  if (not $is_script and not _is_perl_module($file)) {
    $Test->ok( 0, $test_txt );
    $Test->diag( "$file is not a perl module or a perl script" );
    return;
  }

  # Set the environment to compile the script or module
  my $inc = join(' -I ', map{ qq{"$_"} } @INC ) || '';
  $inc = "-I $inc" if $inc;
  $file            = _untaint($file);
  my $perl_bin     = _untaint($PERL);
  local $ENV{PATH} = _untaint($ENV{PATH}) if $ENV{PATH};

  # Add the -t -T switches if they are set in the #! line
  my $switch = '';
  $switch = _taint_switch($file) || '' if $is_script;

  # Compile and check for errors
  my $eval = `$perl_bin $inc -c$switch \"$file\" 2>&1`;
  $file = quotemeta($file);
  my $ok = $eval =~ qr!$file syntax OK!ms;
  $Test->ok($ok, $test_txt);
  unless ($ok) {
    $Test->diag( $eval );
  }
  return $ok;
}

sub strict_ok {
  my $file     = shift;
  my $test_txt = shift || "use strict   $file";
  $file = _module_to_path($file);
  open my $fh, '<', $file or do { $Test->ok(0, $test_txt); $Test->diag("Could not open $file: $!"); return; };
  while (<$fh>) {
    next if (/^\s*#/); # Skip comments
    next if (/^\s*=.+/ .. /^\s*=(cut|back|end)/); # Skip pod
    last if (/^\s*(__END__|__DATA__)/); # End of code
    if ( /\buse\s+strict\s*;/ or /\buse\s+Moose\b/ or /\buse\s+Mouse\b/ ) {
      $Test->ok(1, $test_txt);
      return 1;
    }
  }
  $Test->ok(0, $test_txt);
  return;
}

sub warnings_ok {
  my $file = shift;
  my $test_txt = shift || "use warnings $file";
  $file = _module_to_path($file);
  my $is_module = _is_perl_module( $file );
  my $is_script = _is_perl_script( $file );
  if (!$is_script and $is_module and ! $CAN_USE_WARNINGS) {
    $Test->skip();
    $Test->diag("This version of perl ($]) does not have use warnings - perl 5.6 or higher is required");
    return;
  }

  open my $fh, '<', $file or do { $Test->ok(0, $test_txt); $Test->diag("Could not open $file: $!"); return; };
  while (<$fh>) {
    if ($. == 1 and $is_script and $_ =~ $PERL_PATTERN) {
      if (/perl\s+\-\w*[wW]/) {
        $Test->ok(1, $test_txt);
        return 1;
      }
    }
    last unless $CAN_USE_WARNINGS;
    next if (/^\s*#/); # Skip comments
    next if (/^\s*=.+/ .. /^\s*=(cut|back|end)/); # Skip pod
    last if (/^\s*(__END__|__DATA__)/); # End of code
  if ( /\buse\s+warnings(\s|::|;)/ or /\buse\s+Moose\b/ or /\buse\s+Mouse\b/ ) {
      $Test->ok(1, $test_txt);
      return 1;
    }
  }
  $Test->ok(0, $test_txt);
  return;
}

sub all_perl_files_ok {
  my @files = _all_perl_files( @_ );

  _make_plan();
  foreach my $file ( @files ) {
    syntax_ok( $file )   if $TEST_SYNTAX;
    strict_ok( $file )   if $TEST_STRICT;
    warnings_ok( $file ) if $TEST_WARNINGS;
  }
}

sub all_cover_ok {
  my $threshold = shift || $COVERAGE_THRESHOLD;
  my @dirs = @_ ? @_
                : (File::Spec->splitpath( $0 ))[1] || '.';
  my @all_files = grep { ! /$0$/o && $0 !~ /$_$/ }
                  grep { _is_perl_script($_)     }
                       _all_files(@dirs);
  _make_plan();

  my $cover_bin    = _cover_path() or do{ $Test->skip(); $Test->diag("Cover binary not found"); return};
  my $perl_bin     = _untaint($PERL);
  local $ENV{PATH} = _untaint($ENV{PATH}) if $ENV{PATH};
  if ($IS_WINDOWS and ! -d $DEVEL_COVER_DB) {
    mkdir $DEVEL_COVER_DB or warn "$DEVEL_COVER_DB: $!";
  }
  my $res = `$cover_bin -delete 2>&1`;
  if ($?) {
    $Test->skip();
    $Test->diag("Cover at $cover_bin got error $?: $res");
    return;
  }
  foreach my $file ( @all_files ) {
    $file = _untaint($file);
    `$perl_bin -MDevel::Cover=$DEVEL_COVER_OPTIONS $file`;
    $Test->ok(! $?, "Coverage captured from $file" );
  }
  $Test->ok(my $cover = `$cover_bin 2>&1`, "Got cover");

  my ($total) = ($cover =~ /^\s*Total.+?([\d\.]+)\s*$/m);
  $Test->ok( $total >= $threshold, "coverage = ${total}% > ${threshold}%");
  return $total;
}


sub _is_perl_module {
  $_[0] =~ /\.pm$/i
  ||
  $_[0] =~ /::/;
}


sub _is_perl_script {
  my $file = shift;
  return 1 if $file =~ /\.pl$/i;
  return 1 if $file =~ /\.t$/;
  open my $fh, '<', $file or return;
  my $first = <$fh>;
  return 1 if defined $first && ($first =~ $PERL_PATTERN);
  return;
}

##
## Returns the taint switches -tT in the #! line of a perl script
##
sub _taint_switch {
  my $file = shift;
  open my $fh, '<', $file or return;
  my $first = <$fh>;
  $first =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ or return;
  return $1;
}

##
## Return the path of a module
##
sub _module_to_path {
  my $file = shift;
  return $file unless ($file =~ /::/);
  my @parts = split /::/, $file;
  my $module = File::Spec->catfile(@parts) . '.pm';
  foreach my $dir (@INC) {
    my $candidate = File::Spec->catfile($dir, $module);
    next unless (-e $candidate && -f _ && -r _);
    return $candidate;
  }
  return $file; # non existing file - error is catched elsewhere
}


sub _cover_path {
  return $COVER if defined $COVER;

  my $os_separator = $IS_WINDOWS ? ';' : ':';
  foreach ((split /$os_separator/, $ENV{PATH}), @Config{qw(bin sitedir scriptdir)} ) {
    my $path = $_ || '.';
    my $path_cover = File::Spec->catfile($path, 'cover');
    if ($IS_WINDOWS) {
      next unless (-f $path_cover && -r _);
    }
    else {
      next unless -x $path_cover;
    }
    return $COVER = _untaint($path_cover);
  }
  return;
}


sub _make_plan {
  unless ($Test->has_plan) {
    $Test->plan( 'no_plan' );
  }
  $Test->expected_tests;
}


sub _untaint {
  my @untainted = map {($_ =~ $UNTAINT_PATTERN)} @_;
  wantarray ? @untainted
            : $untainted[0];
}

1;