File Coverage

blib/lib/Test/Tabs.pm

Criterion	Covered	Total	%
statement	99	123	80.4
branch	42	64	65.6
condition	7	18	38.8
subroutine	20	22	90.9
pod	2	2	100.0
total	170	229	74.2

package Test::Tabs;

use 5.008;
use strict;
use warnings;

BEGIN {
	$Test::Tabs::AUTHORITY = 'cpan:TOBYINK';
	$Test::Tabs::VERSION   = '0.003';
}

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

use vars qw( $PERL $UNTAINT_PATTERN $PERL_PATTERN );

$PERL             = $^X || 'perl';
$UNTAINT_PATTERN  = qr|^([-+@\w./:\\]+)$|;
$PERL_PATTERN     = qr/^#!.*perl/;

my %file_find_arg = ($] <= 5.006) ? () : (
	untaint         => 1,
	untaint_pattern => $UNTAINT_PATTERN,
	untaint_skip    => 1,
);

my $Test  = Test::Builder->new;
my $updir = File::Spec->updir();

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

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![\\/]?inc!); # Remove Module::Install
		return if ($File::Find::dir =~ m![\\/]?blib[\\/]man\d$!); # Filter out pod doc in dist
		return if ($File::Find::name =~ m!Build$!i); # Filter out autogenerated Build script
		return unless (-f $File::Find::name && -r _);
		push @found, File::Spec->no_upwards( $File::Find::name );
	};
	my $find_arg = {
		%file_find_arg,
		wanted   => $want_sub,
		no_chdir => 1,
	};
	find( $find_arg, @base_dirs);
	return @found;
}

sub tabs_ok
{
	my $file = shift;
	$file = _module_to_path($file);
	open my $fh, $file or do {
		$Test->ok(0, "whitespace for $file");
		$Test->diag("Could not open $file: $!");
		return;
	};
	my $line        = 0;
	my $last_indent = 0;
	my $ignoring    = 0;
	my $ok          = 1;
	while (<$fh>)
	{
		$line++;

		my $ignore_line = /##\s*WS/i;
		$ignoring = 1 if /#\s*no\s*Test::Tabs/;
		$ignoring = 0 if /#\s*use\s*Test::Tabs/;

		if (/#\s*skip\s*Test::Tabs/)
		{
			$ok
				? $Test->skip($file)
				: $Test->ok($ok, "$file contains skip comment, but problems already encountered");
			return $ok;
		}

		next if (/^\s*#/);
		next if (/^\s*=.+/ .. (/^\s*=(cut|back|end)/ || eof($fh)));
		last if (/^\s*(__END__|__DATA__)/);
		next if $ignoring || $ignore_line;

		my ($indent, $remaining) = (/^([\s\x20]*)(.*)/);
		next unless length $remaining;

		if ($indent =~ /\x20/)
		{
			$Test->diag("$file had space indent on line $line");
			$ok = 0;
		}
		if ($remaining =~ /\t/)
		{
			$Test->diag("$file had non-indenting tab on line $line");
			$ok = 0;
		}
		if ($remaining =~ /\s$/)
		{
			$Test->diag("$file had trailing whitespace on line $line");
			$ok = 0;
		}
		if (length($indent) - $last_indent > 1)
		{
			$Test->diag("$file had jumping indent on line $line");
			$ok = 0;
		}
		$last_indent = length $indent;
	}
	$Test->ok($ok, "whitespace for $file");
	return $ok;
}

sub all_perl_files_ok
{
	local $Test::Builder::Level = $Test::Builder::Level + 1;
	my @files = _all_perl_files( @_ );
	_make_plan();
	foreach my $file ( sort @files )
	{
		tabs_ok($file, "OK tabs in '$file'");
	}
}

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 =~ /\.psgi$/;
	return 1 if $file =~ /\.t$/;
	open (my $fh, $file) or return;
	my $first = <$fh>;
	return 1 if defined $first && ($first =~ $PERL_PATTERN);
	return;
}

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;
}

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

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

sub __silly {
	# this is just for testing really.
	print "$_\n"
	  for 1..3;  ##WS
}

## no Test::Tabs
  1;
## use Test::Tabs

__END__