File Coverage

lib/DBIx/Oro/Driver/SQLite.pm
Criterion Covered Total %
statement 253 295 85.7
branch 91 152 59.8
condition 52 86 60.4
subroutine 33 35 94.2
pod 18 18 100.0
total 447 586 76.2


line stmt bran cond sub pod time code
1             package DBIx::Oro::Driver::SQLite;
2 23     23   169 use warnings;
  23         42  
  23         939  
3 23     23   136 use strict;
  23         41  
  23         566  
4 23     23   122 use DBIx::Oro;
  23         44  
  23         205  
5             our @ISA;
6 23     23   949 BEGIN { @ISA = 'DBIx::Oro' };
7              
8 23     23   323 use v5.10.1;
  23         77  
9              
10             # Todo: use 'truncate' for table deletion
11              
12             # Defaults to 500 for SQLITE_MAX_COMPOUND_SELECT
13             our $MAX_COMP_SELECT;
14              
15             BEGIN {
16 23     23   708 $MAX_COMP_SELECT = 500;
17             };
18              
19 23     23   145 use Carp qw/carp/;
  23         54  
  23         1467  
20              
21             # Find and create database file
22 23     23   145 use File::Path;
  23         42  
  23         1550  
23 23     23   193 use File::Basename;
  23         51  
  23         81554  
24              
25             # Default arguments for snippet function
26             my @arguments =
27             qw/start end ellipsis column token/;
28              
29             my $arguments = qr/^(?:start|end|ellipsis|column|token)$/;
30              
31             my @default = ('', '', '...', -1, -15);
32              
33              
34             # Constructor
35             sub new {
36 27     27 1 63 my $class = shift;
37 27         112 my %param = @_;
38 27   50     197 $param{created} //= 0;
39              
40 27         44 my $autocommit = delete $param{autocommit};
41              
42             # Bless object with hash
43 27         61 my $self = bless \%param, $class;
44              
45             # Store filename
46 27   50     197 my $file = $self->{file} = $param{file} // '';
47              
48             # Temporary or memory file
49 27 100 100     262 if (!$file || $file eq ':memory:') {
    100          
50 24         49 $self->{created} = 1;
51             }
52              
53             # Create path for file - based on ORLite
54             elsif (!-e $file) {
55              
56 2         519 my $dir = File::Basename::dirname($file);
57 2 50       43 unless (-d $dir) {
58 0         0 File::Path::mkpath( $dir, { verbose => 0 } );
59             };
60              
61             # Touch the file
62 2 50       202 if (open(TOUCH,'>' . $file)) {
63 2         11 $self->{created} = 1;
64 2         22 close(TOUCH);
65             };
66             };
67              
68             # Data source name
69 27         93 $self->{dsn} = 'dbi:SQLite:dbname=' . $self->{file};
70              
71             # Attach hash
72 27 50       104 $self->{attached} = {} unless exists $self->{attached};
73              
74             # Autocommit
75 27         61 ${$self->{autocommit}} =
76 27         57 ${$self->{_autocounter}} = 0;
  27         88  
77              
78             # Set autocommit
79 27 50       85 $self->autocommit($autocommit) if $autocommit;
80              
81             # Return object
82 27         82 $self;
83             };
84              
85              
86             # Initialize database if newly created
87             sub _init {
88 27     27   70 my $self = shift;
89              
90             # Get callback
91             my $cb = delete $self->{init} if $self->{init} &&
92 27 100 50     246 (ref $self->{init} || '') eq 'CODE';
      66        
93              
94             # Import SQL file
95 27         93 my $import = delete $self->{import};
96 27         52 my $import_cb = delete $self->{import_cb};
97              
98             # Initialize database if newly created
99 27 100 66     109 if ($self->created && ($import || $cb)) {
      100        
100              
101             # Start creation transaction
102 6 50       77 unless (
103             $self->txn(
104             sub {
105              
106             # Import SQL file
107 6 50   6   18 if ($import) {
108 0 0       0 $self->import_sql($import, $import_cb) or return -1;
109             };
110              
111             # Release callback
112 6 50       24 if ($cb) {
113 6         30 local $_ = $self;
114 6         22 return $cb->($self);
115             };
116 0         0 return 1;
117             })
118             ) {
119              
120             # Unlink SQLite database
121 0 0       0 if (index($self->file, ':') != 0) {
122 0         0 unlink $self->file;
123             };
124              
125             # Not successful
126 0         0 $self = undef;
127 0         0 return;
128             };
129             };
130              
131 27         323 return 1;
132             };
133              
134              
135             # Connect to database
136             sub _connect {
137 30     30   63 my $self = shift;
138             my $dbh = $self->SUPER::_connect(
139 30 100       213 sqlite_unicode => defined $self->{unicode} ? $self->{unicode} : 1
140             );
141              
142             # Turn foreign keys on as default
143 30 50       293 $dbh->do('PRAGMA foreign_keys = ON') unless $self->{foreign_keys};
144              
145             # Set busy timeout
146 30   50     1428 $dbh->sqlite_busy_timeout( $self->{busy_timeout} || 300 );
147              
148             # Reattach possibly attached databases
149 30         71 while (my ($db_name, $file) = each %{$self->{attached}}) {
  30         190  
150 0         0 $self->prep_and_exec("ATTACH '$file' AS ?", [$db_name]);
151             };
152              
153             # Return database handle
154 30         146 $dbh;
155             };
156              
157              
158             # File of database
159 0   0 0 1 0 sub file { $_[0]->{file} // '' };
160              
161              
162             # Database driver
163 1     1 1 8 sub driver { 'SQLite' };
164              
165              
166             # Database was just created
167             sub created {
168 28     28 1 68 my $self = shift;
169              
170             # Creation state is 0
171 28 100       127 return 0 unless $self->{created};
172              
173             # Check for thread id
174 27 50 33     226 if (defined $self->{tid} && $self->{tid} != threads->tid) {
    50          
175 0         0 return ($self->{created} = 0);
176             }
177              
178             # Check for process id
179             elsif ($self->{pid} != $$) {
180 0         0 return ($self->{created} = 0);
181             };
182              
183             # Return creation state
184 27         244 return 1;
185             };
186              
187              
188             # Explain query plan
189             sub explain {
190 1     1 1 443 my $self = shift;
191              
192             # Prepare and execute explain query plan
193 1         11 my ($rv, $sth) = $self->prep_and_exec(
194             'EXPLAIN QUERY PLAN ' . shift, @_
195             );
196              
197             # Query was not succesfull
198 1 50       4 return unless $rv;
199              
200             # Create string
201 1         2 my $string;
202 1         2 foreach ( @{ $sth->fetchall_arrayref([]) }) {
  1         23  
203 2         61 $string .= sprintf("%3d | %3d | %3d | %-60s\n", @$_);
204             };
205              
206             # Return query plan string
207 1         29 return $string;
208             };
209              
210              
211             # Delete with SQLite feature
212             sub delete {
213 11     11 1 1628 my $self = shift;
214 11         18 my $secure;
215              
216             # Check if -secure parameter is set
217 11 100 66     96 if ($_[-1] && ref $_[-1] && ref $_[-1] eq 'HASH') {
      66        
218 5   50     19 $secure = delete $_[-1]->{-secure} || 0;
219             };
220              
221             # Delete
222 11 50       29 unless ($secure) {
223              
224 11         91 my $rv = $self->SUPER::delete(@_);
225              
226             # Decrement autocommit
227 11 100       48 $self->_decr_commit if $rv;
228              
229 11         78 return $rv;
230             }
231              
232             # Delete securely
233             else {
234              
235             # Security value
236 0         0 my $sec_value;
237              
238             # Retrieve secure delete pragma
239 0         0 my ($rv, $sth) = $self->prep_and_exec('PRAGMA secure_delete');
240 0 0       0 $sec_value = $sth->fetchrow_array if $rv;
241 0         0 $sth->finish;
242              
243             # Set secure_delete pragma
244 0 0       0 $self->do('PRAGMA secure_delete = ON') unless $sec_value;
245              
246             # Delete
247 0         0 $rv = $self->SUPER::delete(@_);
248              
249             # Decrement autocommit
250 0 0       0 $self->_decr_commit if $rv;
251              
252             # Reset secure_delete pragma
253 0 0       0 $self->do('PRAGMA secure_delete = OFF') unless $sec_value;
254              
255             # Return value
256 0         0 return $rv;
257             };
258             };
259              
260              
261             # Insert values to database
262             sub insert {
263 938     938 1 52555 my $self = shift;
264              
265             # Get table name
266 938 50       2584 my $table = $self->_table_name(\@_) or return;
267              
268             # No parameters
269 938 50       1718 return unless $_[0];
270              
271             # Properties
272 938 50 66     3429 my $prop = shift if ref $_[0] eq 'HASH' && ref $_[1];
273              
274             # Single insert
275 938 100       2096 if (ref $_[0] eq 'HASH') {
    50          
276              
277             # Param
278 905         945 my %param = %{ shift(@_) };
  905         2846  
279              
280             # Create insert arrays
281 905         1462 my (@keys, @values);
282 905         2297 while (my ($key, $value) = each %param) {
283             # Insert pairs
284 1351 50 33     8767 next if !ref $key && $key !~ $DBIx::Oro::KEY_REGEX;
285 1351         2234 push @keys, $key;
286 1351         3422 push @values, $value;
287             };
288              
289             # Nothing to insert
290 905 50       1518 return unless @keys;
291              
292             # Create insert string
293 905         1271 my $sql = 'INSERT ';
294              
295 905 50 33     1602 if ($prop && (my $oc = $prop->{-on_conflict})) {
296 0 0       0 if ($oc eq 'replace') {
    0          
297 0         0 $sql = 'REPLACE '
298             }
299             elsif ($oc eq 'ignore') {
300 0         0 $sql .= 'IGNORE '
301             };
302             };
303              
304             $sql .= 'INTO ' . $table .
305 905         1938 ' (' . join(', ', map { "`$_`" } @keys) . ') VALUES (' . DBIx::Oro::_q(\@values) . ')';
  1351         4510  
306              
307             # Prepare and execute
308 905         2405 my $rv = $self->prep_and_exec( $sql, \@values );
309              
310             # Decrement autocommit
311 905 100       3018 $self->_decr_commit if $rv;
312              
313 905         3510 return $rv;
314             }
315              
316             # Multiple inserts
317             elsif (ref($_[0]) eq 'ARRAY') {
318              
319 33 100       112 return unless $_[1];
320              
321 32         44 my @keys = @{ shift(@_) };
  32         82  
322              
323             # Default values
324 32         59 my @default = ();
325              
326             # Check if keys are defaults
327 32         63 my $i = 0;
328 32         50 my @default_keys;
329 32         107 while ($keys[$i]) {
330              
331             # No default - next
332 87 100       216 $i++, next unless ref $keys[$i];
333              
334             # Has default value
335 7         11 my ($key, $value) = @{ splice( @keys, $i, 1) };
  7         19  
336 7         15 push(@default_keys, $key);
337 7         16 push(@default, $value);
338             };
339              
340             # Unshift default keys to front
341 32         58 unshift(@keys, @default_keys);
342              
343 32         107 my $sql = 'INSERT INTO ' . $table . ' (' . join(', ', map { "`$_`" } @keys) . ') ';
  87         251  
344 32         123 my $union = 'SELECT ' . DBIx::Oro::_q(\@keys);
345              
346             # Maximum bind variables
347 32         143 my $max = ($MAX_COMP_SELECT / @keys) - @keys;
348              
349 32 100       98 if (scalar @_ <= $max) {
350              
351             # Add data unions
352 29         135 $sql .= $union . ((' UNION ' . $union) x ( scalar(@_) - 1 ));
353              
354             # Prepare and execute with prepended defaults
355             my @rv = $self->prep_and_exec(
356             $sql,
357 29         60 [ map { (@default, @$_); } @_ ]
  144         437  
358             );
359              
360             # Decrement autocommit
361 29 100       202 $self->_decr_commit if $rv[0];
362              
363 29         546 return @rv;
364             }
365              
366             # More than SQLite MAX_COMP_SELECT insertions
367             else {
368              
369 3         7 my ($rv, @v_array);
370 3         411 my @values = @_;
371              
372             # Start transaction
373             $self->txn(
374             sub {
375 3     3   49 while (@v_array = splice(@values, 0, $max - 1)) {
376              
377             # Delete undef values
378 28 50       91 @v_array = grep($_, @v_array) unless @_;
379              
380             # Add data unions
381 28         410 my $sub_sql = $sql . $union .
382             ((' UNION ' . $union) x ( scalar(@v_array) - 1 ));
383              
384             # Prepare and execute
385             my $rv_part = $self->prep_and_exec(
386             $sub_sql,
387 28         81 [ map { (@default, @$_); } @v_array ]
  6061         8361  
388             );
389              
390             # Rollback transaction
391 28 50       654 return -1 unless $rv_part;
392 28         368 $rv += $rv_part;
393             };
394              
395 3 50       44 }) or return;
396              
397             # Decrement autocommit
398 3 50       45 $self->_decr_commit if $rv;
399              
400             # Everything went fine
401 3         91 return $rv;
402             };
403             };
404              
405             # Unknown query
406 0         0 return;
407             };
408              
409              
410             # Update existing values in the database
411             sub update {
412 25     25 1 1022 my $self = shift;
413              
414 25         115 my $rv = $self->SUPER::update(@_);
415              
416             # Decrement autocommit
417 25 100       94 $self->_decr_commit if $rv;
418              
419 25         99 return $rv;
420             };
421              
422              
423             sub merge {
424 10     10 1 20 my $self = shift;
425              
426 10         50 my ($rv, $type) = $self->SUPER::merge(@_);
427              
428 10 50 100     56 if ($rv && $type eq 'insert' && ${$self->{autocommit}}) {
  4   66     17  
429 0         0 ${$self->{_autocounter}}--;
  0         0  
430             };
431              
432 10 50       69 return wantarray ? ($rv, $type) : $rv;
433             };
434              
435             # Attach database
436             sub attach {
437 6     6 1 3583 my ($self, $db_name, $file) = @_;
438              
439 6   100     34 $file //= '';
440              
441             # Attach file, memory or temporary database
442 6         46 my $rv = scalar $self->prep_and_exec("ATTACH '$file' AS ?", [$db_name]);
443              
444 6         32 $self->{attached}->{$db_name} = $file;
445              
446 6         28 return $rv;
447             };
448              
449              
450             # Detach database
451             sub detach {
452 4     4 1 11 my $self = shift;
453 4 50       13 return unless $_[0];
454              
455             # Detach all databases
456 4         11 foreach my $db_name (@_) {
457 5         17 delete $self->{attached}->{$db_name};
458 5 100       20 return unless $self->prep_and_exec('DETACH ?', [$db_name]);
459             };
460              
461 3         19 return 1;
462             };
463              
464              
465             # Wrapper for sqlite last_insert_row_id
466             sub last_insert_id {
467 14     14 1 88 shift->dbh->sqlite_last_insert_rowid;
468             };
469              
470              
471             # Create matchinfo function
472             sub matchinfo {
473 2     2 1 10847 my $self = shift;
474              
475             # Use no multibyte characters
476             # use bytes;
477              
478             # Format string
479 2 50 33     30 my $format = lc(shift) if $_[0] && $_[0] =~ /^[pcnalsx]+$/i;
480              
481             # Return anonymous subroutine
482             return sub {
483 3     3   4 my $column;
484 3 50       9 if (@_) {
485 3   50     9 $column = shift || 'content';
486              
487             # Format string
488 3 50 33     10 $format = lc(shift) if $_[0] && $_[0] =~ /^[pcnalsx]+$/i;
489             };
490              
491             # Sort format for leading 'pc' if needed
492 3 50       9 if ($format) {
493 3         6 for ($format) {
494              
495             # Sort alphabetically
496 3         27 $_ = join('', sort split('', $_));
497              
498             # Delete repeating characters
499 3         20 s/(.)\1+/$1/g;
500              
501             # Prepend 'pc' if necessary
502 3 50       13 if (/[xals]/) {
503 3         12 tr/pc//d; # Delete 'pc'
504 3         9 $_ = 'pc' . $format; # Prepend 'pc'
505             };
506             };
507             }
508              
509             # No format given
510             else {
511 0         0 $format = 'pcx';
512             };
513              
514             # Return anonymous subroutine
515             return sub {
516             return
517 3         17 'matchinfo(' . $column . ', "' . $format . '")',
518             \&_matchinfo_return,
519             $format;
520 3         19 };
521 2         28 };
522             };
523              
524              
525             # Treat matchinfo return
526             sub _matchinfo_return {
527 6     6   16 my ($blob, $format) = @_;
528              
529             # Get 32-bit blob chunks
530 6         39 my @matchinfo = unpack('l' . (length($blob) * 4), $blob);
531              
532             # Parse format character
533 6         10 my %match;
534 6         20 foreach (split '', $format) {
535              
536             # Characters: p, c, n
537 22 100 100     117 if ($_ eq 'p' or $_ eq 'c' or $_ eq 'n') {
    100 100        
    50 66        
      100        
538 14         30 $match{$_} = shift @matchinfo;
539             }
540              
541             # Characters: a, l, s
542             elsif ($_ eq 'a' or $_ eq 'l' or $_ eq 's') {
543 4         14 $match{$_} = [ splice(@matchinfo, 0, $match{c}) ];
544             }
545              
546             # Characters: x
547             elsif ($_ eq 'x') {
548 4         6 my @match;
549 4         12 for (1 .. ($match{p} * $match{c})) {
550 12         30 push(@match, [ splice(@matchinfo, 0, 3) ]);
551             };
552              
553 4         11 $match{$_} = \@match;
554             }
555              
556             # Unknown character
557             else {
558 0         0 shift @matchinfo;
559             };
560             };
561 6         26 return \%match;
562             };
563              
564              
565             # Create offsets function
566             sub offsets {
567 3     3 1 2146 my $self = shift;
568 3         6 my $field = shift;
569              
570             # Use no multibyte characters
571             # use bytes;
572              
573             # subroutine
574             return sub {
575 3     3   9 my $column = shift;
576             'offsets(' . ($column // $field // 'content') . ')',
577             sub {
578 4         10 my $blob = shift;
579 4         7 my @offset;
580 4         43 my @array = split(/\s/, $blob);
581 4         14 while (@array) {
582 7         28 push(@offset, [ splice(@array, 0, 4) ]);
583             };
584 4         17 return \@offset;
585             }
586 3   33     50 };
  3   50     41  
587             };
588              
589              
590             # Create snippet function
591             sub snippet {
592 5     5 1 17 my $self = shift;
593              
594             # Snippet parameters
595 5         9 my @snippet;
596              
597             # Parameters are given
598 5 100       19 if ($_[0]) {
599 3         16 my %snippet = ();
600              
601             # Parameters are given as a hash
602 3 50       31 if ($_[0] =~ $arguments) {
603 3         18 %snippet = @_;
604 3         11 foreach (keys %snippet) {
605 8 50       39 carp "Unknown snippet parameter '$_'" unless $_ =~ $arguments;
606             };
607             }
608              
609             # Parameters are given as an array
610             else {
611 0         0 @snippet{@arguments} = @_;
612             };
613              
614             # Trim parameter array and fill gaps with defaults
615 3         9 my ($s, $i) = (0, 0);
616 3         8 foreach (reverse @arguments) {
617 15 100       34 $s = 1 if defined $snippet{$_};
618 15 100 66     62 unshift(@snippet, $snippet{$_} // $default[$i]) if $s;
619 15         27 $i++;
620             };
621             };
622              
623             # Return anonymous subroutine
624 5         9 my $sub = 'sub {
625             my $column = $_[0] ? shift : \'content\';
626             my $str = "snippet(" . $column ';
627              
628 5 100       12 if ($snippet[0]) {
629 3         8 $sub .= ' . ", ' . join(',', map { '\"' . $_ . '\"' } @snippet) . '"';
  12         39  
630             };
631              
632 5         12 $sub .= " . \")\";\n};";
633              
634 5         521 return eval( $sub );
635             };
636              
637              
638             # New table object
639             sub table {
640 26     26 1 15503 my $self = shift;
641              
642             # Get object from superclass
643 26         99 my $table = $self->SUPER::table(@_);
644              
645             # Add autocommit parameters
646 26         54 foreach (qw/autocommit _autocounter
647             foreign_keys/) {
648 78         150 $table->{$_} = $self->{$_};
649             };
650              
651             # Return blessed object
652 26         65 return $table;
653             };
654              
655              
656             # Set foreign_key pragma
657             sub foreign_keys {
658 0     0 1 0 my $self = shift;
659              
660             # Get pragma
661 0 0 0     0 unless (defined $_[0]) {
    0          
662 0         0 return $self->{foreign_keys};
663             }
664              
665             # Turn foreign keys on
666 0 0       0 elsif ($_[0] && !$self->{foreign_keys}) {
667 0         0 $self->dbh->do('PRAGMA foreign_keys = ON');
668 0         0 return ($self->{foreign_keys} = 1);
669             }
670              
671             # Turn foreign keys off
672             elsif (!$_[0] && $self->{foreign_keys}) {
673             $self->dbh->do('PRAGMA foreign_keys = OFF');
674             return ($self->{foreign_keys} = 0);
675             };
676              
677 0         0 return;
678             };
679              
680              
681             # Set autocommit
682             sub autocommit {
683 14     14 1 479 my $self = shift;
684              
685             # Get autocommit
686 14 100       35 unless (defined $_[0]) {
687 5   50     7 return ${$self->{autocommit}} || 0;
688             }
689              
690             # Set autocommit
691             else {
692 9         11 my $num = shift;
693 9         23 my $dbh = $self->dbh;
694              
695             # Is a number
696 9 100 66     80 if ($num && $num =~ m/^\d+/o) {
    50          
697 5 50       12 if ($num > 1) {
698 5         25 $dbh->{AutoCommit} = 0;
699 5         11 ${$self->{autocommit}} =
700 5         10 ${$self->{_autocounter}} = $num;
  5         23  
701 5         23 return 1;
702             }
703              
704             else {
705 0         0 $dbh->{AutoCommit} = 1;
706 0         0 ${$self->{_autocounter}} =
707 0         0 ${$self->{autocommit}} = 0;
  0         0  
708 0         0 return 1;
709             };
710             }
711              
712             # Is null
713             elsif (!$num) {
714 4         17 ${$self->{autocommit}} = 0;
  4         7  
715 4 50       17 if (${$self->{_autocounter}}) {
  4         10  
716 4         9 ${$self->{_autocounter}} = 0;
  4         5  
717 4         54 $dbh->commit;
718             };
719 4 50       10 $dbh->{AutoCommit} = 1 unless ${$self->{in_txn}};
  4         30  
720 4         25 return 1;
721             }
722              
723             # Failure
724             else {
725 0         0 return;
726             };
727             };
728             };
729              
730              
731             # Decrement commit counter
732             sub _decr_commit {
733 955     955   1213 my $self = shift;
734              
735             # Autocounter is set
736 955 100       1035 if (${$self->{_autocounter}}) {
  955         2326  
737 66         69 my $auto = --${$self->{_autocounter}};
  66         123  
738              
739             # Commit is null
740 66 100       127 unless ($auto) {
741              
742 4 50       9 $self->dbh->commit unless ${$self->{in_txn}};
  4         16  
743 4         11 ${$self->{_autocounter}} = ${$self->{autocommit}};
  4         8  
  4         8  
744             };
745             };
746             };
747              
748              
749             1;
750              
751              
752             __END__