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