File Coverage

blib/lib/Database/DumpTruck.pm
Criterion Covered Total %
statement 169 170 99.4
branch 46 60 76.6
condition 29 55 52.7
subroutine 24 24 100.0
pod 14 17 82.3
total 282 326 86.5


line stmt bran cond sub pod time code
1             package Database::DumpTruck;
2              
3             =head1 NAME
4              
5             Database::DumpTruck - Relaxing interface to SQLite
6              
7             =head1 SYNOPSIS
8              
9             my $dt = new Database::DumpTruck;
10              
11             $dt->insert({Hello => 'World'});
12             $dt->create_index(['Hello']);
13             $dt->upsert({Hello => 'World', Yolo => 8086});
14             my $data = $dt->dump;
15              
16             $dt->insert([
17             {Hello => 'World'},
18             {Hello => 'Hell', Structured => {
19             key => value,
20             array => [ 1, 2, 3, {} ],
21             }}], 'table2');
22             my $data2 = $dt->dump('table2');
23             $dt->drop('table2');
24             $dt->execute('SELECT 666');
25              
26             my @columns = $dt->column_names();
27              
28             $dt->save_var('number_of_the_beast', 666);
29             my $number_of_the_beast = $dt->get_var('number_of_the_beast');
30              
31             =head1 DESCRIPTION
32              
33             This is a simple document-oriented interface to a SQLite database, modelled
34             after Scraperwiki's Python C module. It allows for easy (and maybe
35             inefficient) storage and retrieval of structured data to and from a database
36             without interfacing with SQL.
37              
38             L attempts to identify the type of the data you're
39             inserting and uses an appropriate SQLite type:
40              
41             =over 4
42              
43             =item C
44              
45             This is used for integer values. Will be used for C<8086>, but not C<"8086"> or
46             C<8086.0>.
47              
48             =item C
49              
50             This is used for numeric values that are not integer. Will be used for
51             C<8086.0>, but not C<"8086"> or C<8086>.
52              
53             =item C
54              
55             This is used for values that look like result of logical statemen. A crude
56             check for values that are both C<""> and C<0> or both C<"1"> and C<1> at the
57             same time is in place. This is a result of comparison or a negation.
58              
59             To force a value to look like boolean, prepend it with a double negation: e.g.
60             C or C.
61              
62             =item C
63              
64             Used for C and C references. Values are converted into and from
65             JSON strings upon C and C.
66              
67             =item C
68              
69             Pretty much everything else.
70              
71             =back
72              
73             =cut
74              
75 1     1   61936 use strict;
  1         4  
  1         68  
76 1     1   6 use warnings;
  1         2  
  1         31  
77              
78 1     1   719068 use DBI;
  1         26846  
  1         79  
79 1     1   11 use B;
  1         1  
  1         42  
80 1     1   1447 use JSON;
  1         17488  
  1         7  
81             require DBD::SQLite;
82              
83             our $VERSION = '1.2';
84              
85             sub get_column_type
86             {
87 71     71 0 1488 my $v = shift;
88              
89 71 100       219 return '' unless defined $v;
90              
91             # A reference?
92 62         132 my $ref = ref $v;
93 62 100       173 if ($ref) {
94 7 50 66     87 return 'json text' if $ref eq 'ARRAY' or $ref eq 'HASH';
95             # TODO: blessings into some magic package names to force a type?
96             # TODO: What's the most canonical package to describe datetime?
97             }
98              
99             # A scalar.
100 55         378 my $obj = B::svref_2object (\$v);
101 55         234 my $flags = $obj->FLAGS;
102              
103             # Could here be a better way to detect a boolean?
104 55 100       165 if (($flags & (B::SVf_NOK | B::SVf_POK))
105             == (B::SVf_NOK | B::SVf_POK))
106             {
107 2 50 33     93 return 'bool'
      33        
      33        
108             if ($obj->NV == 0 && $obj->PV eq '')
109             or ($obj->NV == 1 && $obj->PV eq '1');
110             }
111              
112 53 100       469 return 'text' if $flags & B::SVf_POK;
113 21 50       58 return 'real' if $flags & B::SVf_NOK;
114 21 50       176 return 'integer' if $flags & B::SVf_IOK;
115              
116 0         0 return 'text';
117             }
118              
119             sub convert
120             {
121 28     28 0 96 my $data = shift;
122 28         40 my @retval;
123              
124 28 100       135 foreach my $row (ref $data eq 'ARRAY' ? @$data : ($data)) {
125 31         173 push @retval, [ map { [ $_ => $row->{$_} ] } sort keys %$row ];
  48         243  
126             }
127              
128 28         94 return \@retval;
129             }
130              
131             sub simplify
132             {
133 2     2 0 4 my $text = shift;
134 2         5 $text =~ s/[^a-zA-Z0-9]//g;
135 2         8 return $text;
136             }
137              
138             =head1 METHODS
139              
140             =over 4
141              
142             =item B ([params])
143              
144             Initialize the database handle. Accepts optional hash with parameters:
145              
146             =over 8
147              
148             =item B (Default: C)
149              
150             The database file.
151              
152             =item B (Default: C)
153              
154             Name for the default table.
155              
156             =item B (Default: C<_dumptruckvars>)
157              
158             Name of the variables table.
159              
160             =item B (Default: C<_dumptruckvarstmp>)
161              
162             Name of the temporary table used when converting the values for variables table.
163              
164             =item B (Default: C<1>)
165              
166             Enable automatic commit.
167              
168             =back
169              
170             =cut
171              
172             sub new
173             {
174 3     3 1 1034 my $class = shift;
175 3   50     13 my $self = shift || {};
176              
177 3   50     11 $self->{dbname} ||= 'dumptruck.db';
178 3   50     21 $self->{table} ||= 'dumptruck';
179 3   50     17 $self->{vars_table} ||= '_dumptruckvars';
180 3   50     16 $self->{vars_table_tmp} ||= '_dumptruckvarstmp';
181 3 100       13 $self->{auto_commit} = 1
182             unless exists $self->{auto_commit};
183              
184 3 50       31 $self->{dbh} = DBI->connect("dbi:SQLite:$self->{dbname}","","", {
185             AutoCommit => $self->{auto_commit},
186             RaiseError => 1, PrintError => 0 })
187             or die "Could get a database handle: $!";
188 3         3486 $self->{dbh}{sqlite_unicode} = 1;
189              
190 3         140 return bless $self, $class;
191             }
192              
193             =item B ([table_name])
194              
195             Return a list of names of all columns in given table, or table C.
196              
197             =cut
198              
199             sub column_names
200             {
201 15     15 1 29 my $self = shift;
202 15   66     2877 my $table_name = shift || $self->{table};
203              
204 15         391 $self->execute (sprintf 'PRAGMA table_info(%s)',
205             $self->{dbh}->quote ($table_name))
206             }
207              
208             sub _check_or_create_vars_table
209             {
210 4     4   8 my $self = shift;
211              
212 4         68 $self->execute (sprintf 'CREATE TABLE IF NOT EXISTS %s '.
213             '(`key` text PRIMARY KEY, `value` blob, `type` text)',
214             $self->{dbh}->quote ($self->{vars_table}));
215             }
216              
217             =item B (sql, [params])
218              
219             Run a raw SQL statement and get structured output. Optional parameters for C
220             placeholders can be specified.
221              
222             =cut
223              
224             sub execute
225             {
226 160     160 1 1459 my $self = shift;
227 160         221 my $sql = shift;
228 160         1983 my @params = @_;
229 160         234 my @retval;
230              
231 160 50       510 warn "Executing statement: '$sql'" if $self->{debug};
232 160         1173 my $sth = $self->{dbh}->prepare ($sql);
233 116         2805919 $sth->execute (@params);
234              
235 114 100       4771 return [] unless $sth->{NUM_OF_FIELDS};
236              
237 49         801 while (my $row = $sth->fetch) {
238 82         865 my $types = $sth->{TYPE};
239 82         1345 my $names = $sth->{NAME_lc};
240 82         319 push @retval, {};
241              
242 82         318 foreach (0..$#$row) {
243 270         7558 my $data = $row->[$_];
244 270 100 100     1313 $data = decode_json ($data) if $data and $types->[$_] eq 'json text';
245 270         2183 $retval[$#retval]->{$names->[$_]} = $data;
246             }
247             };
248              
249 49         1342 return \@retval;
250             }
251              
252             =item B ()
253              
254             Commit outstanding transaction. Useful when C is off.
255              
256             =cut
257              
258             sub commit
259             {
260 1     1 1 4 my $self = shift;
261              
262 1         58883 $self->{dbh}->commit;
263             }
264              
265             =item B ()
266              
267             Close the database handle. You should not need to call this explicitly.
268              
269             =cut
270              
271             sub close
272             {
273 1     1 1 3 my $self = shift;
274              
275 1         89 $self->{dbh}->disconnect;
276 1         6 $self->{dbh} = undef;
277             }
278              
279             =item B (columns, [table_name], [if_not_exists], [unique])
280              
281             Create an optionally unique index on columns in a given table. Can be told
282             to do nothing if the index already exists.
283              
284             =cut
285              
286             sub create_index
287             {
288 1     1 1 3 my $self = shift;
289 1         3 my $columns = shift;
290 1   33     5 my $table_name = shift || $self->{table};
291 1         3 my $if_not_exists = shift;
292 1 50 33     8 $if_not_exists = (not defined $if_not_exists or $if_not_exists)
293             ? 'IF NOT EXISTS' : '';
294 1 50       7 my $unique = (shift) ? 'UNIQUE' : '';
295              
296 1         5 my $index_name = join '_', (simplify ($table_name),
297 1         5 map { simplify ($_) } @$columns);
298              
299 1         15 $self->execute (sprintf 'CREATE %s INDEX %s %s ON %s (%s)',
300             $unique, $if_not_exists, $index_name,
301             $self->{dbh}->quote ($table_name),
302 1         11 join (',', map { $self->{dbh}->quote ($_) } @$columns));
303             }
304              
305             sub _check_and_add_columns
306             {
307 30     30   55 my $self = shift;
308 30         54 my $table_name = shift;
309 30         77 my $row = shift;
310              
311 30         99 foreach (@$row) {
312 48         109 my ($k, $v) = @$_;
313 48         95 eval { $self->execute (sprintf 'ALTER TABLE %s ADD COLUMN %s %s',
  48         955  
314             $self->{dbh}->quote ($table_name),
315             $self->{dbh}->quote ($k), get_column_type ($v)) };
316 48 50 66     4861 die if $@ and not $@ =~ /duplicate column name/;
317             }
318             }
319              
320             =item B (data, table_name, [error_if_exists])
321              
322             Create a table and optionally error out if it already exists. The data
323             structure will be based on data, though no data will be inserted.
324              
325             =cut
326              
327             sub create_table
328             {
329 15     15 1 12281 my $self = shift;
330 15         24 my $data = shift;
331 15 50       53 my $table_name = shift or die 'Need table name';
332 15         23 my $error_if_exists = shift;
333              
334             # Get ordered key-value pairs
335 15         56 my $converted_data = convert ($data);
336 15 100       67 die 'No data passed' unless $converted_data->[0];
337              
338             # Find first non-null column
339 14         65 my $startdata = $converted_data->[0];
340 14         30 my ($k, $v);
341 14         43 foreach (@$startdata) {
342 13         37 ($k, $v) = @$_;
343 13 100       41 last if defined $v;
344             }
345              
346             # No columns, don't attempt table creation. Do not die either as
347             # the table might already exist and user may just want to insert
348             # an all-default/empty row.
349 14 100       41 return unless $k;
350              
351             # Create the table with the first column
352 13 50       43 my $if_not_exists = 'IF NOT EXISTS' unless $error_if_exists;
353 13         136 $self->execute (sprintf 'CREATE TABLE %s %s (%s %s)',
354             $if_not_exists, $self->{dbh}->quote ($table_name),
355             $self->{dbh}->quote ($k), get_column_type ($v));
356              
357             # Add other rows
358 13         275 foreach (@$converted_data) {
359 15         85 $self->_check_and_add_columns ($table_name, $_);
360             }
361             }
362              
363             =item B (data, [table_name], [upsert])
364              
365             Insert (and optionally replace) data into a given table or C.
366             Creates the table with proper structure if it does not exist already.
367              
368             =cut
369              
370             sub insert
371             {
372 14     14 1 950 my $self = shift;
373 14         29 my $data = shift;
374 14   66     79 my $table_name = shift || $self->{table};
375 14         27 my $upsert = shift;
376              
377             # Override existing entries
378 14 100       44 my $upserttext = ($upsert ? 'OR REPLACE' : '');
379              
380             # Ensure the table itself exists
381 14         57 $self->create_table ($data, $table_name);
382              
383             # Learn about the types of already existing fields
384 23         156 my %column_types = map { lc($_->{name}) => $_->{type} }
  13         66  
385 13         645 @{$self->column_names ($table_name)};
386              
387             # Get ordered key-value pairs
388 13         91 my $converted_data = convert ($data);
389 13 50 33     81 die 'No data passed' unless $converted_data and $converted_data->[0];
390              
391             # Add other rows
392 13         21 my @rowids;
393 13         89 foreach (@$converted_data) {
394 15         61 $self->_check_and_add_columns ($table_name, $_);
395              
396 15         28 my (@keys, @values);
397 15         40 foreach my $cols (@$_) {
398 23         153 my ($key, $value) = @$cols;
399              
400             # Learn about the type and possibly do a conversion
401 23 100       82 my $type = $column_types{lc($key)} or get_column_type ($value);
402 23 100       105 $value = encode_json ($value) if $type eq 'json text';
403              
404 23         36 push @keys, $key;
405 23         51 push @values, $value;
406             }
407              
408 15 100       43 if (@keys) {
409 14         41 my $question_marks = join ',', map { '?' } 1..@keys;
  23         86  
410 23         249 $self->execute (sprintf ('INSERT %s INTO %s (%s) VALUES (%s)',
411             $upserttext, $self->{dbh}->quote ($table_name),
412 14         79 join (',', map { $self->{dbh}->quote($_) } @keys),
413             $question_marks), @values);
414             } else {
415 1         9 $self->execute (sprintf 'INSERT %s INTO %s DEFAULT VALUES',
416             $upserttext, $self->{dbh}->quote ($table_name));
417             }
418              
419 14         444 push @rowids, $self->execute ('SELECT last_insert_rowid()')
420             ->[0]{'last_insert_rowid()'};
421             }
422 12 50 66     405 return (ref $data eq 'HASH' and $data->{keys}) ? $rowids[0] : @rowids;
423             }
424              
425             =item B (data, [table_name])
426              
427             Replace data into a given table or C. Creates the table with proper
428             structure if it does not exist already.
429              
430             Equivalent to calling C with C parameter set to C<1>.
431              
432             =cut
433              
434             sub upsert
435             {
436 1     1 1 3 my $self = shift;
437 1         2 my $data = shift;
438 1         3 my $table_name = shift;
439              
440 1         5 $self->insert ($data, $table_name, 1);
441             }
442              
443             =item B (key)
444              
445             Retrieve a saved value for given key from the variable database.
446              
447             =cut
448              
449             sub get_var
450             {
451 4     4 1 12 my $self = shift;
452 4         11 my $k = shift;
453              
454 4         48 my $data = $self->execute(sprintf ('SELECT * FROM %s WHERE `key` = ?',
455             $self->{dbh}->quote ($self->{vars_table})), $k);
456 4 50 33     35 return unless defined $data and exists $data->[0];
457              
458             # Create a temporary table, to take advantage of the type
459             # guessing and conversion we do in dump()
460 4         29 $self->execute (sprintf 'CREATE TEMPORARY TABLE %s (`value` %s)',
461             $self->{dbh}->quote ($self->{vars_table_tmp}),
462             $self->{dbh}->quote ($data->[0]{type}));
463 4         89 $self->execute (sprintf ('INSERT INTO %s (`value`) VALUES (?)',
464             $self->{dbh}->quote ($self->{vars_table_tmp})),
465             $data->[0]{value});
466 4         53 my $v = $self->dump ($self->{vars_table_tmp})->[0]{value};
467 4         25 $self->drop ($self->{vars_table_tmp});
468              
469 4         74 return $v;
470             }
471              
472             =item B (key, value)
473              
474             Insert a value for given key into the variable database.
475              
476             =cut
477              
478             sub save_var
479             {
480 4     4 1 9 my $self = shift;
481 4         9 my $k = shift;
482 4         11 my $v = shift;
483              
484 4         17 $self->_check_or_create_vars_table;
485              
486             # Create a temporary table, to take advantage of the type
487             # guessing and conversion we do in insert()
488 4         68 my $column_type = get_column_type ($v);
489 4         25 $self->drop ($self->{vars_table_tmp}, 1);
490 4         58 $self->insert ({ value => $v }, $self->{vars_table_tmp});
491              
492 4         45 $self->execute(sprintf ('INSERT OR REPLACE INTO %s '.
493             '(`key`, `type`, `value`)'.
494             'SELECT ? AS key, ? AS type, value FROM %s',
495             $self->{dbh}->quote ($self->{vars_table}),
496             $self->{dbh}->quote ($self->{vars_table_tmp})),
497             $k, get_column_type ($v));
498              
499 4         173 $self->drop ($self->{vars_table_tmp});
500             }
501              
502             =item B ()
503              
504             Returns a list of names of all tables in the database.
505              
506             =cut
507              
508             sub tables
509             {
510 1     1 1 3 my $self = shift;
511              
512 1         2 map { $_->{name} } @{$self->execute
  2         13  
  1         4  
513             ('SELECT name FROM sqlite_master WHERE TYPE="table"')};
514             }
515              
516             =item B ([table_name])
517              
518             Returns all data from the given table or C nicely structured.
519              
520             =cut
521              
522             sub dump
523             {
524 17     17 1 1778 my $self = shift;
525 17   66     123 my $table_name = shift || $self->{table};
526              
527 17         180 $self->execute (sprintf 'SELECT * FROM %s',
528             $self->{dbh}->quote ($table_name))
529             }
530              
531             =item B ([table_name])
532              
533             Drop the given table or C.
534              
535             =cut
536              
537             sub drop
538             {
539 15     15 1 137 my $self = shift;
540 15   66     64 my $table_name = shift || $self->{table};
541 15         24 my $if_exists = shift;
542              
543 15 100       157 $self->execute (sprintf 'DROP TABLE %s %s',
544             ($if_exists ? 'IF EXISTS' : ''),
545             $self->{dbh}->quote ($table_name))
546             }
547              
548             =back
549              
550             =head1 BUGS
551              
552             None known.
553              
554             =head1 SEE ALSO
555              
556             =over
557              
558             =item *
559              
560             L - Python module this one is
561             heavily inspired by.
562              
563             =back
564              
565             =head1 COPYRIGHT
566              
567             Copyright 2014, Lubomir Rintel
568              
569             This program is free software; you can redistribute it and/or modify it
570             under the same terms as Perl itself.
571              
572             =head1 AUTHOR
573              
574             Lubomir Rintel L<< >>
575              
576             =cut
577              
578             1;