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   137993 use 5.010;
  2         18  
4 2     2   12 use strict;
  2         4  
  2         42  
5 2     2   9 use warnings;
  2         18  
  2         626  
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.03
16              
17             =cut
18              
19             our $VERSION = '0.03';
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 849 my ($class, %opt) = @_;
61 1   50     11 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 11     11 1 104 my ($self, $key, $value) = @_;
84              
85 11         14 my $vref = \$value;
86 11         21 my $ref = $self->{table};
87              
88 11         17 foreach my $item (@$key) {
89 64   100     156 $ref = $ref->{$item} //= {};
90 64         113 push @{$ref->{$ref}}, $vref;
  64         160  
91             }
92              
93 11         27 $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 11 my ($self, $prefix) = @_;
117              
118 1         2 my $ref = $self->{table};
119              
120 1         3 foreach my $item (@$prefix) {
121 4 50       9 if (exists $ref->{$item}) {
122 4         16 $ref = $ref->{$item};
123             }
124             else {
125 0         0 return;
126             }
127             }
128              
129 1         2 map { $$_ } @{$ref->{$ref}};
  7         14  
  1         3  
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 REPOSITORY
167              
168             L
169              
170             =head1 AUTHOR
171              
172             Daniel Șuteu, C<< >>
173              
174             =head1 LICENSE AND COPYRIGHT
175              
176             Copyright 2016-2017 Daniel Șuteu.
177              
178             This program is free software; you can redistribute it and/or modify it
179             under the terms of the the Artistic License (2.0). You may obtain a
180             copy of the full license at:
181              
182             L
183              
184             =cut
185              
186             1; # End of Search::ByPrefix