File Coverage

lib/File/DataClass/ResultSet.pm
Criterion Covered Total %
statement 126 126 100.0
branch 21 28 75.0
condition 9 13 69.2
subroutine 49 49 100.0
pod 16 16 100.0
total 221 232 95.2


line stmt bran cond sub pod time code
1             package File::DataClass::ResultSet;
2              
3 3     3   18 use namespace::autoclean;
  3         6  
  3         64  
4              
5 3     3   170 use File::DataClass::Constants qw( EXCEPTION_CLASS FALSE TRUE );
  3         10  
  3         186  
6 3     3   15 use File::DataClass::Functions qw( is_arrayref is_hashref is_member throw );
  3         6  
  3         122  
7 3     3   1000 use File::DataClass::List;
  3         9  
  3         99  
8 3     3   1206 use File::DataClass::Result;
  3         24  
  3         91  
9 3         17 use File::DataClass::Types qw( ArrayRef ClassName
10 3     3   21 HashRef Int Maybe Object Str );
  3         6  
11 3     3   3860 use Scalar::Util qw( blessed );
  3         7  
  3         217  
12 3     3   1624 use Subclass::Of;
  3         25075  
  3         78  
13 3     3   1063 use Unexpected::Functions qw( RecordNotFound Unspecified );
  3         6  
  3         33  
14 3     3   1066 use Moo;
  3         7  
  3         22  
15              
16             my $class_stash = {};
17              
18             # Private functions
19             my $_build_operators = sub {
20             return {
21 3     3   34 'eq' => sub { return $_[ 0 ] eq $_[ 1 ] },
22 5     5   45 '==' => sub { return $_[ 0 ] == $_[ 1 ] },
23 3     3   25 'ne' => sub { return $_[ 0 ] ne $_[ 1 ] },
24 3     3   28 '!=' => sub { return $_[ 0 ] != $_[ 1 ] },
25 5     5   33 '>' => sub { return $_[ 0 ] > $_[ 1 ] },
26 3     3   21 '>=' => sub { return $_[ 0 ] >= $_[ 1 ] },
27 3     3   23 '<' => sub { return $_[ 0 ] < $_[ 1 ] },
28 3     3   22 '<=' => sub { return $_[ 0 ] <= $_[ 1 ] },
29 3     3   7 '=~' => sub { my $re = $_[ 1 ]; return $_[ 0 ] =~ qr{ $re }mx },
  3         54  
30 3     3   7 '!~' => sub { my $re = $_[ 1 ]; return $_[ 0 ] !~ qr{ $re }mx },
  3         47  
31 12     12   441 };
32             };
33              
34             # Public attributes
35             has 'list_class' => is => 'ro', isa => ClassName,
36             default => 'File::DataClass::List';
37              
38             has 'result_class' => is => 'ro', isa => ClassName,
39             default => 'File::DataClass::Result';
40              
41             has 'result_source' => is => 'ro', isa => Object,
42             handles => [ qw( attributes defaults label_attr path storage ) ],
43             required => TRUE, weak_ref => TRUE;
44              
45             has '_iterator' => is => 'rw', isa => Int, default => 0,
46             init_arg => undef;
47              
48             has '_operators' => is => 'lazy', isa => HashRef,
49             builder => $_build_operators;
50              
51             has '_results' => is => 'rw', isa => ArrayRef,
52 20     20   10294 builder => sub { [] }, init_arg => undef;
53              
54             # Private methods
55             my $_get_attr_meta = sub {
56             my ($types, $source, $values, $attr) = @_;
57              
58             my $sdef = $source->defaults->{ $attr };
59             my $type = $source->types->{ $attr }
60             // $types->{ ref $sdef || ref $values->{ $attr } || 'SCALAR' };
61              
62             return [ is => 'rw', isa => $type ];
63             };
64              
65             my $_new_result_class = sub {
66             my ($class, $source, $values) = @_;
67              
68             my $name = "${class}::".(ucfirst $source->name);
69              
70             exists $class_stash->{ $name } and return $class_stash->{ $name };
71              
72             my $except = 'delete | id | insert | name | result_source | update';
73             my %types = ( 'ARRAY', Maybe[ArrayRef],
74             'HASH', Maybe[HashRef],
75             'SCALAR', Maybe[Str], );
76             my @attrs = map { $_ => $_get_attr_meta->( \%types, $source, $values, $_ )}
77             grep { not m{ \A (?: $except ) \z }mx }
78             @{ $source->attributes };
79              
80             return $class_stash->{ $name } = subclass_of
81             ( $class, -package => $name, -has => [ @attrs ] );
82             };
83              
84             my $_create_result = sub {
85             my ($self, $args) = @_;
86              
87             my $attr = { %{ $self->defaults }, result_source => $self->result_source };
88              
89             for (grep { exists $args->{ $_ } and defined $args->{ $_ } }
90             @{ $self->attributes }, 'id', 'name') {
91             $attr->{ $_ } = $args->{ $_ };
92             }
93              
94             my $class = $_new_result_class->
95             ( $self->result_class, $self->result_source, $attr );
96              
97             return $class->new( $attr );
98             };
99              
100             my $_eval_op = sub {
101             my ($self, $lhs, $op, $rhs) = @_;
102              
103             my $subr = $self->_operators->{ $op } or return FALSE;
104              
105             $_ or return FALSE for (map { $subr->( $_, $rhs ) ? 1 : 0 }
106             (is_arrayref $lhs) ? @{ $lhs } : ( $lhs ));
107              
108             return TRUE;
109             };
110              
111             my $_push = sub {
112             my ($self, $id, $attr, $items) = @_;
113              
114             my $attrs = { %{ $self->select->{ $id } // {} }, id => $id };
115             my $list = [ @{ $attrs->{ $attr } // [] } ];
116             my $in = [];
117              
118             for my $item (grep { not is_member $_, $list } @{ $items }) {
119             CORE::push @{ $list }, $item; CORE::push @{ $in }, $item;
120             }
121              
122             $attrs->{ $attr } = $list;
123             return ($attrs, $in);
124             };
125              
126             my $_splice = sub {
127             my ($self, $id, $attr, $items) = @_;
128              
129             my $attrs = { %{ $self->select->{ $id } // {} }, id => $id };
130             my $list = [ @{ $attrs->{ $attr } // [] } ];
131             my $out = [];
132              
133             for my $item (@{ $items }) {
134             defined $list->[ 0 ] or last;
135              
136             for (0 .. $#{ $list }) {
137             if ($list->[ $_ ] eq $item) {
138             CORE::splice @{ $list }, $_, 1; CORE::push @{ $out }, $item;
139             last;
140             }
141             }
142             }
143              
144             $attrs->{ $attr } = $list;
145             return ($attrs, $out);
146             };
147              
148             my $_txn_do = sub {
149             my ($self, $coderef) = @_;
150              
151             return $self->storage->txn_do( $self->path, $coderef );
152             };
153              
154             my $_update_result = sub {
155             my ($self, $result, $args) = @_;
156              
157             for my $attr (grep { exists $args->{ $_ } } @{ $self->attributes }) {
158             $result->$attr( $args->{ $attr } );
159             }
160              
161             return $result->update;
162             };
163              
164             my $_validate_params = sub {
165             my ($self, $args) = @_; $args //= {};
166              
167             my $id = (is_hashref $args) ? ($args->{id} // $args->{name}) : $args;
168              
169             $id or throw Unspecified, [ 'record id' ], level => 2;
170              
171             return $id;
172             };
173              
174             my $_eval_clause = sub {
175             my ($self, $clause, $lhs) = @_;
176              
177             if (is_hashref $clause) {
178             for (keys %{ $clause }) {
179             $self->$_eval_op( $lhs, $_, $clause->{ $_ } ) or return FALSE;
180             }
181              
182             return TRUE;
183             }
184             elsif (is_arrayref $clause) { # TODO: Handle case of 2 arrays
185             return (is_arrayref $lhs) ? FALSE : (is_member $lhs, $clause);
186             }
187              
188             return (is_arrayref $lhs) ? ((is_member $clause, $lhs) ? TRUE : FALSE)
189             : ($clause eq $lhs ? TRUE : FALSE);
190             };
191              
192             my $_find = sub {
193             my ($self, $id) = @_; my $results = $self->select;
194              
195             ($id and exists $results->{ $id }) or return;
196              
197             my $attrs = { %{ $results->{ $id } }, id => $id };
198              
199             return $self->$_create_result( $attrs );
200             };
201              
202             my $_list = sub {
203             my ($self, $id) = @_; my ($attr, $attrs, $labels); my $found = FALSE;
204              
205             my $results = $self->select; my $list = [ sort keys %{ $results } ];
206              
207             $attr = $self->label_attr
208             and $labels = { map { $_ => $results->{ $_ }->{ $attr } } @{ $list } };
209              
210             if ($id and exists $results->{ $id }) {
211             $attrs = { %{ $results->{ $id } }, id => $id }; $found = TRUE;
212             }
213             else { $attrs = { id => $id } }
214              
215             my $result = $self->$_create_result( $attrs );
216              
217             $attrs = { found => $found, list => $list, result => $result, };
218             $labels and $attrs->{labels} = $labels;
219             return $self->list_class->new( $attrs );
220             };
221              
222             my $_eval_criteria = sub {
223             my ($self, $criteria, $attrs) = @_; my $lhs;
224              
225             for my $k (keys %{ $criteria }) {
226             defined ($lhs = $attrs->{ $k eq 'name' ? 'id' : $k }) or return FALSE;
227             $self->$_eval_clause( $criteria->{ $k }, $lhs ) or return FALSE;
228             }
229              
230             return TRUE;
231             };
232              
233             my $_find_and_update = sub {
234             my ($self, $args) = @_; my $id = $self->$_validate_params( $args );
235              
236             my $result = $self->$_find( $id )
237             or throw RecordNotFound, [ $self->path, $id ];
238              
239             return $self->$_update_result( $result, $args );
240             };
241              
242             my $_search = sub {
243             my ($self, $where) = @_; my $results = $self->_results; my @tmp;
244              
245             if (not defined $results->[ 0 ]) {
246             $results = $self->select;
247              
248             for (keys %{ $results }) {
249             my $attrs = { %{ $results->{ $_ } }, id => $_ };
250              
251             if (not $where or $self->$_eval_criteria( $where, $attrs )) {
252             CORE::push @{ $self->_results }, $self->$_create_result( $attrs );
253             }
254             }
255             }
256             elsif ($where and defined $results->[ 0 ]) {
257             for (@{ $results }) {
258             $self->$_eval_criteria( $where, $_ ) and CORE::push @tmp, $_;
259             }
260              
261             $self->_results( \@tmp );
262             }
263              
264             return wantarray ? $self->all : $self;
265             };
266              
267             # Public methods
268             sub all {
269 12     12 1 30 my $self = shift; return @{ $self->_results };
  12         37  
  12         222  
270             }
271              
272             sub create {
273 6     6 1 6667 my ($self, $args) = @_; $self->$_validate_params( $args );
  6         21  
274              
275 4     4   23 return $self->$_txn_do( sub { $self->$_create_result( $args )->insert } );
  4         15  
276             }
277              
278             sub create_or_update {
279 5     5 1 2554 my ($self, $args) = @_; my $id = $self->$_validate_params( $args );
  5         19  
280              
281             return $self->$_txn_do( sub {
282 5 100   5   15 my $result = $self->$_find( $id )
283             or return $self->$_create_result( $args )->insert;
284              
285 3         272 return $self->$_update_result( $result, $args );
286 5         32 } );
287             }
288              
289             sub delete {
290 8     8 1 3719 my ($self, $args) = @_; my $id = $self->$_validate_params( $args );
  8         33  
291              
292 8         189 my $path = $self->path;
293 8 50       613 my $optional = (is_hashref $args) ? $args->{optional} : FALSE;
294             my $res = $self->$_txn_do( sub {
295 8 100   8   15 my $result; unless ($result = $self->$_find( $id )) {
  8         23  
296 3 100       19 $optional or throw RecordNotFound, [ $path, $id ];
297 1         4 return FALSE;
298             }
299              
300             $result->delete
301 5 50       417 or throw 'File [_1] source [_2] not deleted', [ $path, $id ];
302 5         24 return TRUE;
303 8         52 } );
304              
305 6 100       69 return $res ? $id : undef;
306             }
307              
308             sub find {
309 6     6 1 2643 my ($self, $args) = @_; my $id = $self->$_validate_params( $args );
  6         22  
310              
311 6     6   40 return $self->$_txn_do( sub { $self->$_find( $id ) } );
  6         23  
312             }
313              
314             sub find_and_update {
315 1     1 1 135 my ($self, $args) = @_; $self->$_validate_params( $args );
  1         4  
316              
317 1     1   5 return $self->$_txn_do( sub { $self->$_find_and_update( $args ) } );
  1         4  
318             }
319              
320             sub first {
321 1     1 1 3 my $self = shift; return $self->_results->[ 0 ];
  1         15  
322             }
323              
324             sub last {
325 1     1 1 2 my $self = shift; return $self->_results->[ -1 ];
  1         16  
326             }
327              
328             sub list {
329 2     2 1 778 my ($self, $args) = @_;
330              
331 2 50 33     9 my $id = (is_hashref $args) ? $args->{id} // $args->{name} : $args;
332              
333 2     2   13 return $self->$_txn_do( sub { $self->$_list( $id ) } );
  2         7  
334             }
335              
336             sub next {
337 3     3 1 31 my $self = shift;
338 3         46 my $index = $self->_iterator; $self->_iterator( $index + 1 );
  3         55  
339              
340 3         106 return $self->_results->[ $index ];
341             }
342              
343             sub push {
344 2     2 1 2799 my ($self, $args) = @_; my $id = $self->$_validate_params( $args );
  2         7  
345              
346 2 50       7 my $list = $args->{list} or throw Unspecified, [ 'list' ];
347 2   100     9 my $items = $args->{items} // []; my ($added, $attrs);
  2         5  
348              
349 2 100       9 $items->[ 0 ] or throw 'List contains no items';
350              
351             my $res = $self->$_txn_do( sub {
352 1     1   5 ($attrs, $added) = $self->$_push( $id, $list, $items );
353              
354 1         4 return $self->$_find_and_update( $attrs );
355 1         6 } );
356              
357 1 50       17 return $res ? $added : FALSE;
358             }
359              
360             sub reset {
361 1     1 1 10 my $self = shift; return $self->_iterator( 0 );
  1         14  
362             }
363              
364             sub select {
365 43     43 1 85 my $self = shift;
366              
367 43         721 return $self->storage->select( $self->path, $self->result_source->name );
368             }
369              
370             sub search {
371 17     17 1 4405 my ($self, $args) = @_;
372              
373 17     17   91 return $self->$_txn_do( sub { $self->$_search( $args ) } );
  17         44  
374             }
375              
376             sub splice {
377 2     2 1 2792 my ($self, $args) = @_; my $id = $self->$_validate_params( $args );
  2         7  
378              
379 2 50       7 my $list = $args->{list} or throw Unspecified, [ 'list' ];
380 2   100     10 my $items = $args->{items} // []; my ($attrs, $removed);
  2         4  
381              
382 2 100       8 $items->[ 0 ] or throw 'List contains no items';
383              
384             my $res = $self->$_txn_do( sub {
385 1     1   4 ($attrs, $removed) = $self->$_splice( $id, $list, $items );
386              
387 1         4 return $self->$_find_and_update( $attrs );
388 1         6 } );
389              
390 1 50       9 return $res ? $removed : FALSE;
391             }
392              
393             sub update {
394 4     4 1 1691 my ($self, $args) = @_;
395              
396 4 100 66     43 if (my $id = $args->{id} // $args->{name}) { # Deprecated
397 3     3   19 return $self->$_txn_do( sub { $self->$_find_and_update( $args ) } );
  3         12  
398             }
399              
400             return $self->$_txn_do( sub {
401 1     1   3 my $updated = FALSE;
402              
403 1         2 for my $result (@{ $self->_results }) {
  1         18  
404 2   66     10 my $res = $self->$_update_result( $result, $args ); $updated ||= $res;
  2         11  
405             }
406              
407 1         4 return $updated;
408 1         7 } );
409             }
410              
411             1;
412              
413             __END__