File Coverage

blib/lib/Algorithm/AhoCorasick/SearchMachine.pm
Criterion Covered Total %
statement 102 108 94.4
branch 19 22 86.3
condition 7 9 77.7
subroutine 17 17 100.0
pod 2 2 100.0
total 147 158 93.0


line stmt bran cond sub pod time code
1             package Algorithm::AhoCorasick::SearchMachine;
2              
3 4     4   30071 use strict;
  4         10  
  4         130  
4 4     4   21 use warnings;
  4         7  
  4         2667  
5              
6             sub new {
7 24     24 1 3638 my $class = shift;
8              
9 24 100       70 if (!@_) {
10 4         31 die "no keywords";
11             }
12              
13 20         28 my %keywords;
14 20         48 foreach (@_) {
15 33 100 66     179 if (!defined($_) || ($_ eq '')) {
16 2         21 die "empty keyword";
17             }
18              
19 31         101 $keywords{$_} = 1;
20             }
21              
22 18         83 my $self = { keywords => [ keys %keywords ] };
23 18         64 bless $self, $class;
24 18         45 $self->_build_tree();
25 18         66 return $self;
26             }
27              
28             sub _build_tree {
29 18     18   30 my $self = shift;
30              
31 18         65 $self->{root} = Algorithm::AhoCorasick::Node->new();
32              
33             # build transition links
34 18         29 foreach my $p (@{$self->{keywords}}) {
  18         44  
35 27         46 my $nd = $self->{root};
36 27         77 foreach my $c (split //, $p) {
37 57         121 my $ndNew = $nd->get_transition($c);
38 57 100       156 if (!$ndNew) {
39 47         128 $ndNew = Algorithm::AhoCorasick::Node->new(parent => $nd, char => $c);
40 47         103 $nd->add_transition($ndNew);
41             }
42              
43 57         138 $nd = $ndNew;
44             }
45              
46 27         72 $nd->add_result($p);
47             }
48              
49             # build failure links
50 18         30 my @nodes;
51 18         50 foreach my $nd ($self->{root}->transitions) {
52 18         69 $nd->failure($self->{root});
53 18         36 push @nodes, $nd->transitions;
54             }
55              
56 18         51 while (@nodes) {
57 21         24 my @newNodes;
58              
59 21         37 foreach my $nd (@nodes) {
60 29         558 my $r = $nd->parent->failure;
61 29         67 my $c = $nd->char;
62              
63 29   66     108 while ($r && !($r->get_transition($c))) {
64 29         59 $r = $r->failure;
65             }
66              
67 29 50       60 if (!$r) {
68 29         64 $nd->failure($self->{root});
69             } else {
70 0         0 my $tc = $r->get_transition($c);
71 0         0 $nd->failure($tc);
72              
73 0         0 foreach my $result ($tc->results) {
74 0         0 $nd->add_result($result);
75             }
76             }
77              
78 29         54 push @newNodes, $nd->transitions;
79             }
80              
81 21         78 @nodes = @newNodes;
82             }
83              
84 18         48 $self->{root}->failure($self->{root});
85 18         46 $self->{state} = $self->{root};
86             }
87              
88             sub feed {
89 20     20 1 842 my ($self, $text, $callback) = @_;
90              
91 20         27 my $index = 0;
92 20         33 my $l = length($text);
93 20         47 while ($index < $l) {
94 382         427 my $trans = undef;
95 382         386 while (1) {
96 420         1055 $trans = $self->{state}->get_transition(substr($text, $index, 1));
97 420 100 100     1631 last if ($self->{state} == $self->{root}) || $trans;
98 38         85 $self->{state} = $self->{state}->failure;
99             }
100              
101 382 100       727 if ($trans) {
102 88         129 $self->{state} = $trans;
103             }
104              
105 382         737 foreach my $found ($self->{state}->results) {
106 30         105 my $rv = &$callback($index - length($found) + 1, $found);
107 30 100       8054 if ($rv) {
108 6         145 return $rv;
109             }
110             }
111              
112 376         964 ++$index;
113             }
114              
115 14         38 return undef;
116             }
117              
118             package Algorithm::AhoCorasick::Node;
119              
120 4     4   24 use strict;
  4         9  
  4         133  
121 4     4   19 use warnings;
  4         6  
  4         110  
122 4     4   20 use Scalar::Util qw(weaken);
  4         16  
  4         1833  
123              
124             sub new {
125 65     65   88 my $class = shift;
126              
127 65         167 my $self = { @_ };
128 65         129 $self->{results} = { };
129 65         103 $self->{transitions} = { };
130 65 100       272 weaken $self->{parent} if $self->{parent};
131 65         231 return bless $self, $class;
132             }
133              
134             sub char {
135 76     76   93 my $self = shift;
136              
137 76 50       180 if (!exists($self->{char})) {
138 0         0 die "root node has no character";
139             }
140              
141 76         235 return $self->{char};
142             }
143              
144             sub parent {
145 29     29   41 my $self = shift;
146              
147 29 50       75 if (!exists($self->{parent})) {
148 0         0 die "root node has no parent";
149             }
150              
151 29         94 return $self->{parent};
152             }
153              
154             sub failure {
155 161     161   206 my $self = shift;
156              
157 161 100       331 if (@_) {
158 65         1042 $self->{failure} = $_[0];
159 65         165 weaken $self->{failure};
160             }
161              
162 161         360 return $self->{failure};
163             }
164              
165             # Returns transition to the specified character, or undef.
166             sub get_transition {
167 506     506   880 my ($self, $c) = @_;
168              
169 506         1159 return $self->{transitions}->{$c};
170             }
171              
172             # Returns a list of descendant nodes.
173             sub transitions {
174 65     65   80 my $self = shift;
175              
176 65         75 return values %{$self->{transitions}};
  65         261  
177             }
178              
179             # Returns a list of patterns ending in this node.
180             sub results {
181 382     382   459 my $self = shift;
182              
183 382         386 return keys %{$self->{results}};
  382         1260  
184             }
185              
186             # Adds pattern ending in this node.
187             sub add_result {
188 27     27   41 my ($self, $res) = @_;
189              
190 27         94 $self->{results}->{$res} = 1;
191             }
192              
193             # Adds transition node.
194             sub add_transition {
195 47     47   63 my ($self, $node) = @_;
196              
197 47         96 $self->{transitions}->{$node->char} = $node;
198             }
199              
200             1;
201              
202             __END__