File Coverage

blib/lib/SQL/DBx/SQLite.pm
Criterion Covered Total %
statement 79 98 80.6
branch 15 32 46.8
condition 5 13 38.4
subroutine 18 24 75.0
pod 7 7 100.0
total 124 174 71.2


line stmt bran cond sub pod time code
1             package SQL::DBx::SQLite;
2 2     2   2603 use strict;
  2         3  
  2         74  
3 2     2   8 use warnings;
  2         2  
  2         52  
4 2     2   997 use Moo::Role;
  2         18141  
  2         11  
5 2     2   538 use Log::Any qw/$log/;
  2         2  
  2         16  
6 2     2   120 use Carp qw/croak carp confess/;
  2         4  
  2         2385  
7              
8             our $VERSION = '0.971.2';
9              
10             sub sqlite_create_function_debug {
11 1     1 1 2 my $self = shift;
12              
13 1 50       13 return unless $self->dbd eq 'SQLite';
14              
15 1         11 my $dbh = $self->conn->dbh;
16              
17             $dbh->sqlite_create_function(
18             'debug', -1,
19             sub {
20 1 50 33 1   310 if ( @_ && defined $_[0] && $_[0] =~ m/^select/i ) {
      33        
21 0         0 my $sql = shift;
22 0         0 my $sth = $dbh->prepare($sql);
23 0         0 $sth->execute(@_);
24 0         0 $log->debug(
25             $sql . "\n"
26             . join( "\n",
27 0         0 map { DBI::neat_list($_) }
28 0         0 @{ $sth->fetchall_arrayref } )
29             );
30             }
31             else {
32 1 50       3 $log->debug( map { defined $_ ? $_ : 'NULL' } @_ );
  1         11  
33             }
34             }
35 1         131 );
36              
37 1         11 $log->debugf( 'SQL debug() function added by ' . __PACKAGE__ );
38             }
39              
40             sub sqlite_create_function_sha1 {
41 1     1 1 12 my $self = shift;
42              
43 1 50       8 return unless $self->dbd eq 'SQLite';
44              
45 1         8 require Digest::SHA;
46 1         9 require Encode;
47 1         7 my $dbh = $self->conn->dbh;
48              
49             $dbh->sqlite_create_function(
50             'sha1', -1,
51             sub {
52 3 50       5512 Digest::SHA::sha1(
53 3         13 map { utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_ }
54 3     3   117543 grep { defined $_ } @_
55             );
56             }
57 1         1021 );
58              
59             $dbh->sqlite_create_function(
60             'sha1_hex',
61             -1,
62             sub {
63 0 0       0 Digest::SHA::sha1_hex(
64 0         0 map { utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_ }
65 0     0   0 grep { defined $_ } @_
66             );
67             }
68 1         11 );
69              
70             $dbh->sqlite_create_function(
71             'sha1_base64',
72             -1,
73             sub {
74 0 0       0 Digest::SHA::sha1_base64(
75 0         0 map { utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_ }
76 0     0   0 grep { defined $_ } @_
77             );
78             }
79 1         8 );
80              
81 1         8 $dbh->sqlite_create_aggregate( 'agg_sha1', -1,
82             'SQL::DBx::SQLite::agg_sha1' );
83              
84 1         4 $dbh->sqlite_create_aggregate( 'agg_sha1_hex', -1,
85             'SQL::DBx::SQLite::agg_sha1_hex' );
86              
87 1         4 $dbh->sqlite_create_aggregate( 'agg_sha1_base64', -1,
88             'SQL::DBx::SQLite::agg_sha1_base64' );
89              
90 1         6 $log->debugf( 'SQL sha1*() functions added by ' . __PACKAGE__ );
91 1         4 return;
92             }
93              
94             my $seq_inc = q{UPDATE
95             sqlite_sequence
96             SET
97             seq = seq + 1
98             WHERE
99             name = ?};
100              
101             my $seq_get = q{SELECT
102             seq
103             FROM
104             sqlite_sequence
105             WHERE
106             name = ?};
107              
108             sub _nextval {
109 7     7   271 my $dbh = shift;
110 7   50     27 my $name = shift || die 'nextval($name)';
111              
112 7 100       75 if ( $dbh->do( $seq_inc, undef, $name ) ) {
113 5         38534 my $val = ( $dbh->selectrow_array( $seq_get, undef, $name ) )[0];
114 5 100       1366 defined $val || croak "nextval: unknown sequence: $name";
115 3         32 return $val;
116             }
117             else {
118 1         625 croak "nextval1: unknown sequence: $name";
119             }
120             }
121              
122             sub _currval {
123 2     2   55 my $dbh = shift;
124 2   50     8 my $name = shift || die 'currval($name)';
125              
126 2         14 my $val = ( $dbh->selectrow_array( $seq_get, undef, $name ) )[0];
127              
128 2 50       251 defined $val || croak "currval: unknown sequence: $name";
129 2         11 return $val;
130             }
131              
132             sub sqlite_create_function_nextval {
133 1     1 1 26 my $self = shift;
134              
135 1 50       9 return unless $self->dbd eq 'SQLite';
136              
137 1         9 my $dbh = $self->conn->dbh;
138 3     3   16342 $dbh->sqlite_create_function( 'nextval', 1, sub { _nextval( $dbh, $_[0] ) },
139 1         1561 );
140              
141 1         6 $log->debug( 'SQL nextval() function added by ' . __PACKAGE__ );
142             }
143              
144             sub sqlite_create_function_currval {
145 1     1 1 9 my $self = shift;
146              
147 1 50       10 return unless $self->dbd eq 'SQLite';
148              
149 1         9 my $dbh = $self->conn->dbh;
150 1     1   911 $dbh->sqlite_create_function( 'currval', 1, sub { _currval( $dbh, $_[0] ) },
151 1         319 );
152              
153 1         6 $log->debug( 'SQL currval() function added by ' . __PACKAGE__ );
154             }
155              
156             sub sqlite_create_sequence {
157 1     1 1 803 my $self = shift;
158 1   33     10 my $name = shift || confess 'sqlite_create_sequence($name)';
159              
160 1 50       9 return unless $self->dbd eq 'SQLite';
161              
162 1         8 my $dbh = $self->conn->dbh;
163              
164             # The sqlite_sequence table doesn't exist until an
165             # autoincrement table has been created.
166             # IF NOT EXISTS is used because table_info may not return any
167             # information if we are inside a transaction where the first
168             # sequence was created
169 1 50       85 if ( !$dbh->selectrow_array('PRAGMA table_info(sqlite_sequence)') ) {
170 1         77 $dbh->do( 'CREATE TABLE IF NOT EXISTS '
171             . 'Ekag4iiB(x integer primary key autoincrement)' );
172 1         54514 $dbh->do('DROP TABLE IF EXISTS Ekag4iiB');
173             }
174              
175             # the sqlite_sequence table doesn't have any constraints so it
176             # would be possible to insert the same sequence twice. Check if
177             # one already exists
178 1         8347 my $val = ( $dbh->selectrow_array( $seq_get, undef, $name ) )[0];
179 1 50       326 $val && croak "create_sequence: sequence already exists: $name";
180 1         8 $dbh->do( 'INSERT INTO sqlite_sequence(name,seq) VALUES(?,?)',
181             undef, $name, 0 );
182             }
183              
184             sub nextval {
185 4     4 1 2828 my $self = shift;
186 4         16 my $name = shift;
187              
188 4         25 return _nextval( $self->conn->dbh, $name );
189             }
190              
191             sub currval {
192 1     1 1 391 my $self = shift;
193 1         3 my $name = shift;
194              
195 1         5 return _currval( $self->conn->dbh, $name );
196             }
197              
198             Moo::Role->apply_role_to_package( 'SQL::DB', __PACKAGE__ );
199              
200             package SQL::DBx::SQLite::agg_sha1;
201             our @ISA = ('Digest::SHA');
202              
203             sub step {
204 0     0     my $self = shift;
205 0 0         $self->add(
206 0           map { utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_ }
207 0           grep { defined $_ } @_
208             );
209             }
210              
211             sub finalize {
212 0     0     $_[0]->digest;
213             }
214              
215             package SQL::DBx::SQLite::agg_sha1_hex;
216             our @ISA = ('SQL::DBx::SQLite::agg_sha1');
217              
218             sub finalize {
219 0     0     $_[0]->hexdigest;
220             }
221              
222             package SQL::DBx::SQLite::agg_sha1_base64;
223             our @ISA = ('SQL::DBx::SQLite::agg_sha1');
224              
225             sub finalize {
226 0     0     $_[0]->b64digest;
227             }
228              
229             1;