File Coverage

blib/lib/Mojo/Leds/Rest/MongoDB.pm
Criterion Covered Total %
statement 15 119 12.6
branch 0 54 0.0
condition 0 21 0.0
subroutine 5 18 27.7
pod n/a
total 20 212 9.4


line stmt bran cond sub pod time code
1             package Mojo::Leds::Rest::MongoDB;
2             $Mojo::Leds::Rest::MongoDB::VERSION = '1.13';
3 1     1   149397 use Mojo::Base 'Mojo::Leds::Rest';
  1         11  
  1         7  
4 1     1   470 use boolean;
  1         880  
  1         3  
5              
6 1     1   62 use Scalar::Util qw(looks_like_number);
  1         2  
  1         35  
7 1     1   319 use BSON::OID;
  1         51000  
  1         34  
8 1     1   335 use Tie::IxHash;
  1         2885  
  1         1437  
9              
10             has pk => '_id';
11             has f_search => 'find';
12             has f_table => 'coll';
13              
14             sub _create {
15 0     0     my $c = shift;
16 0           my $rec = shift;
17 0           my $res = $c->tableDB->insert_one($rec);
18 0 0         if ( $res->acknowledged ) {
19 0           $rec->{_id} = $res->inserted_id;
20             }
21             else {
22 0           return $c->_raise_error( 'Element duplicated', 409 );
23             }
24 0           return $rec;
25             }
26              
27             sub _rec2json() {
28 0     0     my $c = shift;
29 0   0       my $rec = shift || $c->stash( $c->_class_name . '::record' );
30 0           return $rec;
31             }
32              
33             sub _patch {
34 0     0     my $c = shift;
35 0           my $set = shift;
36              
37 0   0       my $id = shift || $c->restify->current_id;
38              
39             # remove id from updated fields
40 0           delete $set->{ $c->pk };
41              
42 0           my $rec = $c->stash( $c->_class_name . '::record' );
43 0           my $res = $c->tableDB->update_one(
44             { $c->pk => $c->_oid($id) },
45             { '$set' => $set },
46             );
47              
48 0 0         return $c->_raise_error( 'Element not found', 404 )
49             unless $res->matched_count;
50 0           $rec = { %$rec, %$set };
51 0           return $rec;
52             }
53              
54             sub _update {
55 0     0     my $c = shift;
56 0           my $set = shift;
57              
58 0   0       my $id = shift || $c->restify->current_id;
59              
60             # remove id from updated fields
61 0           delete $set->{ $c->pk };
62              
63 0           my $rec = $c->stash( $c->_class_name . '::record' );
64 0           my $res = $c->tableDB->replace_one( { $c->pk => $c->_oid($id) }, $set, );
65              
66 0 0         return $c->_raise_error( 'Element not found', 404 )
67             unless $res->matched_count;
68 0           return { $c->pk => $id, %$set };
69             }
70              
71             sub _delete {
72 0     0     my $c = shift;
73 0           my $rec = shift;
74 0           $rec = $c->tableDB->find_one_and_delete( { $c->pk => $rec->{_id} } );
75 0           return $rec;
76             }
77              
78             sub _list {
79 0     0     my ( $c, $rec, $qry, $opt, $rc ) = @_;
80              
81 0           my $recs = [$rec->all];
82 0 0         if ($rc) {
83             my $count =
84             ( exists $opt->{limit} || exists $opt->{page} || exists $opt->{skip} )
85 0 0 0       ? $c->tableDB->count_documents($qry)
86             : scalar(@$recs);
87 0           $recs = { count => $count, recs => $recs };
88             }
89              
90 0           return $recs;
91             }
92              
93             sub _listupdate {
94 0     0     my $c = shift;
95 0           my $json = shift;
96              
97 0           my @recs;
98 0           foreach my $item (@$json) {
99 0 0         if ( exists $item->{ $c->pk } ) {
100 0           $c->app->log->debug(
101             'Update record ' . Data::Dumper::Dumper($item) );
102 0           my $id = $item->{ $c->pk };
103 0           my $rec = $c->_update( $item, $id );
104 0           push @recs, $rec;
105             }
106             else {
107 0           $c->app->log->debug(
108             'Create record ' . Data::Dumper::Dumper($item) );
109 0           my $rec = $c->_create($item);
110 0           push @recs, $rec;
111             }
112             }
113 0           return @recs;
114             }
115              
116             sub _qs2q {
117 0     0     my $c = shift;
118 0           my $flt = $c->req->query_params->to_hash;
119 0           my $qry = {};
120 0           my $opt = {};
121 0           my $rc = 0;
122              
123 0           $opt->{sort} = new Tie::IxHash;
124              
125             # query string parse
126 0           while ( my ( $k, $v ) = each %$flt ) {
127 0 0         $v = $v + 0 if ( looks_like_number($v) );
128 0 0         $v = undef if ( $v eq '[null]' );
129 0           for ($k) {
130              
131             # match exact filter
132 0 0         if (/^q\[(.*?)\]/) {
    0          
    0          
    0          
    0          
    0          
133 0     0     $c->_query_builder( \$qry, $1, $v, sub { return shift } );
  0            
134             }
135              
136             # match regexp filter
137             elsif (/^qre\[(.*?)\]/) {
138             $c->_query_builder( \$qry, $1, $v,
139 0     0     sub { $a = shift; return qr/$a/i } );
  0            
  0            
140             }
141              
142             # advanced sort
143 0           elsif (/^sort\[(.*?)\]/) { $opt->{sort}->Push( $1 => $v ) }
144 0           elsif ( $_ eq 'limit' ) { $opt->{limit} = $v }
145 0           elsif ( $_ eq 'skip' ) { $opt->{skip} = $v }
146 0           elsif ( $_ eq 'rc' ) { $rc = $v }
147             }
148             }
149              
150             # page here because i must have limit
151 0 0 0       if ( defined $flt->{page} && defined $flt->{limit} ) {
152 0           $opt->{skip} = $flt->{limit} * ( $flt->{page} - 1 );
153             }
154              
155             # simple sort, needs sort and order
156 0 0 0       if ( defined $flt->{sort} && defined $flt->{order} ) {
157 0 0         $opt->{sort}->Push( $flt->{sort} => $flt->{order} eq 'asc' ? -1 : 1 );
158             }
159              
160 0           $c->app->log->debug( 'Query url: '
161             . Data::Dumper::Dumper($flt)
162             . "\nSearch: "
163             . Data::Dumper::Dumper($qry)
164             . "\nOpt: "
165             . Data::Dumper::Dumper($opt) );
166              
167 0           return ( $qry, $opt, $rc );
168             }
169              
170             sub _query_builder {
171 0     0     my ( $c, $qry, $k, $v, $func ) = @_;
172 0 0         if ( ref($v) ne 'ARRAY' ) {
173 0 0         $v = $c->_oid($v) if ( $k eq '_id' );
174 0 0         if ( $v =~ /^(true)|(false)$/ ) {
175 0 0         $v = $v eq 'true' ? true : false;
176             }
177 0           $$qry->{$k} = $func->($v);
178             }
179             else {
180 0           $$qry->{'$or'} = [];
181 0           foreach my $value (@$v) {
182 0 0         if ( $value =~ /^(true)|(false)$/ ) {
183 0 0         $value = $value eq 'true' ? true : false;
184             }
185 0 0         $value = $c->_oid($value) if ( $k eq '_id' );
186 0           push @{ $$qry->{'$or'} }, { $k => $func->($value) };
  0            
187             }
188             }
189             }
190              
191             sub _resource_lookup {
192 0     0     my $c = shift;
193 0           my $id = $c->restify->current_id;
194 0           my $oid = $c->_oid($id);
195 0 0         return unless ($oid);
196 0           my $rec = $c->tableDB->find_one( { $c->pk => $oid } );
197             }
198              
199             sub _oid {
200 0     0     my $c = shift;
201 0           my $id = shift;
202              
203             # oid in {"$oid" : "012345678901234567890123"} format
204 0 0 0       $id = $id->{'$oid'} if ( ref($id) eq 'HASH' && exists( $id->{'$oid'} ) );
205              
206             # convert to 12 byte packet
207 0           $id = pack( "H*", $id );
208              
209 0           my $oid;
210 0           eval { $oid = new BSON::OID( oid => $id ) };
  0            
211              
212 0 0         if ($@) {
213 0           return $c->_raise_error( "ID '$id' is not valid", 400 );
214             }
215 0           return $oid;
216             }
217              
218             1;
219              
220             =pod
221              
222             =head1 NAME
223              
224             Mojo::Leds::Rest::MongoDB - A RESTFul interface to MongoDB
225              
226             =head1 VERSION
227              
228             version 1.13
229              
230             =head1 SYNOPSIS
231              
232             =head1 DESCRIPTION
233              
234             =encoding UTF-8
235              
236             =head1 AUTHOR
237              
238             Emiliano Bruni
239              
240             =head1 COPYRIGHT AND LICENSE
241              
242             This software is copyright (c) 2022 by Emiliano Bruni.
243              
244             This is free software; you can redistribute it and/or modify it under
245             the same terms as the Perl 5 programming language system itself.
246              
247             =cut
248              
249             __END__