File Coverage

blib/lib/App/RecordStream/KeyGroups.pm
Criterion Covered Total %
statement 132 137 96.3
branch 35 40 87.5
condition 7 9 77.7
subroutine 16 17 94.1
pod 0 6 0.0
total 190 209 90.9


line stmt bran cond sub pod time code
1             package App::RecordStream::KeyGroups;
2             our $VERSION = "4.0.23";
3              
4 72     72   22625 use strict;
  72         158  
  72         1717  
5 72     72   319 use warnings;
  72         145  
  72         87351  
6              
7             sub new {
8 80     80 0 546 my $class = shift;
9 80         201 my @args = @_;
10              
11 80         240 my $this = {
12             KEY_GROUPS => [],
13             };
14              
15 80         182 bless $this, $class;
16              
17 80         241 $this->add_groups($_) foreach @args;
18              
19 80         392 return $this;
20             };
21              
22             sub has_any_group {
23 41     41 0 1671 my $this = shift;
24 41         79 return (scalar @{$this->{'KEY_GROUPS'}}) > 0;
  41         196  
25             }
26              
27             sub add_groups {
28 68     68 0 152 my $this = shift;
29 68         143 my $groups = shift;
30              
31 68         268 foreach my $group_spec (split(',', $groups)) {
32 86         172 my $group;
33 86 100       304 if ( $group_spec =~ m/^!/ ) {
34 27         150 $group = App::RecordStream::KeyGroups::Group->new($group_spec);
35             }
36             else {
37 59         424 $group = App::RecordStream::KeyGroups::KeySpec->new($group_spec);
38             }
39              
40 86         166 push @{$this->{'KEY_GROUPS'}}, $group;
  86         373  
41             }
42             }
43              
44             sub get_keyspecs_for_record {
45 752     752 0 1284 my $this = shift;
46 752         1132 my $record = shift;
47              
48 752         1111 my @specs;
49              
50 752         1202 foreach my $group ( @{$this->{'KEY_GROUPS'}} ) {
  752         1462  
51 1190         1933 push @specs, @{$group->get_fields($record)};
  1190         2353  
52             }
53              
54 752         2286 return \@specs;
55             }
56              
57             # This is a cached version
58             sub get_keyspecs {
59 38     38 0 92 my $this = shift;
60 38         102 my $record = shift;
61              
62 38 100       118 if ( !$this->{'KEY_SPECS'} ) {
63 25         81 $this->{'KEY_SPECS'} = $this->get_keyspecs_for_record($record);
64             }
65              
66 38         132 return $this->{'KEY_SPECS'};
67             }
68              
69             sub usage {
70 0     0 0 0 return <
71             KEY GROUPS
72             __FORMAT_TEXT__
73             SYNTAX: !regex!opt1!opt2...
74             Key groups are a way of specifying multiple fields to a recs command with a
75             single argument or function. They are generally regexes, and have several
76             options to control what fields they match. By default you give a regex, and
77             it will be matched against all first level keys of a record to come up with
78             the record list. For instance, in a record like this:
79             __FORMAT_TEXT__
80              
81             { 'zip': 1, 'zap': 2, 'foo': { 'bar': 3 } }
82              
83             __FORMAT_TEXT__
84             Key group: !z! would get the keys 'zip' and 'zap'
85              
86             You can have a literal '!' in your regex, just escape it with a \\.
87              
88             Normally, key groups will only match keys whose values are scalars. This
89             can be changed with the 'returnrefs' or rr flag.
90              
91             With the above record !f! would match no fields, but !f!rr would match foo
92             (which has a value of a hash ref)
93              
94             Options on KeyGroups:
95             __FORMAT_TEXT__
96             returnrefs, rr - Return keys that have reference values (default:off)
97             full, f - Regex should match against full keys (recurse fully)
98             depth=NUM,d=NUM - Only match keys at NUM depth (regex will match against
99             full keyspec)
100             sort, s - sort keyspecs lexically
101             HELP
102             }
103              
104             1;
105              
106             package App::RecordStream::KeyGroups::KeySpec;
107              
108             sub new {
109 59     59   123 my $class = shift;
110 59         110 my $spec = shift;
111              
112 59         169 my $this = {
113             SPEC => $spec,
114             };
115              
116 59         171 return bless $this, $class;
117             }
118              
119             sub get_fields {
120 1035     1035   1544 my $this = shift;
121 1035         1476 my $record = shift;
122              
123 1035 50       2604 if ( $record->has_key_spec($this->{'SPEC'}) ) {
124 1035         1598 return [join('/', @{$record->get_key_list_for_spec($this->{'SPEC'})})];
  1035         2511  
125             }
126              
127 0         0 return [];
128             }
129              
130             1;
131              
132             package App::RecordStream::KeyGroups::Group;
133              
134             my $VALID_OPTIONS = {
135             d => 'depth',
136             depth => 'depth',
137             s => 'sort',
138             'sort' => 'sort',
139             f => 'full_match',
140             full => 'full_match',
141             rr => 'return_refs',
142             returnrefs => 'return_refs'
143             };
144              
145             sub new {
146 28     28   72 my $class = shift;
147 28         56 my $group_spec = shift;
148              
149 28         57 my $this = {
150             };
151              
152 28         66 bless $this, $class;
153              
154 28         103 $this->parse_group($group_spec);
155 28         64 return $this;
156             }
157              
158             sub get_fields {
159 163     163   328 my $this = shift;
160 163         289 my $record = shift;
161              
162 163         270 my @specs;
163 163         329 my $regex = $this->{'REGEX'};
164 163         284 foreach my $spec (@{$this->get_specs($record)}) {
  163         395  
165 751 100       3936 if ( $spec =~ m/$regex/ ) {
166 283         703 push @specs, $spec;
167             }
168             }
169              
170             #TODO: deal with sorts
171 163 100       491 if ( $this->has_option('sort') ) {
172 99         288 @specs = sort @specs;
173             }
174 163         618 return \@specs;
175             }
176              
177             sub get_specs {
178 163     163   274 my $this = shift;
179 163         274 my $record = shift;
180              
181 163         265 my $min_depth = 1;
182 163         293 my $max_depth = 1;
183              
184 163 100       355 if ( $this->has_option('full_match') ) {
    100          
185 5         10 $max_depth = -1;
186              
187             }
188             elsif ( $this->has_option('depth') ) {
189 1         3 my $depth = $this->option_value('depth');
190 1         2 $min_depth = $depth;
191 1         2 $max_depth = $depth;
192             }
193              
194 163         374 my $paths = [];
195 163         1000 $this->_get_paths({%$record}, 1, $min_depth, $max_depth, [], $paths);
196 163         594 return [map { join('/', @$_) } @$paths];
  751         2210  
197             }
198              
199             sub _get_paths {
200 891     891   1542 my $this = shift;
201 891         1444 my $data = shift;
202 891         1469 my $current_depth = shift;
203 891         1391 my $min_depth = shift;
204 891         1437 my $max_depth = shift;
205 891         1403 my $current_keys = shift;
206 891         1465 my $found_paths = shift;
207              
208 891 100       2059 if ( $current_depth >= $min_depth ) {
209 890 100 100     2509 if ( ref($data) eq '' || $this->has_option('return_refs') ) {
210 751         1820 push @$found_paths, [@$current_keys];
211             }
212             }
213              
214 891 100       2269 if ( ref($data) eq 'ARRAY' ) {
215 2         4 my $index = -1;
216 2         4 foreach my $value ( @$data ) {
217 3         7 $index++;
218 3 50 33     17 if ( $current_depth <= $max_depth || $max_depth == -1 ) {
219 0         0 $this->_get_paths($value,
220             $current_depth+1,
221             $min_depth,
222             $max_depth,
223             [@$current_keys, "\#index"],
224             $found_paths);
225             }
226             }
227             }
228 891 100       2707 if ( ref($data) eq 'HASH') {
229 175         552 foreach my $key (keys %$data) {
230 733 100 100     1999 if ( $current_depth <= $max_depth || $max_depth == -1 ) {
231 728         2279 $this->_get_paths($data->{$key},
232             $current_depth+1,
233             $min_depth,
234             $max_depth,
235             [@$current_keys, $key],
236             $found_paths);
237             }
238             }
239             }
240             }
241              
242             sub parse_group {
243 41     41   5099 my $this = shift;
244 41         96 my $spec = shift;
245              
246 41 100       152 if ( '!' ne substr($spec, 0, 1) ) {
247 2         11 die "Malformed group spec: '$spec', does not start with '!'\n";
248             }
249              
250 39 50       136 if ( length($spec) < 2 ) {
251 0         0 die "Malformed group spec: '$spec', does not have enough length\n";
252             }
253              
254 39         82 my $regex = '';
255 39         91 my $last_char = '';
256 39         132 my $found_end = 0;
257 39         71 my $start_option_index = 1;
258              
259 39         115 for (my $index = 1; $index < length($spec); $index++) {
260 148         222 $start_option_index++;
261 148         301 my $current_char = substr($spec, $index, 1);
262              
263 148 100       333 if ( $current_char eq '!' ) {
264 38 50       118 if ( $last_char ne '\\' ) {
265 38         63 $last_char = $current_char;
266 38         73 $found_end = 1;
267 38         65 last;
268             }
269             }
270 110         175 $last_char = $current_char;
271 110         174 $regex .= $current_char;
272 110         254 next;
273             }
274              
275 39 100       109 die "Malformed group spec: Did not find terminating '!' in '$spec'\n" if ( ! $found_end );
276              
277 38         115 my $options_string = substr($spec, $start_option_index);
278 38         93 my $options = {};
279              
280 38         118 foreach my $option_group (split('!', $options_string)) {
281 36         102 my ($option, $value) = split('=', $option_group);
282 36 100       130 if ( my $normalized_option = $VALID_OPTIONS->{$option} ) {
283 35 50       83 if ( exists $options->{$normalized_option} ) {
284 0         0 die "Already specified option '$option'. Bad option: '$option_group' in '$spec'\n";
285             }
286             else {
287 35         111 $options->{$normalized_option} = $value;
288             }
289             }
290             else {
291 1         7 die "Malformed group spec: Unrecognized option: '$option' in '$spec'\n";
292             }
293             }
294              
295 37         150 $this->{'REGEX'} = $regex;
296 37         104 $this->{'OPTIONS'} = $options;
297             }
298              
299             sub has_option {
300 660     660   1144 my $this = shift;
301 660         1102 my $option = shift;
302              
303 660         2347 return exists $this->{'OPTIONS'}->{$option};
304             }
305              
306             sub option_value {
307 1     1   2 my $this = shift;
308 1         7 my $option = shift;
309              
310 1         4 return $this->{'OPTIONS'}->{$option};
311             }
312              
313             1;