#!/usr/bin/perl
use strict;
use lib qw {blib/lib};
use Regexp::Common;
use warnings;
sub failures;
use constant PASSES => 20;
use constant FAIL => 10;
my $count;
my $normal = $RE {zip} {Netherlands};
my $no_space = $RE {zip} {Dutch} {-sep => ""};
my $dash = $RE {zip} {Netherlands} {-sep => "-"};
my $prefix = $RE {zip} {Dutch} {-prefix => "yes"};
my $no_prefix = $RE {zip} {Netherlands} {-prefix => "no"};
my $iso = $RE {zip} {Dutch} {-country => "iso"};
my $cept = $RE {zip} {Netherlands} {-country => "cept"};
my $country = $RE {zip} {Dutch} {-country => "NLD"};
my $dash_prefix = $dash -> {-prefix => "yes"};
my $dash_no_prefix = $dash -> {-prefix => "no"};
my @tests = (
[ normal => $normal => [qw /1 1 0 0 0 0 0/]],
[ no_space => $no_space => [qw /0 0 1 1 0 0 0/]],
[ dash => $dash => [qw /0 0 0 0 1 1 0/]],
[ prefix => $prefix => [qw /0 1 0 0 0 0 0/]],
['no prefix' => $no_prefix => [qw /1 0 0 0 0 0 0/]],
[ iso => $iso => [qw /1 1 0 0 0 0 0/]],
[ cept => $cept => [qw /1 1 0 0 0 0 0/]],
[ country => $country => [qw /1 0 0 0 0 0 1/]],
['dash & prefix' => $dash_prefix => [qw /0 0 0 0 0 1 0/]],
['dash & no prefix' => $dash_no_prefix => [qw /0 0 0 0 1 0 0/]],
);
my @failures = failures;
sub mess {print ++ $count, " - $_ (@_)\n"}
sub pass {print "ok "; &mess}
sub fail {print "not ok "; &mess}
my $max = 1 + 2 * @tests * @{$tests [0] -> [2]} * PASSES + @failures * @tests;
print "1..$max\n";
print "ok ", ++ $count, "\n";
sub run_test {
my ($name, $re, $should_match) = @_;
my $match = /^$re$/;
my $line = $match ? "match" : "no match";
$line .= "; $name";
($match xor $should_match) ? fail $line : pass $line
}
sub __ {map {defined () ? $_ : "UNDEF"} @_}
sub run_keep {
my ($name, $re, $should_match) = splice @_ => 0, 3;
unless ($should_match) {
if (/^$re$/) {fail "match; keep - $name"}
else {pass "no match; keep - $name"}
return;
}
my @exp = ($_, $_ [0], join ("" => grep {defined} @_ [1 .. 3]),
@_ [1 .. 3]);
if (my @args = /^$re$/) {
unshift @_ => $_;
unless (@exp == @args) {
fail "match; keep - $name [@{[__ @args]}]";
}
foreach my $n (0 .. $#_) {
unless (!defined $exp [$n] && !defined $args [$n] ||
defined $exp [$n] && defined $args [$n] &&
$exp [$n] eq $args [$n]) {
fail "match; keep - $name [@{[__ @args]}]";
return;
}
}
pass "match; keep - $name";
return;
}
fail "no match; keep - $name";
}
sub _n {
my $min = $_ [0];
my $max = @_ > 1 ? $_ [1] : $_ [0];
my $x = 1 + int rand 9;
$x .= int rand 10 for 2 .. $_ [0] + int rand (1 + $max - $min);
$x;
}
sub _l {
my $min = $_ [0];
my $max = @_ > 1 ? $_ [1] : $_ [0];
my @l = ('A' .. 'Z');
my $x = "";
$x .= $l [int rand @l] for 1 .. $_ [0] + int rand (1 + $max - $min);
$x;
}
my %cache;
foreach my $d (1 .. PASSES) {
my $n = _n 4;
my $l = _l 2;
$l = _l 2 while $l =~ /[FIOQUY]/ || $l =~ /S[ADS]/;
redo if $cache {"$n $l"};
my @t = ([undef, $n, " ", $l],
["NL", $n, " ", $l],
[undef, $n, "", $l],
["NL", $n, "", $l],
[undef, $n, "-", $l],
["NL", $n, "-", $l],
["NLD", $n, " ", $l]);
my $c = 0;
foreach my $t (@t) {
local $_ = defined $t -> [0] ? $t -> [0] . "-" : "";
$_ .= join "" => grep {defined} @{$t} [1 .. 3];
foreach my $test (@tests) {
my ($name, $re, $matches) = @$test;
run_test $name, $re, $matches -> [$c];
run_keep $name, $re -> {-keep}, $matches -> [$c], @$t;
}
$c ++;
}
}
foreach (@failures) {
foreach my $test (@tests) {
my ($name, $re) = @$test;
/^$re$/ ? fail "match; $name" : pass "no match; $name";
}
}
sub failures {
my @failures = ("", " ");
# Zip starting with '0'.
foreach (1 .. FAIL) {
my $x = _n 4;
$x =~ s/^./0/;
my $y .= _l 2;
$y = _l 2 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
redo if $cache {"$x $y"} ++;
push @failures => "$x $y";
}
# Too few numbers.
foreach (1 .. FAIL) {
my $x = _n 1, 3;
my $y .= _l 2;
$y = _l 2 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
redo if $cache {"$x $y"} ++;
push @failures => "$x $y";
}
# Too many numbers.
foreach (1 .. FAIL) {
my $x = _n 5, 10;
my $y .= _l 2;
$y = _l 2 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
redo if $cache {"$x $y"} ++;
push @failures => "$x $y";
}
# Too few letters.
foreach (1 .. FAIL) {
my $x = _n 4;
my $y .= _l 1;
$y = _l 1 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
redo if $cache {"$x $y"} ++;
push @failures => "$x $y";
}
# Too many letters.
foreach (1 .. FAIL) {
my $x = _n 4;
my $y .= _l 3, 6;
$y = _l 3, 6 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
redo if $cache {"$x $y"} ++;
push @failures => "$x $y";
}
# Wrong letters.
foreach (1 .. FAIL) {
my $x = _n 4;
my $y .= _l 2;
$y = _l 2 until $y =~ /[FIOQUY]/;
redo if $cache {"$x $y"} ++;
push @failures => "$x $y";
}
# Wrong letter combos.
foreach (1 .. FAIL) {
my $x = _n 4;
my $y .= ('SA', 'SD', 'SS') [rand 3];
redo if $cache {"$x $y"} ++;
push @failures => "$x $y";
}
# Wrong separator.
foreach (1 .. FAIL) {
my $x = _n 4;
my $y .= _l 2;
$y = _l 2 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
my $s = int rand 256;
redo if +($s & 0x7F) < 0x20;
$s = chr $s;
redo if $s eq ' ' || $s eq '-';
redo if $cache {"$x$s$y"} ++;
push @failures => "$x$s$y";
}
# Lowercase letters.
foreach (1 .. FAIL) {
my $x = _n 4;
my $y .= _l 1;
$y = _l 1 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
$y = lc $y;
redo if $cache {"$x $y"} ++;
push @failures => "$x $y";
}
# Letters, then numbers.
foreach (1 .. FAIL) {
my $x = _n 4;
my $y .= _l 2;
$y = _l 2 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
redo if $cache {"$y $x"} ++;
push @failures => "$y $x";
}
# Leading/trailing garbage.
foreach (1 .. FAIL) {
my $x = _n 4;
my $y .= _l 2;
$y = _l 2 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
redo if $cache {" $x $y"} ++ or $cache {"$x $y "} ++;
push @failures => " $x $y", "$x $y ";
}
push @failures => map {"NL-$_"} @failures;
# Wrong countries.
foreach (1 .. FAIL) {
my $x = _n 4;
my $y .= _l 2;
$y = _l 2 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
my $c = _l 2;
$c = _l 2 while $c eq "NL";
redo if $cache {"$c-$x $y"} ++;
push @failures => "$c-$x $y";
}
# Lowercase countries.
foreach (1 .. FAIL) {
my $x = _n 4;
my $y .= _l 2;
$y = _l 2 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
redo if $cache {"nl-$x $y"} ++;
push @failures => "nl-$x $y";
}
# Too many letters in country.
foreach (1 .. FAIL) {
my $x = _n 4;
my $y .= _l 2;
$y = _l 2 while $y =~ /[FIOQUY]/ || $y =~ /S[ADS]/;
my $c = _l 1;
$c = _l 1 while $c eq "D";
redo if $cache {"${c}NL-$x $y"} ++ || $cache {"NL$c-$x $y"} ++;
push @failures => "${c}NL-$x $y";
push @failures => "NL$c-$x $y";
}
@failures;
};
__END__