view release on metacpan or  search on metacpan

test.pl  view on Meta::CPAN

#!/usr/bin/perl
require 5.00561;

use ExtUtils::testlib;
use Rx;
use strict;
my ($TESTS, $SUCCEED, $FAIL);
$/ = "";
while (<DATA>) {
  chomp;
  s/^#.*$//smg;
  my ($regex, @test_strings) = split /\n/;

  my %test;
  for (@test_strings) {
    my ($type, @args) = split;
    $test{$type} = \@args;
  }
  $test{END} = [length($regex)+1,0] unless exists $test{FAILS};
  $TESTS += exists $test{FAILS} ? 1 : 2 * keys %test;

  my $h = eval { Rx::rxdump($regex) };
  if (! defined $h) {
    if ($test_strings[0] eq 'FAILS') {
      ++$SUCCEED;               # It was *supposed* to fail
    } else {
      print "* Test $. /$regex/ failed to compile.\n";
      $FAIL += 2 * @test_strings;
    }
    next;
  }

  my %untested_node_types;
  my @nodes = (0);
  my %seq;
  while (@nodes) {
    my $nn = shift @nodes;
    my ($off, $len) = ($h->{OFFSETS}[$nn], $h->{LENGTHS}[$nn]);
    my $n = $h->{$nn};
    for my $item (qw(CHILD NEXT LOOKFOR)) {
      push @nodes, $n->{$item} if exists $n->{$item};
    }
    my $key = $n->{TYPE};
    $key .= "-$n->{STRING}" if $key eq 'EXACT';
    $key .= "-$n->{ARGS}" if $key eq 'OPEN' || $key eq 'CLOSE';
    $key .= "-" . ++$seq{$key} if $key eq 'BRANCH';
    if (exists $test{$key}) {
      my ($ex_off, $ex_len) = @{$test{$key}};
      my $good = 2;
      if ($ex_off != $off) {
        print "  Test $. /$regex/: $key had offset $off, s/b $ex_off\n";
        --$good;
      }
      if ($ex_len != $len) {
        print "  Test $. /$regex/: $key had length $len, s/b $ex_len\n";
        --$good;
      }
      $SUCCEED += $good;
      $FAIL += 2 - $good;
      delete $test{$key};
    } else {
      ++$untested_node_types{$key} ;
    }
  }

  $FAIL += 2 * keys %test;
  my $missing_tests;
  for my $testname (keys %test) {