File Coverage

blib/lib/Grep/Query/FieldAccessor.pm
Criterion Covered Total %
statement 51 51 100.0
branch 14 20 70.0
condition n/a
subroutine 10 10 100.0
pod 5 5 100.0
total 80 86 93.0


line stmt bran cond sub pod time code
1             # for now, a fairly simple container for field names => code pieces to retrieve the actual data
2             #
3             package Grep::Query::FieldAccessor;
4              
5 10     10   77 use strict;
  10         28  
  10         326  
6 10     10   54 use warnings;
  10         19  
  10         905  
7              
8             our $VERSION = '1.011';
9             $VERSION = eval $VERSION;
10              
11 10     10   57 use Carp;
  10         23  
  10         6855  
12             our @CARP_NOT = qw(Regexp::Query);
13              
14             ## CTOR(s)
15             ##
16             sub new
17             {
18 84     84 1 574221 my $class = shift;
19 84         154 my $optionalAccessors = shift;
20              
21 84         238 my $self = { _fields => {} };
22 84         184 bless($self, $class);
23            
24 84 100       213 if (defined($optionalAccessors))
25             {
26 15 50       63 croak("accessors must be a hash") unless ref($optionalAccessors) eq 'HASH';
27 15         83 $self->add($_, $optionalAccessors->{$_}) foreach (keys(%$optionalAccessors));
28             }
29            
30 84         403 return $self;
31             }
32              
33             sub newDefault
34             {
35 54     54 1 109 my $class = shift;
36              
37 54         157 my $self = $class->new();
38 54         119 foreach my $field (@_)
39             {
40 111     2477   483 $self->add($field, sub { $self->__fetchvalue($field, $_[0], split(/->/, $field)) } );
  2477         6405  
41             }
42            
43 54         144 return $self;
44             }
45              
46             ## MEMBER(S)
47              
48             sub add
49             {
50 266     266 1 672 my $self = shift;
51 266         387 my $field = shift;
52 266         346 my $accessor = shift;
53            
54 266 50       483 croak("accessor field name must be a simple scalar string") if ref($field);
55 266 50       507 croak("accessor must be code") unless ref($accessor) eq 'CODE';
56 266 50       579 croak("field $field already set") if exists($self->{_fields}->{$field});
57              
58 266         632 $self->{_fields}->{$field} = $accessor;
59             }
60              
61             sub access
62             {
63 12201     12201 1 17393 my $self = shift;
64 12201         16137 my $field = shift;
65 12201         15363 my $obj = shift;
66            
67 12201         20682 return $self->assertField($field)->($obj);
68             }
69              
70             sub assertField
71             {
72 12536     12536 1 16014 my $self = shift;
73 12536         16144 my $field = shift;
74              
75 12536         17948 my $accessor = $self->{_fields}->{$field};
76 12536 50       22038 croak("invalid field name '$field'") unless $accessor;
77            
78 12536         23808 return $accessor;
79             }
80              
81             ## PRIVATE
82              
83             sub __fetchvalue
84             {
85 5002     5002   6651 my $self = shift;
86 5002         6666 my $field = shift;
87 5002         6477 my $obj = shift;
88              
89             # if there is no more in the navpath, we just return the obj
90             #
91 5002 100       12187 return $obj unless @_;
92            
93             # else, pick out the next piece of the navpath
94             #
95 2525         3388 my $point = shift(@_);
96 2525         3428 my ($arridx, $exptype);
97            
98             # do we have a hash key or an array index?
99             #
100 2525 100       4929 if ($point =~ /^\[(-?\d+)\]$/)
101             {
102 33         107 ($arridx, $exptype) = ($1, 'ARRAY');
103             }
104             else
105             {
106 2492         4358 ($arridx, $exptype) = (undef, 'HASH');
107             }
108            
109             # make sure the obj is of the expected type
110             #
111 2525         3838 my $objtype = ref($obj);
112 2525 50       4531 croak("the field '$field' at point '$point' does not have the expected type: $exptype != $objtype") unless $exptype eq $objtype;
113            
114             # recurse by following the navpath
115             #
116 2525 100       5986 return $self->__fetchvalue($field, (defined($arridx) ? $obj->[$arridx] : $obj->{$point}), @_);
117             }
118              
119             1;
120              
121             =head1 NAME
122              
123             Grep::Query::FieldAccessor - Helper object to hold methods to access fields in the supplied hashes/objects
124              
125             =head1 SYNOPSIS
126              
127             use Grep::Query::FieldAccessor;
128              
129             # fill up an object with accessors
130             #
131             my $fieldAccessor1 = Grep::Query::FieldAccessor->new();
132             $fieldAccessor1->add('name', sub { $_[0]->getName() });
133             $fieldAccessor1->add('age', sub { $_[0]->calculateAge() });
134             ...
135            
136             # equal, but provide it all in one go
137             #
138             my $fieldAccessor2 = Grep::Query::FieldAccessor->new
139             (
140             {
141             name => sub { $_[0]->getName() },
142             age => sub { $_[0]->calculateAge() },
143             ...
144             }
145             );
146              
147             =head1 DESCRIPTION
148              
149             When using a L holding a query denoting fields, an object of this
150             type must be passed along.
151              
152             It must contain methods, indexed on field names, that given an item in the
153             queried list, can extract the value to compare with.
154              
155             B Ensure the methods supplied don't cause side-effects when they are
156             called (such as causing the object or other things to change).
157              
158             =head1 METHODS
159              
160             =head2 new( [ $hash ] )
161              
162             Creates a new field accessor object.
163              
164             If the optional C<$hash> is provided, fields will be populated from it,
165             otherwise the L method must be used.
166              
167             =head2 newDefault( @fieldlist )
168              
169             Creates a new field accessor object with default accessors for all the fields
170             in the given list. It will handle fields expressing navigation paths automatically.
171              
172             =head2 add( $fieldname, $sub )
173              
174             Adds an accessor for the given field.
175              
176             Croaks if the params don't seem to be what they should be or if a field is
177             added more than once.
178              
179             =head2 access( $fieldname, $obj )
180              
181             (normally used by the internal query execution)
182              
183             Looks up the code sub for the given field and executes it with obj as a
184             parameter and returns the result.
185              
186             =head2 assertField
187              
188             (normally used by the internal query execution)
189              
190             Retrieves the code sub for the given field.
191              
192             Croaks if no such field is defined.
193              
194             =head1 AUTHOR
195              
196             Kenneth Olwing, C<< >>
197              
198             =head1 BUGS
199              
200             Please report any bugs or feature requests to C,
201             or through the web interface at
202             L. I will be
203             notified, and then you'll automatically be notified of progress on your bug as
204             I make changes.
205              
206             =head1 SUPPORT
207              
208             You can find documentation for this module with the perldoc command.
209              
210             perldoc Grep::Query
211              
212              
213             You can also look for information at:
214              
215             =over 4
216              
217             =item * RT: CPAN's request tracker (report bugs here)
218              
219             L
220              
221             =item * AnnoCPAN: Annotated CPAN documentation
222              
223             L
224              
225             =item * CPAN Ratings
226              
227             L
228              
229             =item * Search CPAN
230              
231             L
232              
233             =back
234              
235             =head1 ACKNOWLEDGEMENTS
236              
237             =head1 LICENSE AND COPYRIGHT
238              
239             Copyright 2016 Kenneth Olwing.
240              
241             This program is free software; you can redistribute it and/or modify it
242             under the terms of the the Artistic License (2.0). You may obtain a
243             copy of the full license at:
244              
245             L
246              
247             Any use, modification, and distribution of the Standard or Modified
248             Versions is governed by this Artistic License. By using, modifying or
249             distributing the Package, you accept this license. Do not use, modify,
250             or distribute the Package, if you do not accept this license.
251              
252             If your Modified Version has been derived from a Modified Version made
253             by someone other than you, you are nevertheless required to ensure that
254             your Modified Version complies with the requirements of this license.
255              
256             This license does not grant you the right to use any trademark, service
257             mark, tradename, or logo of the Copyright Holder.
258              
259             This license includes the non-exclusive, worldwide, free-of-charge
260             patent license to make, have made, use, offer to sell, sell, import and
261             otherwise transfer the Package with respect to any patent claims
262             licensable by the Copyright Holder that are necessarily infringed by the
263             Package. If you institute patent litigation (including a cross-claim or
264             counterclaim) against any party alleging that the Package constitutes
265             direct or contributory patent infringement, then this Artistic License
266             to you shall terminate on the date that such litigation is filed.
267              
268             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
269             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
270             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
271             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
272             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
273             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
274             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
275             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
276              
277             =cut