File Coverage

blib/lib/POE/Test/Loops.pm

Criterion	Covered	Total	%
statement	33	127	25.9
branch	0	50	0.0
condition	0	9	0.0
subroutine	11	14	78.5
pod	1	1	100.0
total	45	201	22.3

# vim: ts=2 sw=2 expandtab

package POE::Test::Loops;
$POE::Test::Loops::VERSION = '1.360';
use warnings;
use strict;

use File::Spec;
use File::Path;
use File::Find;

use constant TEST_BLOCK_FOR_WHICH => 0x01;
use constant TEST_BLOCK_FOR_WRONG => 0x02;
use constant TEST_BLOCK_FOR_RIGHT => 0x04;
use constant TEST_BLOCK_BEGIN     => 0x08;

### Find the test libraries.

use lib qw(./lib ../lib);
use POE::Test::DondeEstan;
my $source_base = POE::Test::DondeEstan->marco();

### Generate loop tests.

sub generate {
  my ($dir_base, $loops, $flag_verbose) = @_;

  foreach my $loop (@$loops) {
    my $loop_dir = lc($loop);
    $loop_dir =~ s/::/_/g;

    my $fqmn = _find_event_loop_file($loop);
    unless ($fqmn) {
      $flag_verbose and print "Couldn't find a loop for $loop ...\n";
      next;
    }

    $flag_verbose and print "Found $fqmn\n";

    my $loop_cfg = _get_loop_cfg($fqmn);
    unless (defined $loop_cfg and length $loop_cfg) {
      $loop_cfg = (
				"sub skip_tests { return }"
			);
    }

    my $source = (
			"#!/usr/bin/perl -w\n" .
			"\n" .
			"use strict;\n" .
			"\n" .
			"use lib qw(--base_lib--);\n" .
			"use Test::More;\n" .
			"use POSIX qw(_exit);\n" .
			"\n" .
			"--loop_cfg--\n" .
			"\n" .
			"BEGIN {\n" .
			"  if (my \$why = skip_tests('--test_name--')) {\n" .
			"    plan skip_all => \$why\n" .
			"  }\n" .
			"}\n" .
			"\n" .
			"# Run the tests themselves.\n" .
			"require '--base_file--';\n" .
			"\n" .
			"_exit 0 if \$^O eq 'MSWin32';\n" .
			"CORE::exit 0;\n"
		);

		# Full directory where source files are found.

    my $dir_src = File::Spec->catfile($source_base, "Loops");
    my $dir_dst = File::Spec->catfile($dir_base, $loop_dir);

		# Gather the list of source files.
		# Each will be used to generate a real test file.

    opendir BASE, $dir_src or die $!;
    my @base_files = grep /\.pm$/, readdir(BASE);
    closedir BASE;

		# Initialize the destination directory.  Clear or create as needed.

    $dir_dst =~ tr[/][/]s;
    $dir_dst =~ s{/+$}{};

    rmtree($dir_dst);
    mkpath($dir_dst, 0, 0755);

		# For each source file, generate a corresponding one in the
		# configured destination directory.  Expand various bits to
		# customize the test.

    foreach my $base_file (@base_files) {
      my $test_name = $base_file;
      $test_name =~ s/\.pm$//;

      my $full_file = File::Spec->catfile($dir_dst, $base_file);
      $full_file =~ s/\.pm$/.t/;

			# These hardcoded expansions are for the base file to be required,
			# and the base library directory where it'll be found.

      my $expanded_src = $source;
      $expanded_src =~ s/--base_file--/$base_file/g;
      $expanded_src =~ s/--base_lib--/$dir_src/g;
      $expanded_src =~ s/--loop_cfg--/$loop_cfg/g;
      $expanded_src =~ s/--test_name--/$test_name/g;

			# Write with lots of error checking.

      open EXPANDED, ">$full_file" or die $!;
      print EXPANDED $expanded_src;
      close EXPANDED or die $!;
    }
  }
}

sub _find_event_loop_file {
  my $loop_name = shift;

  my $loop_module;
  if ($loop_name =~ /^POE::/) {
    $loop_module = File::Spec->catfile(split(/::/, $loop_name)) . ".pm";
  }
  else {
    $loop_name =~ s/::/_/g;
    $loop_module = File::Spec->catfile("POE", "Loop", $loop_name) .  ".pm";
  }

  foreach my $inc (@INC) {
    my $fqmn = File::Spec->catfile($inc, $loop_module);
    next unless -f $fqmn;
    return $fqmn;
  }

  return;
}

sub _get_loop_cfg {
  my $fqmn = shift;

  my ($in_test_block, @test_source);

  open SOURCE, "<$fqmn" or die $!;
  while () {
    # Not in a test block.
    unless ($in_test_block) {

      # Proper =for syntax.
      if (/^=for\s+poe_tests\s+(\S.*?)$/) {
        push @test_source, $1;
        $in_test_block = TEST_BLOCK_FOR_RIGHT;
        next;
      }

      # Not sure which =for syntax is in use.
      if (/^=for\s+poe_tests\s*$/) {
        $in_test_block = TEST_BLOCK_FOR_WHICH;
        next;
      }

      if (/^=begin\s+(poe_tests)\s*$/) {
        $in_test_block = TEST_BLOCK_BEGIN;
        next;
      }

      # Some random line.  Do nothing.
      next;
    }

    # Which test block format are we in?
    if ($in_test_block & TEST_BLOCK_FOR_WHICH) {
      # If the following line is blank, then we're probably in the
      # wrong, multi-line kind originally documented and now
      # deprecated.
      if (/^\s*$/) {
        $in_test_block = TEST_BLOCK_FOR_WRONG;
        next;
      }

      # The following line is not blank, so it appears we're in a
      # properly formatted =for paragraph.
      $in_test_block = TEST_BLOCK_FOR_RIGHT;
      push @test_source, $_;
      next;
    }

    # The =begin syntax ends with an =end.
    if ($in_test_block & TEST_BLOCK_BEGIN) {
      if (/^=end\s*poe_tests\s*$/) {
        $in_test_block = 0;
        next;
      }

      # Be helpful?
      die "=cut not the proper way to end =begin poe_tests" if /^=cut\s*$/;

      push @test_source, $_;
      next;
    }

    # The proper =for syntax ends on a blank line.
    if ($in_test_block & TEST_BLOCK_FOR_RIGHT) {
      if (/^$/) {
        $in_test_block = 0;
        next;
      }

      # Be helpful?
      die "=cut not the proper way to end =for poe_tests" if /^=cut\s*$/;

      push @test_source, $_;
      next;
    }

    # The wrong =for syntax ends on =cut.
    if ($in_test_block & TEST_BLOCK_FOR_WRONG) {
      if (/^=cut\s*$/) {
        $in_test_block = 0;
        next;
      }

      # Be helpful?
      die "=end not the proper way to end =for poe_tests" if /^=end/;

      push @test_source, $_;
      next;
    }

    die "parser in unknown state: $in_test_block";
  }

  shift @test_source while @test_source and $test_source[0] =~ /^\s*$/;
  pop @test_source while @test_source and $test_source[-1] =~ /^\s*$/;

  return join "", @test_source;
}

1;

__END__