# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
# Oh yeah... i do plan on cleaning up the look-and-feel for this test
# script. My goal in throwing the t(), and tsoundex() code in was to
# let me be lazy. Unfortunately the code on the bottom is nasty.
# When i have time... when i have time... :-)
# - mark
BEGIN {
sub t (&);
sub tsoundex;
sub test_label;
}
t {
test_label "use Text::Soundex qw(:Default-Ruleset)";
eval "use Text::Soundex qw(:Default-Ruleset)";
die if $@;
};
t {
test_label "use Text::Soundex qw(:NARA-Ruleset)";
eval "use Text::Soundex qw(:NARA-Ruleset)";
die if $@;
};
t {
test_label "use Text::Soundex qw(soundex_nara)";
eval "use Text::Soundex qw(soundex_nara)";
die if $@;
};
# Knuth's test cases, scalar in, scalar out
tsoundex("Euler" => "E460");
tsoundex("Gauss" => "G200");
tsoundex("Hilbert" => "H416");
tsoundex("Knuth" => "K530");
tsoundex("Lloydi" => "L300");
tsoundex("Lukasiewicz" => "L222");
# check default "no code" code on a bad string and undef
tsoundex("2 + 2 = 4" => undef);
tsoundex(undef() => undef);
# check list context with and without "no code"
tsoundex([qw/Ellery Ghosh Heilbronn Kant Ladd Lissajous/],
[qw/E460 G200 H416 K530 L300 L222 /]);
tsoundex(['Mark', 'Mielke'],
['M620', 'M420']);
tsoundex(['Mike', undef, 'Stok'],
['M200', undef, 'S320']);
# check the deprecated $soundex_nocode and make sure it's reflected in
# the $Text::Soundex::nocode variable.
{
my $nocodeValue = 'Z000';
$soundex_nocode = $nocodeValue;
t {
test_label "setting \$soundex_nocode";
die if soundex(undef) ne $nocodeValue;
};
t {
test_label "\$soundex_nocode eq \$Text::Soundex::nocode";
die if $Text::Soundex::nocode ne $soundex_nocode;
};
}
# make sure an empty argument list returns an undefined scalar
t {
test_label "empty list";
die if defined(soundex());
};
# test to detect an error in Mike Stok's original implementation, the
# error isn't in Mark Mielke's at all but the test should be kept anyway.
# originally spotted by Rich Pinder <rpinder@hsc.usc.edu>
tsoundex("CZARKOWSKA" => "C622");
exit 0;
my $test_label;
sub t (&)
{
my($test_f) = @_;
$test_label = undef;
eval {&$test_f};
my $success = $@ ? "failed" : "ok";
print $test_label, '.' x (60 - (length($test_label) % 80)), $success, "\n";
}
sub tsoundex
{
my($string, $expected) = @_;
if (ref($string) eq 'ARRAY') {
t {
my $s = scalar2string(@$string);
my $e = scalar2string(@$expected);
$test_label = "soundex($s) eq ($e)";
my @codes = soundex(@$string);
for ($i = 0; $i < @$string; $i++) {
my $success = !(defined($codes[$i])||defined($expected->[$i]));
if (defined($codes[$i]) && defined($expected->[$i])) {
$success = ($codes[$i] eq $expected->[$i]);
}
die if !$success;
}
};
} else {
t {
my $s = scalar2string($string);
my $e = scalar2string($expected);
$test_label = "soundex($s) eq $e";
my $code = soundex($string);
my $success = !(defined($code) || defined($expected));
if (defined($code) && defined($expected)) {
$success = ($code eq $expected);
}
die if !$success;
};
}
}
sub test_label
{
$test_label = $_[0];
}
sub scalar2string
{
join(", ", map {defined($_) ? qq{'$_'} : qq{undef}} @_);
}