File Coverage

blib/lib/Test/NoPlan.pm

Criterion	Covered	Total	%
statement	27	109	24.7
branch	0	56	0.0
condition	0	26	0.0
subroutine	9	13	69.2
pod	3	3	100.0
total	39	207	18.8

package Test::NoPlan;

use warnings;
use strict;

use version; our $VERSION = version->new('0.0.6');

use base 'Exporter';
use Test::Builder::Module;

use FindBin qw($Bin);
use Cwd;
use File::Spec;
use Carp;

our @EXPORT = qw( all_plans_ok );  ## no critic (ProhibitAutomaticExportation)
our @EXPORT_OK = qw( get_file_list check_file_for_no_plan );

{
    my $CLASS = __PACKAGE__;

    my @allowed_args
        = qw/ check_files recurse topdir _stdout _stderr method ignore_files /;

    sub all_plans_ok {
        my ($arg_ref) = @_;
        $arg_ref->{method} ||= 'create';
        _check_args($arg_ref);

        my @files = get_file_list($arg_ref);

        my $method = $arg_ref->{method};
        my $test   = Test::Builder->$method;
        if ( $arg_ref->{_stdout} ) {
            if ( ref $arg_ref->{_stdout} ne 'IO::Scalar' ) {
                croak '_stdout is not an IO::Scalar';
            }
            $test->output( $arg_ref->{_stdout} );
        }
        if ( $arg_ref->{_stderr} ) {
            if ( ref $arg_ref->{_stderr} ne 'IO::Scalar' ) {
                croak '_stderr is not an IO::Scalar';
            }
            $test->failure_output( $arg_ref->{_stderr} );
        }

        if ( $method eq 'create' ) {
            $test->plan( tests => scalar @files );
        }
        else {
            $test->no_ending();
        }

        foreach my $file (@files) {
            $test->ok( check_file_for_no_plan($file),
                "'$file' has 'no_plan' set" );
        }

        if ( $method ne 'create' ) {
            $test->reset_outputs();
        }

        return scalar @files;
    }

    sub _check_args {
        my ($arg_ref) = @_;
        if ( defined($arg_ref) && ref($arg_ref) ne 'HASH' ) {
            croak 'arguments do not seem to be a hash -> ', ref($arg_ref);
        }

        my @unknown_args;

        foreach my $arg ( sort( keys(%$arg_ref) ) ) {
            if ( !grep {/^$arg$/} @allowed_args ) {
                push @unknown_args, $arg;
            }
        }
        if (@unknown_args) {
            die 'Unknown arguments: ', join( ',', @unknown_args );
        }

        if ( $arg_ref->{method} ) {
            if (   $arg_ref->{method} ne 'create'
                && $arg_ref->{method} ne 'new' )
            {
                croak 'Method must be one of "create" or "new", not "',
                    $arg_ref->{method}, '"';
            }
        }
        return;
    }

    sub get_file_list {
        my ($arg_ref) = @_;

        _check_args($arg_ref);

        my $topdir = $Bin;
        if ( $arg_ref->{topdir} && $arg_ref->{topdir} ne '.' ) {
            $topdir = $arg_ref->{topdir};
        }
        if ( defined($topdir) && length $topdir && !-d $topdir ) {
            die( 'Invalid topdir provided: "' . $topdir . '"' );
        }
        my $cwd = getcwd();
        $topdir =~ s!$cwd/!!;

        my $check_files = qr/\.t$/xsm;
        if ( $arg_ref->{check_files} ) {
            $check_files = $arg_ref->{check_files};
        }
        if ( ref($check_files) ne 'Regexp' ) {
            die 'invalid check_files provided';
        }

        my $ignore_files = qr/^\..*/;
        if ( $arg_ref->{ignore_files} ) {
            $ignore_files = $arg_ref->{ignore_files};
        }

        my @files = ();
        opendir( my $topdir_dh, $topdir )
            or die 'Unable to read ', $topdir, ': ', $!;

        while ( my $dir_entry = readdir($topdir_dh) ) {
            next if ( $dir_entry =~ m/^\./xsm );

            my $resolved_entry = File::Spec->catfile( $topdir, $dir_entry );

            if ( -d $resolved_entry ) {
                if ( $arg_ref->{recurse} ) {
                    my %new_args = %$arg_ref;
                    $new_args{topdir} = $resolved_entry;
                    push @files, get_file_list( \%new_args );

                    #{ %{$arg_ref}, topdir => $resolved_entry, } );
                }
                next;
            }

            if ( $dir_entry =~ $check_files && $dir_entry !~ $ignore_files ) {
                push @files, $resolved_entry;
            }
        }

        closedir($topdir_dh) or die 'Unable to close ', $topdir, ': ', $!;

        return wantarray ? sort @files : "@files";
    }

    sub check_file_for_no_plan {
        my ($file) = @_;

        if ( !-s $file ) {
            croak "'$file' does not exist or is empty";
        }

        open( my $file_fh, '<', $file )
            or die 'Unable to read ' . $file . ': ', $!;
        my $file_contents;
        {
            local $/ = undef;
            $file_contents = <$file_fh>;
        }
        close($file_fh)
            or die 'Unable to close ' . $file . ': ', $!;

        # by default everything is ok, for those tests that do not use
        # Test::More directly
        my $return_code = 1;

        # look for uncommented lines containing Test::More or plan
        # followed by uncommented test keyword - these are ok
        if (   $file_contents =~ m/^[^#]*\bTest::More\b[^#]*\btests\b/xm
            || $file_contents =~ m/^[^#]*\bplan\b[^#]*\btests\b/xm )
        {
            $return_code = 1;
        }

        # look for uncommented lines containing Test::More or plan
        # followed by uncommented no_plan keyword - these are problems
        elsif ($file_contents =~ m/^[^#]*\bTest::More\b[^#]*\bno_plan\b/xm
            || $file_contents =~ m/^[^#]*\bplan\b[^#]*\bno_plan\b/xm )
        {
            $return_code = 0;
        }

        return $return_code;
    }
}

1;    # End of Test::NoPlan

__END__