1use strict; 2 3my $test_counter; 4 5BEGIN { 6 $test_counter = 0; 7 sub t (&); 8 sub tsoundex; 9 sub test_label; 10} 11 12END { 13 print "1..$test_counter\n"; 14} 15 16t { 17 test_label "use Text::Soundex 'soundex'"; 18 eval "use Text::Soundex 'soundex'"; 19 die if $@; 20}; 21 22t { 23 test_label "use Text::Soundex 'soundex_nara'"; 24 eval "use Text::Soundex 'soundex_nara'"; 25 die if $@; 26}; 27 28t { 29 test_label "use Text::Soundex;"; 30 eval "use Text::Soundex"; 31 die if $@; 32}; 33 34# Knuth's test cases, scalar in, scalar out 35tsoundex("Euler" => "E460"); 36tsoundex("Gauss" => "G200"); 37tsoundex("Hilbert" => "H416"); 38tsoundex("Knuth" => "K530"); 39tsoundex("Lloydi" => "L300"); 40tsoundex("Lukasiewicz" => "L222"); 41 42# check default "no code" code on a bad string and undef 43tsoundex("2 + 2 = 4" => undef); 44tsoundex(undef() => undef); 45 46# check list context with and without "no code" 47tsoundex([qw/Ellery Ghosh Heilbronn Kant Ladd Lissajous/], 48 [qw/E460 G200 H416 K530 L300 L222 /]); 49tsoundex(['Mark', 'Mielke'], 50 ['M620', 'M420']); 51tsoundex(['Mike', undef, 'Stok'], 52 ['M200', undef, 'S320']); 53 54# check the deprecated $soundex_nocode and make sure it's reflected in 55# the $Text::Soundex::nocode variable. 56{ 57 our $soundex_nocode; 58 my $nocodeValue = 'Z000'; 59 $soundex_nocode = $nocodeValue; 60 61 t { 62 test_label "setting \$soundex_nocode"; 63 die if soundex(undef) ne $nocodeValue; 64 }; 65 66 t { 67 test_label "\$soundex_nocode eq \$Text::Soundex::nocode"; 68 die if $Text::Soundex::nocode ne $soundex_nocode; 69 }; 70} 71 72# make sure an empty argument list returns an undefined scalar 73t { 74 test_label "empty list"; 75 die if defined(soundex()); 76}; 77 78# test to detect an error in Mike Stok's original implementation, the 79# error isn't in Mark Mielke's at all but the test should be kept anyway. 80# originally spotted by Rich Pinder <rpinder@hsc.usc.edu> 81tsoundex("CZARKOWSKA" => "C622"); 82 83exit 0; 84 85 86my $test_label; 87 88sub t (&) 89{ 90 my($test_f) = @_; 91 $test_label = undef; 92 eval {&$test_f}; 93 my $ok = $@ ? "not ok" : "ok"; 94 $test_counter++; 95 print "$ok - $test_counter $test_label\n"; 96} 97 98sub tsoundex 99{ 100 my($string, $expected) = @_; 101 if (ref($string) eq 'ARRAY') { 102 t { 103 my $s = scalar2string(@$string); 104 my $e = scalar2string(@$expected); 105 $test_label = "soundex($s) eq ($e)"; 106 my @codes = soundex(@$string); 107 for (my $i = 0; $i < @$string; $i++) { 108 my $success = !(defined($codes[$i])||defined($expected->[$i])); 109 if (defined($codes[$i]) && defined($expected->[$i])) { 110 $success = ($codes[$i] eq $expected->[$i]); 111 } 112 die if !$success; 113 } 114 }; 115 } else { 116 t { 117 my $s = scalar2string($string); 118 my $e = scalar2string($expected); 119 $test_label = "soundex($s) eq $e"; 120 my $code = soundex($string); 121 my $success = !(defined($code) || defined($expected)); 122 if (defined($code) && defined($expected)) { 123 $success = ($code eq $expected); 124 } 125 die if !$success; 126 }; 127 } 128} 129 130sub test_label 131{ 132 $test_label = $_[0]; 133} 134 135sub scalar2string 136{ 137 join(", ", map {defined($_) ? qq{'$_'} : qq{undef}} @_); 138} 139