The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w
# $Revision: #4 $$Date: 2005/08/31 $$Author: jd150722 $
# DESCRIPTION: Perl ExtUtils: Type 'make test' to test this package
#
# Copyright 2003-2005 by Jeff Dutton.  This program is free software;
# you can redistribute it and/or modify it under the terms of either the GNU
# General Public License or the Perl Artistic License.

use strict;
use Data::Dumper;
use Test;
use vars qw(@TestREs $TestsPerRE);

BEGIN {
    $TestsPerRE = 20;  # Number of random strings chosen and tested for each regular expression
    @TestREs = ( { re=>qr/Hello (\w+)!/,
		   captures=>[ { 1=>"World", },
			       { 1=>"Universe", },
			       { 1=>"Washington", },
			       ], },
		 { re=>qr/((http|https|ftp):\/\/)?(www[0-9]?|ftp|\w+)\.(\w+)\.(com|gov|edu|\w{1,5})/x,
		   captures=>[ { 2=>"http", 3=>"www", 4=>"yahoo", 5=>"com" },
			       { 2=>"ftp", 3=>"secret", 4=>"squirrel", 5=>"xyz", },
			       { 1=>"https://", 2=>"not used because 1 is specified", },
			       ], },

		 # BUG: captures ()'s with quantifiers do not work correctly/ideally
		 #      All values of the capture are hardcoded, not just the last one,
		 #        which is all that needs to be hardcoded.
		 { re=>qr/((0|1)|2){4,} (((((\.|\?|\!)?))){2}){2}/,
		   captures=>[ {                 },
			       { 1=>"0",         }, # Should make at least 4 characters (last is a 0)
			       { 2=>"1",         }, # Should make at least 4 characters (last is a 1)
			       {         3=>".." },
			       {         4=>"?"  },
			       {         5=>"!"  },
			       {         5=>""   },
			       {         6=>"."  },
			       {         6=>""   },
			       {         7=>"?"  },
			       {         7=>""   },
			       ], },
		 );

    plan tests => ($#TestREs+1);
}
BEGIN { require "t/test_utils.pl"; }

use Parse::RandGen;
$Parse::RandGen::Debug = 1;

foreach my $testRE (@TestREs) {
    my $re = Parse::RandGen::Regexp->new($testRE->{re});
    my @testCaptures = @{$testRE->{captures}};
    my $error = "";

  TEST_LOOP:
    foreach my $doMatch (1, 0) {
	foreach my $captures (@testCaptures) {
	    for (my $i=0; $i<$TestsPerRE; $i++) {
		my $data = $re->pick(match=>$doMatch, captures=>$captures);
		my $matchRE = qr/^$testRE->{re}$/;
		my $matches = ($data =~ $matchRE)?1:0;
		my $caps = "";
		foreach my $cap (keys %$captures) {
		    $caps .= ", " if $caps;
		    $caps .= "$cap=>\"".$captures->{$cap}.'"';
		}

		# Use Data Dumper to get readable data (sometimes funky characters are used)
		my $d = Data::Dumper->new([$data]);
		$d->Terse(1)->Indent(0)->Useqq(1);
		my $dispData = $d->Dump();

		if (($matches == $doMatch)
		    || !$doMatch #FIX - currently unable to guarantee a mismatch...  You can always get lucky ;-)
		    ) {
		    printf("Success: %-20s regexp picked a %-6s for ($caps)\n\tinput %s%s\n",
			   $testRE->{re}, ($doMatch?"MATCH":"MISS"), $dispData, ((!$doMatch&&$matches)?"  (the pick was for a MISS, but you can never be sure)":""));
		} else {
		    $error = sprintf("%%Error: %-20s regexp picked a %-6s for ($caps)\n\tinput %s!\n",
				     $testRE->{re}, ($doMatch?"MATCH":"MISS"), $dispData);
		    last TEST_LOOP;
		}
	    }
	}
    }
    warn("\n\n$error\n\n") if $error;
    ok(!$error);
}