File Coverage

blib/lib/App/RecordStream/Record.pm
Criterion Covered Total %
statement 132 134 98.5
branch 33 38 86.8
condition 7 9 77.7
subroutine 30 31 96.7
pod 19 23 82.6
total 221 235 94.0


line stmt bran cond sub pod time code
1             package App::RecordStream::Record;
2              
3             =head1 NAME
4              
5             App::RecordStream::Record
6              
7             =head1 AUTHOR
8              
9             Benjamin Bernard
10             Keith Amling
11              
12             =head1 DESCRIPTION
13              
14             An object representing a single record of recs input/output. This is a
15             glorified hash with some helper methods.
16              
17             =head1 SYNOPSIS
18              
19             use App::RecordStream::Record;
20             my $record = App::RecordStream::Record->new("name" => "John Smith", "age" => 39);
21              
22             =head1 CONSTRUCTOR
23              
24             =over 4
25              
26             =item App::RecordStream::Record->new(%hash);
27              
28             Construct a new record with provided keys and values. Can take a single
29             argument which is a hash ref. If this form is used, it will bless that hash
30             and use it, so that hash ref now belongs to this object. This avoids memory
31             copies
32              
33             =back
34              
35             =head1 METHODS
36              
37             =over 4
38              
39             =item @keys = $this->keys();
40              
41             Returns an array of field names.
42              
43             =item $boolean = $this->exists($key);
44              
45             Determine whether or not this field exists in the record.
46              
47             =item $value = $this->get($key);
48              
49             Retrieve a field from the record, returns undef if there is no such field.
50              
51             =item $old_value = $this->get_XXX();
52              
53             Calls $this->get("XXX");
54              
55             =item $old_value = $this->set($key, $value);
56              
57             Set a field in the record, returns the old value, or undef if there was no such
58             field.
59              
60             =item $old_value = $this->set_XXX($value);
61              
62             Calls $this->set("XXX", $value);
63              
64             =item @old_values = $this->remove(@keys);
65              
66             Remove fields from the record, returns the old values (or undef for each missing).
67              
68             =item $this->prune_to(@keys);
69              
70             Removes fields whose names are not among those provided.
71              
72             =item $this->rename($old_key, $new_key);
73              
74             Rename a field. If the field did not exists a new field with value undef is
75             created.
76              
77             =item %hash = $this->as_hash();
78              
79             Marshall a record into hash format.
80              
81             =item $hashref = $this->as_hashref();
82              
83             Marshall a record into hash format, returning a reference. The caller may
84             modify this hash (the changes will not be reflected in the record itself).
85              
86             =item $cmp = $this->cmp($that, @keys);
87              
88             Compare this record to another, using comparators derived from @keys (see
89             get_comparators). Returns -1, 0, or 1 for $this before $that, $this same as
90             $that, and $this after $that, respectively.
91              
92             =item $value_ref = $this->guess_key_from_spec($keyspec, $no_vivify = 0, $throw_error = 0)
93              
94             Get the reference for a key spec. Commonly used like:
95              
96             ${$r->guess_key_from_spec('foo/bar')} eq 'zip'
97             ${$r->guess_key_from_spec('foo/bar')} = 'boo'
98              
99             (the assign back gets back into the record)
100              
101             no_vivify and no_error are optional, and control behavior in the absence of the
102             specified key. throw_error will cause a 'NoSuchKey' exception to be thrown.
103              
104             See 'man recs' for more info on key specs
105              
106             =item $boolean = $this->has_key_spec($spec)
107              
108             Returns a boolean indicating the presence of the key spec in the record. Will
109             not have side effects in the record.
110              
111             =item $ARRAY_REF = $this->get_key_list_for_spec($spec)
112              
113             Returns a list of keys that the spec expanded out to. Arrrays will still be
114             #NUM, hash keys will be fully expanded to the keys present in the record.
115              
116             =item $keyspecs_array_ref = $this->get_keys_for_group($key_group, $rerun)
117              
118             Will create a App::RecordStream::KeyGroups (if necessary) and return the keyspecs that match
119             the given group. See --help-keyspecs or App::RecordStream::KeyGroups for more information.
120              
121             Setting rerun to true will cause every record this is called on to re-do
122             keygroup calculation
123              
124             =item $values_array_ref = $this->get_group_values($key_group, $rerun)
125              
126             Returns the values in this record for a key group. Will rerun keygroup parsing
127             if $rerun is passed
128              
129             =item $comparators_ref = App::RecordStream::Record::get_comparators(@specs)
130              
131             Calls get_comparator for each element of @specs and returns the results
132             together in an array reference.
133              
134             =item $comparator = App::RecordStream::Record::get_comparator($spec)
135              
136             Produces a comparator function (which takes two records and returns similarly
137             to <=> or cmp) from the provided $spec. $spec should be like "" for
138             lexical sort, or "=" where is "+" or "" for
139             ascending or "-" for descending and type is one of the known types and
140             is "*" for sorting "ALL" to the end or "" for normal behaviour. Type include
141             "", "l", "lex", or "lexical" for lexical sort (using cmp), and "n", "num" or
142             "numeric" for numeric sort (using <=>).
143              
144             =item @sorted_records = App::RecordStream::Record::sort($records_ref, @specs)
145              
146             Sorts an array ref of records using the provided specs, returns an array of
147             records.
148              
149             =back
150              
151             =cut
152              
153             our $VERSION = "4.0.23";
154              
155 72     72   200416 use strict;
  72         181  
  72         1944  
156 72     72   359 use warnings;
  72         333  
  72         2512  
157              
158 72     72   18199 use App::RecordStream::KeyGroups;
  72         177  
  72         1762  
159 72     72   25513 use App::RecordStream::KeySpec;
  72         199  
  72         1756  
160              
161 72     72   491 use Data::Dumper;
  72         156  
  72         91933  
162              
163             ### Utility cruft
164              
165             my %comparators =
166             (
167             "" => \&cmp_lex,
168             "l" => \&cmp_lex,
169             "lex" => \&cmp_lex,
170             "lexical" => \&cmp_lex,
171              
172             # Ugh, "natural" is really the wrong name for numeric, I would expect
173             # natural to handle any sequence of text and numbers. Unfortunately, this
174             # alias is sort of grandfathered in.
175             "n" => \&cmp_nat,
176             "nat" => \&cmp_nat,
177             "natural" => \&cmp_nat,
178              
179             # add more accurate "numeric" alias
180             "num" => \&cmp_nat,
181             "numeric" => \&cmp_nat,
182             );
183              
184             sub cmp_lex
185             {
186 60     60 0 122 my ($this, $that) = @_;
187 60         120 return ($this cmp $that);
188             }
189              
190             sub cmp_nat
191             {
192 51     51 0 126 my ($this, $that) = @_;
193 51         112 return ($this <=> $that);
194             }
195              
196             sub get_comparators
197             {
198 64     64 1 151 return [map { get_comparator($_) } @_];
  89         224  
199             }
200              
201             {
202             sub get_comparator
203             {
204 89     89 1 186 my ($comparator, $field) = get_comparator_and_field(@_);
205              
206 89         280 return $comparator;
207             }
208              
209             sub get_comparator_and_field
210             {
211 91     91 0 170 my $spec = shift;
212              
213 91         173 my ($field, $direction, $comparator_name, $all_hack);
214              
215 91 100       284 if ( $spec =~ m/=/ )
216             {
217 76         436 ($field, $direction, $comparator_name, $all_hack) = $spec =~ /^(.*)=([-+]?)(.*?)(\*?)$/;
218             }
219             else
220             {
221 15         53 ($field, $direction, $comparator_name, $all_hack) = ($spec, undef, 'lexical', '');
222             }
223              
224 91 100       303 $direction = '+' unless ( $direction );
225 91 100       222 $all_hack = $all_hack ? 1 : 0;
226              
227 91         190 my $func = $comparators{$comparator_name};
228 91 50       241 die "Not a valid comparator: $comparator_name" unless ( $func );
229              
230             my $comparator = sub {
231 117     117   220 my ($this, $that) = @_;
232              
233 117         187 my $val = undef;
234              
235 117 100       270 if ( $all_hack )
236             {
237 41         54 my $this_value = ${$this->guess_key_from_spec($field)};
  41         76  
238 41         62 my $that_value = ${$that->guess_key_from_spec($field)};
  41         83  
239 41 100 66     112 if ( $this_value eq 'ALL' && $that_value ne 'ALL' )
240             {
241 2         5 $val = 1;
242             }
243 41 100 100     149 if ( $this_value ne 'ALL' && $that_value eq 'ALL' )
244             {
245 4         9 $val = -1;
246             }
247 41 50 66     97 if ( $this_value eq 'ALL' && $that_value eq 'ALL' )
248             {
249 0         0 return 0;
250             }
251             }
252              
253 117 100       268 if ( ! defined $val )
254             {
255 111         182 $val = $func->(${$this->guess_key_from_spec($field)}, ${$that->guess_key_from_spec($field)});
  111         250  
  111         240  
256             }
257              
258 117 100       296 if ( $direction eq '-' )
259             {
260 36         73 return -$val;
261             }
262              
263 81         168 return $val;
264 91         393 };
265              
266 91         289 return ($comparator, $field);
267             }
268             }
269              
270             sub sort
271             {
272 4     4 1 22 my $records = shift;
273 4         15 my @specs = @_;
274              
275 4 50       27 return map { $records->[$_] } CORE::sort { $records->[$a]->cmp($records->[$b], @specs) || ($a <=> $b) } (0..(@$records - 1));
  24         50  
  38         120  
276             }
277              
278             ### Actual class
279              
280             our $AUTOLOAD;
281              
282             sub new
283             {
284 1550     1550 1 21208 my $class = shift;
285              
286 1550 100       3826 if ( scalar @_ == 1 ) {
287 125         202 my $arg = $_[0];
288 125 50       396 if ( UNIVERSAL::isa($arg, 'HASH') ) {
289 125         274 bless $arg, $class;
290 125         399 return $arg;
291             }
292             }
293              
294 1425         3266 my $this = { @_ };
295 1425         2641 bless $this, $class;
296              
297 1425         3925 return $this;
298             }
299              
300             sub keys
301             {
302 28     28 1 58 my ($this) = @_;
303 28         121 return CORE::keys(%$this);
304             }
305              
306             sub exists
307             {
308 3     3 1 13 my ($this, $field) = @_;
309 3         22 return exists($this->{$field});
310             }
311              
312             sub get
313             {
314 31     31 1 79 my ($this, $field) = @_;
315 31         137 return $this->{$field};
316             }
317              
318             sub set
319             {
320 49     49 1 101 my ($this, $field, $val) = @_;
321              
322 49         85 my $old = $this->{$field};
323 49         92 $this->{$field} = $val;
324              
325 49         123 return $old;
326             }
327              
328             sub remove
329             {
330 9     9 1 37 my ($this, @fields) = @_;
331              
332 9         23 my @old;
333 9         21 for my $field (@fields)
334             {
335 9         29 push @old, delete $this->{$field};
336             }
337              
338 9         42 return @old;
339             }
340              
341             sub prune_to
342             {
343 1     1 1 11 my ($this, @ok) = @_;
344              
345 1         4 my %ok = map { ($_ => 1) } @ok;
  3         13  
346 1         7 for my $field (CORE::keys(%$this))
347             {
348 4 100       22 if(!exists($ok{$field}))
349             {
350 2         5 delete $this->{$field};
351             }
352             }
353             }
354              
355             sub rename
356             {
357 3     3 1 24 my ($this, $old, $new) = @_;
358              
359 3         12 $this->set($new, $this->get($old));
360 3         11 $this->remove($old);
361             }
362              
363             sub as_hash
364             {
365 17     17 1 862 my ($this) = @_;
366 17         202 return %$this;
367             }
368              
369             sub as_hashref
370             {
371 10     10 1 23 my ($this) = @_;
372 10         142 return {%$this};
373             }
374              
375             sub TO_JSON {
376 5     5 0 12 my ($this) = @_;
377 5         13 return $this->as_hashref();
378             }
379              
380             sub has_key_spec {
381 2697     2697 1 5810 my ($this, $spec) = @_;
382 2697         6606 my $spec_obj = App::RecordStream::KeySpec->new($spec);
383 2697         6460 return $spec_obj->has_key_spec($this);
384             }
385              
386             sub guess_key_from_spec {
387 3955     3955 1 11366 return App::RecordStream::KeySpec::find_key(@_);
388             }
389              
390             sub get_key_list_for_spec {
391 2058     2058 1 3718 my ($this, $spec) = @_;
392              
393 2058         4709 my $spec_obj = App::RecordStream::KeySpec->new($spec);
394 2058         4825 return $spec_obj->get_key_list_for_spec($this);
395             }
396              
397             {
398             my $key_groups = {};
399             sub get_keys_for_group {
400 4     4 1 24 my ($this, $group_string, $rerun) = @_;
401              
402 4         12 my $group = $key_groups->{$group_string};
403 4 100       17 if ( ! $group ) {
404 1         12 my $new_group = App::RecordStream::KeyGroups->new($group_string);
405 1         4 $key_groups->{$group_string} = $new_group;
406 1         3 $group = $new_group;
407             }
408              
409 4 100       13 if ( $rerun ) {
410 2         10 return $group->get_keyspecs_for_record($this);
411             }
412             else {
413 2         9 return $group->get_keyspecs($this);
414             }
415             }
416             }
417              
418             sub get_group_values {
419 1     1 1 5 my ($this, $group, $rerun) = @_;
420              
421 1         5 my $specs = $this->get_keys_for_group($group, $rerun);
422 1         3 my $values = [];
423              
424 1         3 foreach my $spec (@$specs) {
425 3         6 push @$values, ${$this->guess_key_from_spec($spec)};
  3         8  
426             }
427              
428 1         6 return $values;
429             }
430              
431             sub cmp
432             {
433 64     64 1 247 my ($this, $that, @keys) = @_;
434              
435 64         157 my $comparators = get_comparators(@keys);
436              
437 64         210 foreach my $comparator (@$comparators) {
438 76         190 my $val = $comparator->($this, $that);
439 76 100       568 return $val if ( $val != 0 );
440             }
441              
442 2         19 return 0;
443             }
444              
445       0     sub DESTROY {
446             }
447              
448             sub AUTOLOAD
449             {
450 7     7   34 my $this = shift;
451              
452 7         44 $AUTOLOAD =~ s/^.*://;
453              
454 7 100       37 if($AUTOLOAD =~ /^get_(.*)$/)
455             {
456 5         19 return get($this, $1, @_);
457             }
458              
459 2 50       13 if($AUTOLOAD =~ /^set_(.*)$/)
460             {
461 2         11 return set($this, $1, @_);
462             }
463              
464 0           die "No such method " . $AUTOLOAD . " for " . ref($this) . "\n";
465             }
466              
467             1;