File Coverage

blib/lib/Text/Soundex.pm
Criterion Covered Total %
statement 12 37 32.4
branch 0 12 0.0
condition n/a
subroutine 4 8 50.0
pod 0 4 0.0
total 16 61 26.2


line stmt bran cond sub pod time code
1             # -*- perl -*-
2              
3             # (c) Copyright 1998-2007 by Mark Mielke
4             #
5             # Freedom to use these sources for whatever you want, as long as credit
6             # is given where credit is due, is hereby granted. You may make modifications
7             # where you see fit but leave this copyright somewhere visible. As well, try
8             # to initial any changes you make so that if I like the changes I can
9             # incorporate them into later versions.
10             #
11             # - Mark Mielke
12             #
13              
14             package Text::Soundex;
15             require 5.006;
16              
17 1     1   1417 use Exporter ();
  1         2  
  1         18  
18 1     1   5 use XSLoader ();
  1         1  
  1         15  
19              
20 1     1   4 use strict;
  1         2  
  1         48  
21              
22 1     1   1032 use if $] > 5.016, 'deprecate';
  1         10  
  1         7  
23              
24             our $VERSION = '3.04';
25             our @EXPORT_OK = qw(soundex soundex_unicode soundex_nara soundex_nara_unicode
26             $soundex_nocode);
27             our @EXPORT = qw(soundex soundex_nara $soundex_nocode);
28             our @ISA = qw(Exporter);
29              
30             our $nocode;
31              
32             # Previous releases of Text::Soundex made $nocode available as $soundex_nocode.
33             # For now, this part of the interface is exported and maintained.
34             # In the feature, $soundex_nocode will be deprecated.
35             *Text::Soundex::soundex_nocode = \$nocode;
36              
37             sub soundex_noxs
38             {
39             # Original Soundex algorithm
40              
41 0           my @results = map {
42 0     0 0   my $code = uc($_);
43 0           $code =~ tr/AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr//cd;
44              
45 0 0         if (length($code)) {
46 0           my $firstchar = substr($code, 0, 1);
47 0           $code =~ tr[AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr]
48             [0000000000000000111111112222222222222222333344555566]s;
49 0           ($code = substr($code, 1)) =~ tr/0//d;
50 0           substr($firstchar . $code . '000', 0, 4);
51             } else {
52 0           $nocode;
53             }
54             } @_;
55              
56 0 0         wantarray ? @results : $results[0];
57             }
58              
59             sub soundex_nara
60             {
61             # US census (NARA) algorithm.
62              
63 0           my @results = map {
64 0     0 0   my $code = uc($_);
65 0           $code =~ tr/AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr//cd;
66              
67 0 0         if (length($code)) {
68 0           my $firstchar = substr($code, 0, 1);
69 0           $code =~ tr[AaEeHhIiOoUuWwYyBbFfPpVvCcGgJjKkQqSsXxZzDdTtLlMmNnRr]
70             [0000990000009900111111112222222222222222333344555566]s;
71 0           $code =~ s/(.)9\1/$1/gs;
72 0           ($code = substr($code, 1)) =~ tr/09//d;
73 0           substr($firstchar . $code . '000', 0, 4);
74             } else {
75 0           $nocode
76             }
77             } @_;
78              
79 0 0         wantarray ? @results : $results[0];
80             }
81              
82             sub soundex_unicode
83             {
84 0 0   0 0   require Text::Unidecode unless defined &Text::Unidecode::unidecode;
85 0           soundex(Text::Unidecode::unidecode(@_));
86             }
87              
88             sub soundex_nara_unicode
89             {
90 0 0   0 0   require Text::Unidecode unless defined &Text::Unidecode::unidecode;
91 0           soundex_nara(Text::Unidecode::unidecode(@_));
92             }
93              
94             eval { XSLoader::load(__PACKAGE__, $VERSION) };
95              
96             if (defined(&soundex_xs)) {
97             *soundex = \&soundex_xs;
98             } else {
99             *soundex = \&soundex_noxs;
100             *soundex_xs = sub {
101             require Carp;
102             Carp::croak("XS implementation of Text::Soundex::soundex_xs() ".
103             "could not be loaded");
104             };
105             }
106              
107             1;
108              
109             __END__