File Coverage

blib/lib/Test/PONAPI/Repository/MockDB/Table.pm
Criterion Covered Total %
statement 60 62 96.7
branch 11 14 78.5
condition 5 9 55.5
subroutine 10 10 100.0
pod 0 4 0.0
total 86 99 86.8


line stmt bran cond sub pod time code
1             # ABSTRACT: mock repository - table class
2             package Test::PONAPI::Repository::MockDB::Table;
3              
4 8     8   6264 use Moose;
  8         20  
  8         52  
5              
6 8     8   51960 use SQL::Composer;
  8         19  
  8         393  
7              
8 8     8   50 use Test::PONAPI::Repository::MockDB::Table::Relationships;
  8         17  
  8         7031  
9              
10             has [qw/TYPE TABLE ID_COLUMN/] => (
11             is => 'ro',
12             isa => 'Str',
13             required => 1,
14             );
15              
16             has COLUMNS => (
17             is => 'ro',
18             isa => 'ArrayRef',
19             required => 1,
20             );
21              
22             has RELATIONS => (
23             is => 'ro',
24             isa => 'HashRef[Test::PONAPI::Repository::MockDB::Table::Relationships]',
25             default => sub { {} },
26             );
27              
28             sub insert_stmt {
29 19     19 0 84 my ($self, %args) = @_;
30              
31 19         48 my $table = $args{table};
32 19         35 my $values = $args{values};
33              
34 19         181 my $stmt = SQL::Composer::Insert->new(
35             into => $table,
36             values => [ %$values ],
37             driver => 'sqlite',
38             );
39              
40 19         2353 return $stmt;
41             }
42              
43             sub delete_stmt {
44 20     20 0 88 my ($self, %args) = @_;
45              
46 20         52 my $table = $args{table};
47 20         44 my $where = $args{where};
48              
49 20         229 my $stmt = SQL::Composer::Delete->new(
50             from => $table,
51             where => [ %$where ],
52             driver => 'sqlite',
53             );
54              
55 20         4867 return $stmt;
56             }
57              
58             sub select_stmt {
59 208     208 0 1164 my ($self, %args) = @_;
60              
61 208         456 my $type = $args{type};
62 208         780 my $filters = $self->_stmt_filters($type, $args{filter});
63              
64 208 100       461 my %limit = %{ $args{page} || {} };
  208         1371  
65 208   100     1038 my $sort = $args{sort} || [];
66              
67             my %order_by = map {
68 208         510 my ($desc, $col) = /\A(-?)(.+)\z/s;
  8         50  
69 8 50       50 ( $col => ( $desc ? 'desc' : 'asc' ) );
70             } @$sort;
71              
72 208         726 my $columns = $self->_stmt_columns(\%args);
73             my $stmt = SQL::Composer::Select->new(
74             %limit,
75             from => $type,
76             columns => $columns,
77 208 100       524 where => [ %{ $filters } ],
  208         1925  
78             (%order_by ? (order_by => [ %order_by ]) : ()),
79             );
80              
81 208         68524 return $stmt;
82             }
83              
84             sub update_stmt {
85 8     8 0 35 my ($self, %args) = @_;
86              
87 8         22 my $id = $args{id};
88 8         16 my $table = $args{table};
89 8   50     35 my $values = $args{values} || {};
90              
91 8         16 local $@;
92             my $stmt = eval {
93 8         93 SQL::Composer::Update->new(
94             table => $table,
95             values => [ %$values ],
96             where => [ id => $id ],
97             driver => 'sqlite',
98             )
99 8 50       18 } or do {
100 0   0     0 my $msg = "$@"||'Unknown error';
101 0         0 PONAPI::Exception->throw(
102             sql_error => "Failed to compose an update with the given values",
103             internal => $msg,
104             );
105             };
106              
107 8         2687 return $stmt;
108             }
109              
110             sub _stmt_columns {
111 208     208   371 my $self = shift;
112 208         327 my $args = shift;
113 208         351 my ( $fields, $type ) = @{$args}{qw< fields type >};
  208         593  
114              
115 208         433 my $ref = ref $fields;
116              
117 208 100       8145 return [ $self->ID_COLUMN, @$fields ] if $ref eq 'ARRAY';
118              
119 76 100 66     1574 $ref eq 'HASH' and exists $fields->{$type}
120             or return $self->COLUMNS;
121              
122             my @fields_minus_relationship_keys =
123 12         579 grep { !exists $self->RELATIONS->{$_} }
124 10         21 @{ $fields->{$type} };
  10         32  
125              
126 10         468 return +[ $self->ID_COLUMN, @fields_minus_relationship_keys ];
127             }
128              
129             sub _stmt_filters {
130 208     208   409 my ( $self, $type, $filter ) = @_;
131              
132 208 50       9653 return $filter if $self->TABLE ne $type;
133              
134             return +{
135 193         988 map { $_ => $filter->{$_} }
136 640         1751 grep { exists $filter->{$_} }
137 208         422 @{ $self->COLUMNS }
  208         7351  
138             };
139             }
140              
141             __PACKAGE__->meta->make_immutable;
142 8     8   51 no Moose; 1;
  8         22  
  8         60  
143              
144             __END__
145              
146             =pod
147              
148             =encoding UTF-8
149              
150             =head1 NAME
151              
152             Test::PONAPI::Repository::MockDB::Table - mock repository - table class
153              
154             =head1 VERSION
155              
156             version 0.002005
157              
158             =head1 AUTHORS
159              
160             =over 4
161              
162             =item *
163              
164             Mickey Nasriachi <mickey@cpan.org>
165              
166             =item *
167              
168             Stevan Little <stevan@cpan.org>
169              
170             =item *
171              
172             Brian Fraser <hugmeir@cpan.org>
173              
174             =back
175              
176             =head1 COPYRIGHT AND LICENSE
177              
178             This software is copyright (c) 2016 by Mickey Nasriachi, Stevan Little, Brian Fraser.
179              
180             This is free software; you can redistribute it and/or modify it under
181             the same terms as the Perl 5 programming language system itself.
182              
183             =cut