File Coverage

blib/lib/Search/ByPrefix.pm
Criterion Covered Total %
statement 26 27 96.3
branch 1 2 50.0
condition 3 4 75.0
subroutine 6 6 100.0
pod 3 3 100.0
total 39 42 92.8


line stmt bran cond sub pod time code
1             package Search::ByPrefix;
2              
3 2     2   27280 use 5.010;
  2         5  
4 2     2   9 use strict;
  2         5  
  2         42  
5 2     2   7 use warnings;
  2         5  
  2         404  
6              
7             =encoding utf8
8              
9             =head1 NAME
10              
11             Search::ByPrefix - An efficient, tree-based, multi-match prefix searcher.
12              
13             =head1 VERSION
14              
15             Version 0.02
16              
17             =cut
18              
19             our $VERSION = '0.02';
20              
21              
22             =head1 SYNOPSIS
23              
24             B works by creating an internal table from a list of
25             key/value pairs, where each key is an array.
26              
27             Then, this table can be efficiently searched with an array prefix-key,
28             which finds and returns all the values that have this certain prefix.
29              
30             use Search::ByPrefix;
31             my $sbp = Search::ByPrefix->new;
32              
33             # Add an entry
34             $sbp->add($key, $value); # where $key is an array
35              
36             # Search by a prefix
37             my @matches = $sbp->search($prefix); # where $prefix is an array
38              
39             =head1 METHODS
40              
41             =head2 new
42              
43             Creates and returns a new object.
44              
45             my $sbp = Search::ByPrefix->new(%opt);
46              
47             Where C<%opt> can have the following keys:
48              
49             =over 2
50              
51             =item * table => {}
52              
53             The value of the C must be a multidimensional hash-like data structure.
54              
55             =back
56              
57             =cut
58              
59             sub new {
60 1     1 1 69693 my ($class, %opt) = @_;
61 1   50     10 bless {table => $opt{table} // {}}, $class;
62             }
63              
64             =head2 add
65              
66             $sbp->add($key, $value);
67              
68             The C<$key> must be an array, where its granularity controls the matching.
69              
70             my $key = ['f','o','o','-','b','a','r'];
71             my $value = 'foo-bar';
72             $sbp->add($key, $value);
73              
74             or:
75              
76             my $key = ['my', 'dir', 'path'];
77             my $value = 'my/dir/path';
78             $sbp->add($key, $value);
79              
80             =cut
81              
82             sub add {
83 5     5 1 38 my ($self, $key, $value) = @_;
84              
85 5         5 my $vref = \$value;
86 5         9 my $ref = $self->{table};
87              
88 5         7 foreach my $item (@$key) {
89 30   100     68 $ref = $ref->{$item} //= {};
90 30         23 push @{$ref->{values}}, $vref;
  30         47  
91             }
92              
93 5         7 $self;
94             }
95              
96             =head2 search
97              
98             my @matches = $sbp->search($prefix);
99              
100             Searches and returns a list of values that have a certain prefix,
101             where each value is the original value associated with the matched key.
102              
103             The C<$prefix> must be an array, where its granularity controls the matching.
104              
105             my $prefix = ['f','o'];
106             my @values = $sbp->search($prefix); # finds: ('foo-bar')
107              
108             or:
109              
110             my $prefix = ['my', 'dir'];
111             my @values = $sbp->search($prefix); # finds: ('my/dir/path')
112              
113             =cut
114              
115             sub search {
116 1     1 1 9 my ($self, $prefix) = @_;
117              
118 1         2 my $ref = $self->{table};
119              
120 1         3 foreach my $item (@$prefix) {
121 4 50       6 if (exists $ref->{$item}) {
122 4         5 $ref = $ref->{$item};
123             }
124             else {
125 0         0 return;
126             }
127             }
128              
129 1         2 map { $$_ } @{$ref->{values}};
  3         6  
  1         10  
130             }
131              
132             =head1 EXAMPLE
133              
134             This example illustrates how to add some key/value pairs to the table
135             and how to search the table with a given prefix:
136              
137             use 5.010;
138             use Search::ByPrefix;
139             my $obj = Search::ByPrefix->new;
140              
141             sub make_key {
142             [split('/', $_[0])]
143             }
144              
145             foreach my $dir (
146             qw(
147             /home/user1/tmp/coverage/test
148             /home/user1/tmp/covert/operator
149             /home/user1/tmp/coven/members
150             /home/user2/tmp/coven/members
151             /home/user1/tmp2/coven/members
152             )
153             ) {
154             $obj->add(make_key($dir), $dir);
155             }
156              
157             # Finds the directories that have this common path
158             say for $obj->search(make_key('/home/user1/tmp'));
159              
160             The results are:
161              
162             "/home/user1/tmp/coverage/test"
163             "/home/user1/tmp/covert/operator"
164             "/home/user1/tmp/coven/members"
165              
166             =head1 AUTHOR
167              
168             Daniel Șuteu, C<< >>
169              
170             =head1 BUGS
171              
172             Please report any bugs or feature requests to L.
173             I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
174              
175             =head1 SUPPORT
176              
177             You can find documentation for this module with the perldoc command.
178              
179             perldoc Search::ByPrefix
180              
181              
182             You can also look for information at:
183              
184             =over 4
185              
186             =item * Github
187              
188             L
189              
190             =item * AnnoCPAN: Annotated CPAN documentation
191              
192             L
193              
194             =item * CPAN Ratings
195              
196             L
197              
198             =item * Search CPAN
199              
200             L
201              
202             =back
203              
204             =head1 LICENSE AND COPYRIGHT
205              
206             Copyright 2016-2017 Daniel Șuteu.
207              
208             This program is free software; you can redistribute it and/or modify it
209             under the terms of the the Artistic License (2.0). You may obtain a
210             copy of the full license at:
211              
212             L
213              
214             =cut
215              
216             1; # End of Search::ByPrefix