File Coverage

blib/lib/String/Approx.pm
Criterion Covered Total %
statement 205 283 72.4
branch 125 188 66.4
condition 11 15 73.3
subroutine 18 26 69.2
pod 1 14 7.1
total 360 526 68.4


line stmt bran cond sub pod time code
1             package String::Approx;
2              
3             require v5.8.0;
4              
5             $VERSION = '3.28';
6              
7 7     7   2854 use strict;
  7         10  
  7         270  
8             local $^W = 1;
9              
10 7     7   24 use Carp;
  7         10  
  7         452  
11 7     7   23 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  7         11  
  7         2813  
12              
13             require Exporter;
14             require DynaLoader;
15              
16             @ISA = qw(Exporter DynaLoader);
17              
18             @EXPORT_OK = qw(amatch asubstitute aindex aslice arindex
19             adist adistr adistword adistrword);
20              
21             bootstrap String::Approx $VERSION;
22              
23             my $CACHE_MAX = 1000; # high water mark
24             my $CACHE_PURGE = 0.75; # purge this much of the least used
25             my $CACHE_N_PURGE; # purge this many of the least used
26              
27             sub cache_n_purge () {
28 7     7 0 19 $CACHE_N_PURGE = $CACHE_MAX * $CACHE_PURGE;
29 7 50       24 $CACHE_N_PURGE = 1 if $CACHE_N_PURGE < 1;
30 7         8 return $CACHE_N_PURGE;
31             }
32              
33             cache_n_purge();
34              
35             sub cache_max (;$) {
36 0 0   0 0 0 if (@_ == 0) {
37 0         0 return $CACHE_MAX;
38             } else {
39 0         0 $CACHE_MAX = shift;
40             }
41 0 0       0 $CACHE_MAX = 0 if $CACHE_MAX < 0;
42 0         0 cache_n_purge();
43             }
44              
45             sub cache_purge (;$) {
46 0 0   0 0 0 if (@_ == 0) {
47 0         0 return $CACHE_PURGE;
48             } else {
49 0         0 $CACHE_PURGE = shift;
50             }
51 0 0       0 if ($CACHE_PURGE < 0) {
    0          
52 0         0 $CACHE_PURGE = 0;
53             } elsif ($CACHE_PURGE > 1) {
54 0         0 $CACHE_PURGE = 1;
55             }
56 0         0 cache_n_purge();
57             }
58              
59             my %_simple;
60             my %_simple_usage_count;
61              
62             sub _cf_simple {
63 0     0   0 my $P = shift;
64              
65             my @usage =
66 0         0 sort { $_simple_usage_count{$a} <=> $_simple_usage_count{$b} }
67 0         0 grep { $_ ne $P }
  0         0  
68             keys %_simple_usage_count;
69            
70             # Make room, delete the least used entries.
71 0         0 $#usage = $CACHE_N_PURGE - 1;
72            
73 0         0 delete @_simple_usage_count{@usage};
74 0         0 delete @_simple{@usage};
75             }
76              
77             sub _simple {
78 41     41   41 my $P = shift;
79              
80 41         368 my $_simple = new(__PACKAGE__, $P);
81              
82 41 50       83 if ($CACHE_MAX) {
83 41 100       106 $_simple{$P} = $_simple unless exists $_simple{$P};
84              
85 41         47 $_simple_usage_count{$P}++;
86              
87 41 50       90 if (keys %_simple_usage_count > $CACHE_MAX) {
88 0         0 _cf_simple($P);
89             }
90             }
91              
92 41         53 return ( $_simple );
93             }
94              
95             sub _parse_param {
96 7     7   3154 use integer;
  7         57  
  7         26  
97              
98 44     44   56 my ($n, @param) = @_;
99 44         34 my %param;
100              
101 44         67 foreach (@param) {
102 52         93 while ($_ ne '') {
103 58         103 s/^\s+//;
104 58 100       312 if (s/^([IDS]\s*)?(\d+)(\s*%)?//) {
    100          
    100          
    50          
    100          
    100          
    100          
    50          
105 33 100       93 my $k = defined $3 ? (($2-1) * $n) / 100 + ($2 ? 1 : 0) : $2;
    100          
106              
107 33 100       51 if (defined $1) {
108 14         60 $param{$1} = $k;
109             } else {
110 19         54 $param{k} = $k;
111             }
112             } elsif (s/^initial_position\W+(\d+)\b//) {
113 5         15 $param{'initial_position'} = $1;
114             } elsif (s/^final_position\W+(\d+)\b//) {
115 4         11 $param{'final_position'} = $1;
116             } elsif (s/^position_range\W+(\d+)\b//) {
117 0         0 $param{'position_range'} = $1;
118             } elsif (s/^minimal_distance\b//) {
119 5         17 $param{'minimal_distance'} = 1;
120             } elsif (s/^i//) {
121 7         23 $param{ i } = 1;
122             } elsif (s/^g//) {
123 3         7 $param{ g } = 1;
124             } elsif (s/^\?//) {
125 1         4 $param{'?'} = 1;
126             } else {
127 0         0 warn "unknown parameter: '$_'\n";
128 0         0 return;
129             }
130             }
131             }
132              
133 44         152 return %param;
134             }
135              
136             my %_param_key;
137             my %_parsed_param;
138              
139             my %_complex;
140             my %_complex_usage_count;
141              
142             sub _cf_complex {
143 0     0   0 my $P = shift;
144              
145             my @usage =
146             sort { $_complex_usage_count{$a} <=>
147 0         0 $_complex_usage_count{$b} }
148 0         0 grep { $_ ne $P }
  0         0  
149             keys %_complex_usage_count;
150            
151             # Make room, delete the least used entries.
152 0         0 $#usage = $CACHE_N_PURGE - 1;
153            
154 0         0 delete @_complex_usage_count{@usage};
155 0         0 delete @_complex{@usage};
156             }
157              
158             sub _complex {
159 84     84   115 my ($P, @param) = @_;
160 84         98 unshift @param, length $P;
161 84         147 my $param = "@param";
162 84         61 my $_param_key;
163             my %param;
164 0         0 my $complex;
165 0         0 my $is_new;
166              
167 84 100       117 unless (exists $_param_key{$param}) {
168 44         74 %param = _parse_param(@param);
169 44         132 $_parsed_param{$param} = { %param };
170 44         93 $_param_key{$param} = join(" ", %param);
171             } else {
172 40         31 %param = %{ $_parsed_param{$param} };
  40         80  
173             }
174              
175 84         94 $_param_key = $_param_key{$param};
176              
177 84 50       115 if ($CACHE_MAX) {
178 84 100       159 if (exists $_complex{$P}->{$_param_key}) {
179 37         39 $complex = $_complex{$P}->{$_param_key};
180             }
181             }
182              
183 84 100       131 unless (defined $complex) {
184 47 100       69 if (exists $param{'k'}) {
185 19         213 $complex = new(__PACKAGE__, $P, $param{k});
186             } else {
187 28         187 $complex = new(__PACKAGE__, $P);
188             }
189 47 50       120 $_complex{$P}->{$_param_key} = $complex if $CACHE_MAX;
190 47         56 $is_new = 1;
191             }
192              
193 84 100       105 if ($is_new) {
194 47 100       131 $complex->set_greedy unless exists $param{'?'};
195              
196             $complex->set_insertions($param{'I'})
197 47 100       93 if exists $param{'I'};
198             $complex->set_deletions($param{'D'})
199 47 100       92 if exists $param{'D'};
200             $complex->set_substitutions($param{'S'})
201 47 100       71 if exists $param{'S'};
202            
203             $complex->set_caseignore_slice
204 47 100       147 if exists $param{'i'};
205              
206             $complex->set_text_initial_position($param{'initial_position'})
207 47 100       80 if exists $param{'initial_position'};
208              
209             $complex->set_text_final_position($param{'final_position'})
210 47 100       69 if exists $param{'final_position'};
211              
212             $complex->set_text_position_range($param{'position_range'})
213 47 50       85 if exists $param{'position_range'};
214              
215             $complex->set_minimal_distance($param{'minimal_distance'})
216 47 100       85 if exists $param{'minimal_distance'};
217             }
218              
219 84 50       103 if ($CACHE_MAX) {
220 84         103 $_complex_usage_count{$P}->{$_param_key}++;
221              
222             # If our cache overfloweth.
223 84 50       125 if (scalar keys %_complex_usage_count > $CACHE_MAX) {
224 0         0 _cf_complex($P);
225             }
226             }
227              
228 84         216 return ( $complex, %param );
229             }
230              
231             sub cache_disable {
232 0     0 0 0 cache_max(0);
233             }
234              
235             sub cache_flush_all {
236 0     0 0 0 my $old_purge = cache_purge();
237 0         0 cache_purge(1);
238 0         0 _cf_simple('');
239 0         0 _cf_complex('');
240 0         0 cache_purge($old_purge);
241             }
242              
243             sub amatch {
244 48     48 0 6037 my $P = shift;
245 48 100       129 return 1 unless length $P;
246             my $a = ((@_ && ref $_[0] eq 'ARRAY') ?
247 45 100 100     205 _complex($P, @{ shift(@_) }) : _simple($P))[0];
  27         47  
248              
249 45 100       68 if (@_) {
250 41 100       47 if (wantarray) {
251 12         17 return grep { $a->match($_) } @_;
  217         426  
252             } else {
253 29         35 foreach (@_) {
254 29 100       1896 return 1 if $a->match($_);
255             }
256 8         34 return 0;
257             }
258             }
259 4 100       9 if (defined $_) {
260 3 50       7 if (wantarray) {
261 0 0       0 return $a->match($_) ? $_ : undef;
262             } else {
263 3 100       23 return 1 if $a->match($_);
264             }
265             }
266 3 100       16 return $a->match($_) if defined $_;
267              
268 1         5 warn "amatch: \$_ is undefined: what are you matching?\n";
269 1         4 return;
270             }
271              
272             sub _find_substitute {
273 117     117   94 my ($ri, $rs, $i, $s, $S, $rn) = @_;
274              
275 117         72 push @{ $ri }, $i;
  117         84  
276 117         75 push @{ $rs }, $s;
  117         79  
277              
278 117         118 my $pre = substr($_, 0, $i);
279 117         86 my $old = substr($_, $i, $s);
280 117         139 my $suf = substr($_, $i + $s);
281 117         70 my $new = $S;
282              
283 117         128 $new =~ s/\$\`/$pre/g;
284 117         137 $new =~ s/\$\&/$old/g;
285 117         114 $new =~ s/\$\'/$suf/g;
286              
287 117         77 push @{ $rn }, $new;
  117         143  
288             }
289              
290             sub _do_substitute {
291 116     116   81 my ($rn, $ri, $rs, $rS) = @_;
292              
293 116         66 my $d = 0;
294 116         87 my $n = $_;
295              
296 116         124 foreach my $i (0..$#$rn) {
297 117         127 substr($n, $ri->[$i] + $d, $rs->[$i]) = $rn->[$i];
298 117         107 $d += length($rn->[$i]) - $rs->[$i];
299             }
300              
301 116         73 push @{ $rS }, $n;
  116         154  
302             }
303              
304             sub asubstitute {
305 11     11 1 5222 my $P = shift;
306 11         11 my $S = shift;
307             my ($a, %p) =
308             (@_ && ref $_[0] eq 'ARRAY') ?
309 11 100 100     55 _complex($P, @{ shift(@_) }) : _simple($P);
  7         16  
310              
311 11         12 my ($i, $s, @i, @s, @n, @S);
312              
313 11 100       19 if (@_) {
    100          
314 9 100       12 if (exists $p{ g }) {
315 1         2 foreach (@_) {
316 29         28 @s = @i = @n = ();
317 29         72 while (($i, $s) = $a->slice_next($_)) {
318 12 50       17 if (defined $i) {
319 12         14 _find_substitute(\@i, \@s, $i, $s, $S, \@n);
320             }
321             }
322 29 100       43 _do_substitute(\@n, \@i, \@s, \@S) if @n;
323             }
324             } else {
325 8         11 foreach (@_) {
326 232         214 @s = @i = @n = ();
327 232         437 ($i, $s) = $a->slice($_);
328 232 100       280 if (defined $i) {
329 104         117 _find_substitute(\@i, \@s, $i, $s, $S, \@n);
330 104         122 _do_substitute(\@n, \@i, \@s, \@S);
331             }
332             }
333             }
334 9         61 return @S;
335             } elsif (defined $_) {
336 1 50       4 if (exists $p{ g }) {
337 0         0 while (($i, $s) = $a->slice_next($_)) {
338 0 0       0 if (defined $i) {
339 0         0 _find_substitute(\@i, \@s, $i, $s, $S, \@n);
340             }
341             }
342 0 0       0 _do_substitute(\@n, \@i, \@s, \@S) if @n;
343             } else {
344 1         6 ($i, $s) = $a->slice($_);
345 1 50       5 if (defined $i) {
346 1         3 _find_substitute(\@i, \@s, $i, $s, $S, \@n);
347 1         4 _do_substitute(\@n, \@i, \@s, \@S);
348             }
349             }
350 1         10 return $_ = $n[0];
351             } else {
352 1         4 warn "asubstitute: \$_ is undefined: what are you substituting?\n";
353 1         6 return;
354             }
355             }
356              
357             sub aindex {
358 23     23 0 35 my $P = shift;
359 23 100       51 return 0 unless length $P;
360             my $a = ((@_ && ref $_[0] eq 'ARRAY') ?
361 21 100 66     102 _complex($P, @{ shift(@_) }) : _simple($P))[0];
  7         12  
362              
363 21         40 $a->set_greedy; # The *first* match, thank you.
364              
365 21 50       36 if (@_) {
366 21 50       27 if (wantarray) {
367 0         0 return map { $a->index($_) } @_;
  0         0  
368             } else {
369 21         175 return $a->index($_[0]);
370             }
371             }
372 0 0       0 return $a->index($_) if defined $_;
373              
374 0         0 warn "aindex: \$_ is undefined: what are you indexing?\n";
375 0         0 return;
376             }
377              
378             sub aslice {
379 45     45 0 5904 my $P = shift;
380 45 50       69 return (0, 0) unless length $P;
381             my $a = ((@_ && ref $_[0] eq 'ARRAY') ?
382 45 100 66     155 _complex($P, @{ shift(@_) }) : _simple($P))[0];
  43         67  
383              
384 45         70 $a->set_greedy; # The *first* match, thank you.
385              
386 45 50       56 if (@_) {
387 45         41 return map { [ $a->slice($_) ] } @_;
  45         284  
388             }
389 0 0       0 return $a->slice($_) if defined $_;
390              
391 0         0 warn "aslice: \$_ is undefined: what are you slicing?\n";
392 0         0 return;
393             }
394              
395             sub _adist {
396 39     39   28 my $s0 = shift;
397 39         26 my $s1 = shift;
398 39         63 my ($aslice) = aslice($s0, ['minimal_distance', @_], $s1);
399 39         42 my ($index, $size, $distance) = @$aslice;
400 39         32 my ($l0, $l1) = map { length } ($s0, $s1);
  78         60  
401 39 100       109 return $l0 <= $l1 ? $distance : -$distance;
402             }
403              
404             sub adist {
405 19     19 0 3902 my $a0 = shift;
406 19         34 my $a1 = shift;
407 19 100       53 if (length($a0) == 0) {
408 2         6 return length($a1);
409             }
410 17 100       27 if (length($a1) == 0) {
411 2         7 return length($a0);
412             }
413 15 50       30 my @m = ref $_[0] eq 'ARRAY' ? @{shift()} : ();
  0         0  
414 15 100       26 if (ref $a0 eq 'ARRAY') {
    100          
415 6 100       8 if (ref $a1 eq 'ARRAY') {
416 1         2 return [ map { adist($a0, $_, @m) } @{$a1} ];
  4         9  
  1         2  
417             } else {
418 5         3 return [ map { _adist($_, $a1, @m) } @{$a0} ];
  20         21  
  5         8  
419             }
420             } elsif (ref $a1 eq 'ARRAY') {
421 1         2 return [ map { _adist($a0, $_, @m) } @{$a1} ];
  4         4  
  1         2  
422             } else {
423 8 100       12 if (wantarray) {
424 1         2 return map { _adist($a0, $_, @m) } ($a1, @_);
  3         5  
425             } else {
426 7         12 return _adist($a0, $a1, @m);
427             }
428             }
429             }
430              
431             sub adistr {
432 4     4 0 225 my $a0 = shift;
433 4         5 my $a1 = shift;
434 4 50       9 my @m = ref $_[0] eq 'ARRAY' ? shift : ();
435 4 50       10 if (ref $a0 eq 'ARRAY') {
    50          
436 0 0       0 if (ref $a1 eq 'ARRAY') {
437 0         0 my $l0 = length();
438 0         0 return $l0 ? [ map { adist($a0, $_, @m) }
439 0 0       0 @{$a1} ] :
  0         0  
440             [ ];
441             } else {
442 0         0 return [ map { my $l0 = length();
443 0 0       0 $l0 ? _adist($_, $a1, @m) / $l0 : undef
444 0         0 } @{$a0} ];
  0         0  
445             }
446             } elsif (ref $a1 eq 'ARRAY') {
447 0         0 my $l0 = length($a0);
448 0 0       0 return [] unless $l0;
449 0         0 return [ map { _adist($a0, $_, @m) / $l0 } @{$a1} ];
  0         0  
  0         0  
450             } else {
451 4         4 my $l0 = length($a0);
452 4 100       5 if (wantarray) {
453 1 50       2 return map { $l0 ? _adist($a0, $_, @m) / $l0 : undef } ($a1, @_);
  2         5  
454             } else {
455 3 50       7 return undef unless $l0;
456 3         6 return _adist($a0, $a1, @m) / $l0;
457             }
458             }
459             }
460              
461             sub adistword {
462 0     0 0 0 return adist($_[0], $_[1], ['position_range=0']);
463             }
464              
465             sub adistrword {
466 0     0 0 0 return adistr($_[0], $_[1], ['position_range=0']);
467             }
468              
469             sub arindex {
470 3     3 0 14 my $P = shift;
471 3         3 my $l = length $P;
472 3 50       5 return 0 unless $l;
473 3         8 my $R = reverse $P;
474             my $a = ((@_ && ref $_[0] eq 'ARRAY') ?
475 3 50 33     19 _complex($R, @{ shift(@_) }) : _simple($R))[0];
  0         0  
476              
477 3         10 $a->set_greedy; # The *first* match, thank you.
478              
479 3 50       4 if (@_) {
480 3 50       5 if (wantarray) {
481             return map {
482 0         0 my $aindex = $a->index(scalar reverse());
  0         0  
483 0 0       0 $aindex == -1 ? $aindex : (length($_) - $aindex - $l);
484             } @_;
485             } else {
486 3         23 my $aindex = $a->index(scalar reverse $_[0]);
487 3 50       20 return $aindex == -1 ? $aindex : (length($_[0]) - $aindex - $l);
488             }
489             }
490 0 0         if (defined $_) {
491 0           my $aindex = $a->index(scalar reverse());
492 0 0         return $aindex == -1 ? $aindex : (length($_) - $aindex - $l);
493             }
494              
495 0           warn "arindex: \$_ is undefined: what are you indexing?\n";
496 0           return;
497             }
498              
499             1;
500             __END__