File Coverage

lib/CallBackery/Database.pm
Criterion Covered Total %
statement 17 137 12.4
branch 0 14 0.0
condition 0 10 0.0
subroutine 6 20 30.0
pod 14 15 93.3
total 37 196 18.8


line stmt bran cond sub pod time code
1             package CallBackery::Database;
2              
3             # $Id: Database.pm 542 2013-12-12 16:36:34Z oetiker $
4              
5 1     1   8 use Mojo::Base -base,-signatures;
  1         3  
  1         7  
6              
7 1     1   287 use Data::Dumper;
  1         2  
  1         56  
8 1     1   5 use Carp qw(croak);
  1         2  
  1         61  
9 1     1   7 use CallBackery::Exception qw(mkerror);
  1         2  
  1         56  
10 1     1   8 use Scalar::Util qw(weaken);
  1         2  
  1         2270  
11              
12             =head1 NAME
13              
14             CallBackery::Database - database access helpers
15              
16             =head1 SYNOPSIS
17              
18             use CallBackery::Database;
19             my $db = CallBackery::Database->new(app=>$self->config);
20             my ($fields,$values) = $self->map2sql(table,data);
21             my $selWhere = $self->map2where(table,data);
22             my $rowHash = $self->fetchRow(table,{field=>val,field=>val},selExpression?);
23             my $value = $self->fetchValue(table,{field=>val,field=>val},column);
24             my $id = $self->matchData(table,{field=>val,field=>val});
25             my $id = $self->lookUp(table,field,value);
26             my $id = $self->updateOrInsertData(table,{dataField=>val,...},{matchField=>val,...}?);
27             my $id = $self->insertIfNew(table,{field=>val,field=>val});
28              
29             =head1 DESCRIPTION
30              
31             Database access helpers.
32              
33             =head2 config
34              
35             object needs access to the system config to get access to the database
36              
37             =cut
38              
39             has app => sub {
40             croak "app property is required";
41             };
42              
43             has userName => sub {
44             return "* no user *";
45             };
46              
47             has config => sub {
48             shift->app->config;
49             };
50              
51              
52             =head2 dhb
53              
54             a dbi database handle
55              
56             =cut
57              
58             my $lastFlush = time;
59              
60             has sql => sub {
61             my $self = shift;
62             require Mojo::SQLite;
63             my $sql = Mojo::SQLite->new($self->config->cfgHash->{BACKEND}{cfg_db});
64              
65             $sql->options({
66             RaiseError => 1,
67             PrintError => 0,
68             AutoCommit => 1,
69             ShowErrorStatement => 1,
70             sqlite_unicode => 1,
71             FetchHashKeyName=>'NAME_lc',
72             });
73              
74             $sql->on(connection => sub ($sql, $dbh) {
75             $dbh->do('PRAGMA foreign_keys = ON;');
76             });
77              
78             $sql->migrations
79             ->name('cbmig')
80             ->from_data(__PACKAGE__,'dbsetup.sql')
81             ->migrate;
82              
83             return $sql;
84             };
85              
86             # this must be fresh ... always!
87             sub mojoSqlDb {
88 2     2 0 20 my $self = shift;
89 2         7 return $self->sql->db;
90             };
91              
92             =over 4
93              
94             =item my($fields,$values) = $self->C;
95              
96             Provide two hash pointers and quote the field names for inclusion into an
97             SQL expression. Build field names according to the table_field rule.
98              
99             =cut
100              
101             sub map2sql {
102 0     0 1   my $self = shift;
103 0           my $table = shift;
104 0           my $data = shift;
105 0           my @values;
106             my @fields;
107 0           while (my($field, $value) = each %$data) {
108 0           push @fields,$self->mojoSqlDb->dbh->quote_identifier($table."_".$field);
109 0           push @values,$value;
110             }
111 0           return (\@fields,\@values);
112             }
113              
114             =item my $sqlWhere = $self->C;
115              
116             build a where statement Find a record matching the given data in a table the
117             data is a map. Quote field names and values. Build field names according to
118             the table_field rule.
119              
120             =cut
121              
122             sub map2where {
123 0     0 1   my $self = shift;
124 0           my $table = shift;
125 0           my $data = shift;
126 0           my $db = $self->mojoSqlDb;
127 0           my @expression;
128 0           while (my($field, $value) = each %$data) {
129 0           my $field = $db->dbh->quote_identifier($table."_".$field);
130 0           my $expr;
131 0 0         if (defined $value){
132 0           $expr = $field.' = '.$db->dbh->quote($value);
133             }
134             else {
135 0           $expr = $field.' is null';
136             }
137 0           push @expression, $expr;
138             }
139 0           return (join ' AND ',@expression);
140             }
141              
142             =item $hashRef = $self->C;
143              
144             Get an array of hashes with model and label tags:
145              
146             [{model: x, label: y},{id ...},...]
147              
148             =cut
149              
150             sub getMap {
151 0     0 1   my $self = shift;
152 0           my $table = shift;
153 0           my $column = shift;
154 0           my $db = $self->mojoSqlDb;
155 0           my $sqlId = $db->dbh->quote_identifier($table."_id");
156 0           my $sqlColumn = $db->dbh->quote_identifier($table."_".$column);
157 0           my $sqlTable = $db->dbh->quote_identifier($table);
158 0           my $SQL = <<"SQL";
159             SELECT $sqlId as model, $sqlColumn as label
160             FROM $sqlTable
161             ORDER by $sqlColumn
162             SQL
163 0           return $db->dbh->selectall_arrayref($SQL,{Slice=>{}});
164             }
165              
166             =item $hashRef = $self->Cvalue,....},$selectExpr?)>;
167              
168             Get a hash with record index as key. Optionally with a list of columns to return.
169              
170             {
171             2 => { a=>x, b=>y },
172             3 => { a=>k, b=>r }
173             }
174              
175             =cut
176              
177             sub getRowHash {
178 0     0 1   my $self = shift;
179 0           my $table = shift;
180 0           my $data = shift;
181 0   0       my $selectCols = shift // '*';
182 0           my $db = $self->mojoSqlDb;
183 0           my $sqlTable = $db->dbh->quote_identifier($table);
184 0           my $sqlWhere = $self->map2where($table,$data);
185 0           my $SQL = <<"SQL";
186             SELECT $selectCols
187             FROM $sqlTable
188             WHERE $sqlWhere
189             SQL
190 0           return $db->dbh->selectall_hashref($SQL,$table."_id",{Slice=>{}});
191             }
192              
193              
194             =item $id = $self->Cvalue,key=>value},$selectExp ?)>;
195              
196             Find a record matching the given data in a table and return a hash of the matching record.
197              
198             =cut
199              
200             sub fetchRow {
201 0     0 1   my $self = shift;
202 0           my $table = shift;
203 0           my $data = shift;
204 0   0       my $selectCols = shift // '*';
205 0           my $db = $self->mojoSqlDb;
206 0           my $sqlWhere = $self->map2where($table,$data);
207 0           my $sqlTable = $db->dbh->quote_identifier($table);
208 0           my $SQL = <<"SQL";
209             SELECT $selectCols
210             FROM $sqlTable
211             WHERE $sqlWhere
212             SQL
213 0           return $db->dbh->selectrow_hashref($SQL);
214             }
215              
216             =item $id = $self->Cvalue,key=>value},column)>;
217              
218             Find a record matching the given data in a table and returns the value in column.
219              
220             =cut
221              
222             sub fetchValue {
223 0     0 1   my $self = shift;
224 0           my $table = shift;
225 0           my $where = shift;
226 0           my $column = shift;
227 0           my $db = $self->mojoSqlDb;
228 0           my $row = $self->fetchRow($table,$where,$db->dbh->quote_identifier($table.'_'.$column));
229 0 0         if ($row){
230 0           return $row->{$table.'_'.$column};
231             }
232             else {
233 0           return undef;
234             }
235             }
236              
237              
238             =item $id = $self->C;
239              
240             Find a record matching the given data in a table
241             the data is a map.
242              
243             =cut
244              
245             sub matchData {
246 0     0 1   my $self = shift;
247 0           my $table = shift;
248 0           my $data = shift;
249 0           my $found = $self->fetchValue($table,$data,"id");
250 0           return $found;
251              
252             }
253              
254             =item $id = $self->C
255              
256             Lookup the value in table in table_column and return table_id.
257             Throw an exception if this fails. Use matchData if you are just looking.
258              
259             =cut
260              
261             sub lookUp {
262 0     0 1   my $self = shift;
263 0           my $table = shift;
264 0           my $column = shift;
265 0           my $value = shift;
266 0 0         my $id = $self->matchData($table,{$column => $value})
267             or die mkerror(1349,"Lookup for $column = $value in $table faild");
268 0           return $id;
269             }
270              
271             =item $id = $self->C
272              
273             Insert the given data into the table. If a match map is given, try an update first
274             with the given match only insert when update has 0 hits.
275              
276             =cut
277              
278             sub updateOrInsertData {
279 0     0 1   my $self = shift;
280 0           my $table = shift;
281 0           my $data = shift;
282 0           my $match = shift;
283 0           my $db = $self->mojoSqlDb;
284 0           my ($colNames,$colValues) = $self->map2sql($table,$data);
285 0           my $sqlTable = $db->dbh->quote_identifier($table);
286 0           my $sqlIdCol = $db->dbh->quote_identifier($table."_id");
287 0           my $sqlColumns = join ', ', @$colNames;
288 0           my $sqlSet = join ', ', map { "$_ = ?" } @$colNames;
  0            
289 0           my $sqlData = join ', ', map { '?' } @$colValues;
  0            
290 0 0         if ($match){ # try update first if we have an id
291 0           my $matchWhere = $self->map2where($table,$match);
292 0           my $SQL = <<"SQL";
293             UPDATE $sqlTable SET $sqlSet
294             WHERE $matchWhere
295             SQL
296 0           my $count = $db->dbh->do($SQL,{},@$colValues);
297 0 0         if ($count > 0){
298 0   0       return ( $data->{id} // $match->{id} );
299             }
300             }
301 0           my $SQL = <<"SQL";
302             INSERT INTO $sqlTable ( $sqlColumns )
303             VALUES ( $sqlData )
304             SQL
305 0           $db->dbh->do($SQL,{},@$colValues);
306              
307             # non serial primary key, id defined by user
308 0 0         if (exists $data->{'id'}){
309 0           return $data->{'id'};
310             }
311             # serial primary key
312             else{
313 0           return $db->dbh->last_insert_id(undef,undef,$table,$table."_id");
314             }
315             }
316              
317             =item $id = $self->C
318              
319             Lookup the given data. If it is new, insert a record. Returns the matching Id.
320              
321             =cut
322              
323             sub insertIfNew {
324 0     0 1   my $self = shift;
325 0           my $table = shift;
326 0           my $data = shift;
327 0   0       return ( $self->matchData($table,$data)
328             // $self->updateOrInsertData($table,$data));
329             }
330              
331             =item $id = $self->C
332              
333             Delete data from table. Given the record id.
334             Returns true if the record was deleted.
335              
336             =cut
337              
338             sub deleteData {
339 0     0 1   my $self = shift;
340 0           my $table = shift;
341 0           my $id = shift;
342 0           return $self->deleteDataWhere($table,{id=>$id});
343             }
344              
345             =item $id = $self->Cval,key=>val})>
346              
347             Delete data from table. Given the column title and the matching value.
348             Returns true if the record was deleted.
349              
350             =cut
351              
352             sub deleteDataWhere {
353 0     0 1   my $self = shift;
354 0           my $table = shift;
355 0           my $match = shift;
356 0           my $val = shift;
357 0           my $db = $self->mojoSqlDb;
358 0           my $sqlTable = $db->dbh->quote_identifier($table);
359 0           my $matchWhere = $self->map2where($table,$match);
360 0           my $SQL = 'DELETE FROM '.$sqlTable.' WHERE '.$matchWhere;
361             # say $SQL;
362 0           return $db->dbh->do($SQL);
363             }
364              
365             =item getConfigValue($key)
366              
367             return a raw data value from the config table
368              
369             =cut
370              
371             sub getConfigValue {
372 0     0 1   my $self = shift;
373 0           my $key = shift;
374 0           my $value = eval {
375 0           local $SIG{__DIE__};
376 0           $self->fetchValue('cbconfig',{id => $key},'value');
377             };
378 0 0         return ($@ ? undef : $value);
379             }
380              
381             =item setConfigValue($key,$value)
382              
383             write a config value
384              
385             =cut
386              
387             sub setConfigValue {
388 0     0 1   my $self = shift;
389 0           my $key = shift;
390 0           my $value = shift;
391             # warn "SET $key -> ".Dumper([$value]);
392 0           $self->updateOrInsertData('cbconfig',{
393             id=> $key,
394             value => $value
395             }, { id => $key });
396 0           return $value;
397             }
398              
399             1;
400              
401             =back
402              
403             =head1 COPYRIGHT
404              
405             Copyright (c) 2015 by OETIKER+PARTNER AG. All rights reserved.
406              
407             =head1 AUTHOR
408              
409             Stobi@oetiker.chE>
410              
411             =head1 HISTORY
412              
413             2010-06-12 to 1.0 initial
414             2013-11-19 to 1.1 converted to mojo
415              
416             =cut
417              
418             __DATA__