1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
BEGIN {
sub t (&);
sub tsoundex;
sub test_label;
}
t {
test_label "use Text::Soundex 'soundex'";
eval "use Text::Soundex 'soundex'";
die if $@;
};
t {
test_label "use Text::Soundex 'soundex_nara'";
eval "use Text::Soundex 'soundex_nara'";
die if $@;
};
t {
test_label "use Text::Soundex;";
eval "use Text::Soundex";
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}} @_);
}
|
