File Coverage

blib/lib/Text/Fuzzy.pm
Criterion Covered Total %
statement 66 81 81.4
branch 31 46 67.3
condition n/a
subroutine 4 6 66.6
pod 4 4 100.0
total 105 137 76.6


line stmt bran cond sub pod time code
1             package Text::Fuzzy;
2             require Exporter;
3             require DynaLoader;
4              
5             @ISA = qw(Exporter DynaLoader);
6              
7             @EXPORT_OK = qw/fuzzy_index distance_edits/;
8             %EXPORT_TAGS = (
9             all => \@EXPORT_OK,
10             );
11              
12 12     12   764747 use warnings;
  12         124  
  12         420  
13 12     12   66 use strict;
  12         21  
  12         10798  
14             our $VERSION = '0.28_01';
15              
16             __PACKAGE__->bootstrap ($VERSION);
17              
18             # The following routine exports the C routines for the benefit of
19             # "CPAN::Nearest".
20              
21             sub dl_load_flags
22             {
23 12     12 1 3656 return 0x01;
24             }
25              
26             # This is a Perl-based edit distance routine which also returns the
27             # edit steps necessary to convert one string into the other. $distance
28             # is a boolean. If true it switches on
29              
30             our $verbose;
31              
32             sub distance_edits
33             {
34 0     0 1 0 return fuzzy_index (@_, 1);
35             }
36              
37             sub fuzzy_index
38             {
39             # $distance is usually 0 or undefined here.
40              
41 2     2 1 1556 my ($needle, $haystack, $distance) = @_;
42              
43             # Test whether the inputs make any sense here.
44              
45 2         5 my $m = length ($needle);
46 2         3 my $n = length ($haystack);
47 2         4 my $longer;
48 2 100       6 if ($distance) {
49 1 50       5 $longer = $m > $n ? $m : $n;
50             }
51 2         28 my @haystack = split '', $haystack;
52 2         7 my @needle = split '', $needle;
53 2 50       6 print " ", join (" ",@haystack), "\n" if $verbose;
54 2         4 my @row1;
55 2 50       5 print " ", join (" ",@row1), "\n" if $verbose;
56 2         3 my @row2;
57             my @way;
58 2 100       5 if ($distance) {
59 1         5 for (0..$n) {
60 5         14 $way[0][$_] = "i" x $_;
61             }
62 1         4 @row1 = map {$_} (0..$n);
  5         9  
63             }
64             else {
65 1         7 @row1 = (0) x ($n + 1);
66 1         4 for (0..$n) {
67 84         153 $way[0][$_] = '';
68             }
69             }
70 2         5 for (0..$m) {
71 9         20 $way[$_][0] = "d" x $_;
72             }
73 2         5 for my $i (1..$m) {
74 7         10 $row2[0] = $i;
75 7 50       27 print "[", $needle[$i - 1], "] " if $verbose;
76 7 50       10 print $row2[0]," " if $verbose;
77 7         15 for my $j (1..$n) {
78 344         494 my $cost = ($needle[$i-1] ne $haystack[$j-1]);
79 344         420 my $deletion = $row1[$j] + 1;
80 344         407 my $insertion = $row2[$j-1] + 1;
81 344         395 my $substitution = $row1[$j-1] + $cost;
82 344         413 my $min;
83             my $way;
84 344         409 $min = $deletion;
85 344         428 $way = 'd';
86 344 100       502 if ($min > $insertion) {
87 15         17 $min = $insertion;
88 15         20 $way = 'i';
89             }
90 344 100       512 if ($min > $substitution) {
91 41 100       57 if ($cost) {
92 16         20 $way = 'r';
93             }
94             else {
95 25         33 $way = 'k';
96             }
97 41         47 $min = $substitution;
98             }
99 344 100       573 if ($way eq 'd') {
    100          
    50          
100 289 100       665 $way[$i][$j] = ($way[$i-1][$j] ? $way[$i-1][$j]:'') . $way;
101             }
102             elsif ($way eq 'i') {
103 14 50       41 $way[$i][$j] = ($way[$i][$j-1] ? $way[$i][$j-1]:'') . $way;
104             }
105             elsif ($way =~ /[kr]/) {
106 41 100       98 $way[$i][$j] = ($way[$i-1][$j-1] ? $way[$i-1][$j-1]:'') . $way;
107             }
108             else {
109 0         0 die "Internal bug: unrecognized path";
110             }
111 344         440 $row2[$j] = $min;
112 344 50       611 print $row2[$j],$way[$i][$j]," " if $verbose;
113             }
114 7         47 @row1 = @row2;
115 7 50       18 print "\n" if $verbose;
116             }
117 2 100       5 if ($distance) {
118 1         8 return ($row1[$n], $way[$m][$n]);
119             }
120             else {
121             # Windows doesn't like "inf" apparently.
122 1         2 my $mindistance = 1_000_000_000;
123 1         2 my $bestmatch;
124            
125 1         4 for my $j (1..$n) {
126              
127             # The best distance we have found so far.
128              
129 83 100       129 if ($row2[$j] < $mindistance) {
130 4         7 $bestmatch = $j;
131 4         6 $mindistance = $row2[$j];
132             }
133             }
134 1         30 return ($bestmatch, $way[$m][$bestmatch], $mindistance);
135             }
136             }
137              
138             sub nearestv
139             {
140 0     0 1   my ($tf, $array_ref) = @_;
141 0 0         if (wantarray) {
142 0           my @values;
143 0           my @offsets = $tf->nearest ($array_ref);
144 0 0         if (@offsets) {
145 0           for (@offsets) {
146 0           push @values, $array_ref->[$_];
147             }
148 0           return @values;
149             }
150             else {
151 0           return ();
152             }
153             }
154             else {
155 0           my $offset = $tf->nearest ($array_ref);
156 0 0         if (defined $offset) {
157 0           return $array_ref->[$offset];
158             }
159             else {
160 0           return undef;
161             }
162             }
163             }
164              
165              
166             1;