File Coverage

blib/lib/Grep/Query/FieldAccessor.pm
Criterion Covered Total %
statement 50 51 98.0
branch 12 20 60.0
condition n/a
subroutine 10 10 100.0
pod 5 5 100.0
total 77 86 89.5


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 9     9   64 use strict;
  9         21  
  9         270  
6 9     9   50 use warnings;
  9         17  
  9         502  
7              
8             our $VERSION = '1.009';
9             $VERSION = eval $VERSION;
10              
11 9     9   64 use Carp;
  9         18  
  9         6120  
12             our @CARP_NOT = qw(Regexp::Query);
13              
14             ## CTOR(s)
15             ##
16             sub new
17             {
18 61     61 1 530886 my $class = shift;
19 61         114 my $optionalAccessors = shift;
20              
21 61         172 my $self = { _fields => {} };
22 61         135 bless($self, $class);
23            
24 61 100       186 if (defined($optionalAccessors))
25             {
26 19 50       79 croak("accessors must be a hash") unless ref($optionalAccessors) eq 'HASH';
27 19         121 $self->add($_, $optionalAccessors->{$_}) foreach (keys(%$optionalAccessors));
28             }
29            
30 61         288 return $self;
31             }
32              
33             sub newDefault
34             {
35 29     29 1 66 my $class = shift;
36              
37 29         102 my $self = $class->new();
38 29         86 foreach my $field (@_)
39             {
40 80     2366   353 $self->add($field, sub { $self->__fetchvalue($field, $_[0], split(/->/, $field)) } );
  2366         5744  
41             }
42            
43 29         89 return $self;
44             }
45              
46             ## MEMBER(S)
47              
48             sub add
49             {
50 249     249 1 599 my $self = shift;
51 249         348 my $field = shift;
52 249         310 my $accessor = shift;
53            
54 249 50       477 croak("accessor field name must be a simple scalar string") if ref($field);
55 249 50       502 croak("accessor must be code") unless ref($accessor) eq 'CODE';
56 249 50       563 croak("field $field already set") if exists($self->{_fields}->{$field});
57              
58 249         581 $self->{_fields}->{$field} = $accessor;
59             }
60              
61             sub access
62             {
63 13962     13962 1 20247 my $self = shift;
64 13962         19284 my $field = shift;
65 13962         17818 my $obj = shift;
66            
67 13962         23969 return $self->assertField($field)->($obj);
68             }
69              
70             sub assertField
71             {
72 14363     14363 1 18640 my $self = shift;
73 14363         18537 my $field = shift;
74              
75 14363         20869 my $accessor = $self->{_fields}->{$field};
76 14363 50       26196 croak("invalid field name '$field'") unless $accessor;
77            
78 14363         28407 return $accessor;
79             }
80              
81             ## PRIVATE
82              
83             sub __fetchvalue
84             {
85 4732     4732   6774 my $self = shift;
86 4732         6483 my $field = shift;
87 4732         6261 my $obj = shift;
88              
89             # if there is no more in the navpath, we just return the obj
90             #
91 4732 100       11844 return $obj unless @_;
92            
93             # else, pick out the next piece of the navpath
94             #
95 2366         3202 my $point = shift(@_);
96 2366         3181 my ($arridx, $exptype);
97            
98             # do we have a hash key or an array index?
99             #
100 2366 50       4502 if ($point =~ /^\[(\d+)\]$/)
101             {
102 0         0 ($arridx, $exptype) = ($1, 'ARRAY');
103             }
104             else
105             {
106 2366         4425 ($arridx, $exptype) = (undef, 'HASH');
107             }
108            
109             # make sure the obj is of the expected type
110             #
111 2366         3682 my $objtype = ref($obj);
112 2366 50       4285 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 2366 50       5478 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