package SQL::DBx::SQLite;
use strict;
use warnings;
use Moo::Role;
use Log::Any qw/$log/;
use Carp qw/croak carp confess/;
our $VERSION = '0.971.0';
sub sqlite_create_function_debug {
my $self = shift;
return unless $self->dbd eq 'SQLite';
my $dbh = $self->conn->dbh;
$dbh->sqlite_create_function(
'debug', -1,
sub {
if ( @_ && defined $_[0] && $_[0] =~ m/^select/i ) {
my $sql = shift;
my $sth = $dbh->prepare($sql);
$sth->execute(@_);
$log->debug(
$sql . "\n"
. join( "\n",
map { DBI::neat_list($_) }
@{ $sth->fetchall_arrayref } )
);
}
else {
$log->debug( map { defined $_ ? $_ : 'NULL' } @_ );
}
}
);
$log->debugf( 'SQL debug() function added by ' . __PACKAGE__ );
}
sub sqlite_create_function_sha1 {
my $self = shift;
return unless $self->dbd eq 'SQLite';
require Digest::SHA;
require Encode;
my $dbh = $self->conn->dbh;
$dbh->sqlite_create_function(
'sha1', -1,
sub {
Digest::SHA::sha1(
map { utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_ }
grep { defined $_ } @_
);
}
);
$dbh->sqlite_create_function(
'sha1_hex',
-1,
sub {
Digest::SHA::sha1_hex(
map { utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_ }
grep { defined $_ } @_
);
}
);
$dbh->sqlite_create_function(
'sha1_base64',
-1,
sub {
Digest::SHA::sha1_base64(
map { utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_ }
grep { defined $_ } @_
);
}
);
$dbh->sqlite_create_aggregate( 'agg_sha1', -1,
'SQL::DBx::SQLite::agg_sha1' );
$dbh->sqlite_create_aggregate( 'agg_sha1_hex', -1,
'SQL::DBx::SQLite::agg_sha1_hex' );
$dbh->sqlite_create_aggregate( 'agg_sha1_base64', -1,
'SQL::DBx::SQLite::agg_sha1_base64' );
$log->debugf( 'SQL sha1*() functions added by ' . __PACKAGE__ );
return;
}
my $seq_inc = q{UPDATE
sqlite_sequence
SET
seq = seq + 1
WHERE
name = ?};
my $seq_get = q{SELECT
seq
FROM
sqlite_sequence
WHERE
name = ?};
sub _nextval {
my $dbh = shift;
my $name = shift || die 'nextval($name)';
if ( $dbh->do( $seq_inc, undef, $name ) ) {
my $val = ( $dbh->selectrow_array( $seq_get, undef, $name ) )[0];
defined $val || croak "nextval: unknown sequence: $name";
return $val;
}
else {
croak "nextval1: unknown sequence: $name";
}
}
sub _currval {
my $dbh = shift;
my $name = shift || die 'currval($name)';
my $val = ( $dbh->selectrow_array( $seq_get, undef, $name ) )[0];
defined $val || croak "currval: unknown sequence: $name";
return $val;
}
sub sqlite_create_function_nextval {
my $self = shift;
return unless $self->dbd eq 'SQLite';
my $dbh = $self->conn->dbh;
$dbh->sqlite_create_function( 'nextval', 1, sub { _nextval( $dbh, $_[0] ) },
);
$log->debug( 'SQL nextval() function added by ' . __PACKAGE__ );
}
sub sqlite_create_function_currval {
my $self = shift;
return unless $self->dbd eq 'SQLite';
my $dbh = $self->conn->dbh;
$dbh->sqlite_create_function( 'currval', 1, sub { _currval( $dbh, $_[0] ) },
);
$log->debug( 'SQL currval() function added by ' . __PACKAGE__ );
}
sub sqlite_create_sequence {
my $self = shift;
my $name = shift || confess 'sqlite_create_sequence($name)';
return unless $self->dbd eq 'SQLite';
my $dbh = $self->conn->dbh;
# The sqlite_sequence table doesn't exist until an
# autoincrement table has been created.
# IF NOT EXISTS is used because table_info may not return any
# information if we are inside a transaction where the first
# sequence was created
if ( !$dbh->selectrow_array('PRAGMA table_info(sqlite_sequence)') ) {
$dbh->do( 'CREATE TABLE IF NOT EXISTS '
. 'Ekag4iiB(x integer primary key autoincrement)' );
$dbh->do('DROP TABLE IF EXISTS Ekag4iiB');
}
# the sqlite_sequence table doesn't have any constraints so it
# would be possible to insert the same sequence twice. Check if
# one already exists
my $val = ( $dbh->selectrow_array( $seq_get, undef, $name ) )[0];
$val && croak "create_sequence: sequence already exists: $name";
$dbh->do( 'INSERT INTO sqlite_sequence(name,seq) VALUES(?,?)',
undef, $name, 0 );
}
sub nextval {
my $self = shift;
my $name = shift;
return _nextval( $self->conn->dbh, $name );
}
sub currval {
my $self = shift;
my $name = shift;
return _currval( $self->conn->dbh, $name );
}
Moo::Role->apply_role_to_package( 'SQL::DB', __PACKAGE__ );
package SQL::DBx::SQLite::agg_sha1;
our @ISA = ('Digest::SHA');
sub step {
my $self = shift;
$self->add(
map { utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_ }
grep { defined $_ } @_
);
}
sub finalize {
$_[0]->digest;
}
package SQL::DBx::SQLite::agg_sha1_hex;
our @ISA = ('SQL::DBx::SQLite::agg_sha1');
sub finalize {
$_[0]->hexdigest;
}
package SQL::DBx::SQLite::agg_sha1_base64;
our @ISA = ('SQL::DBx::SQLite::agg_sha1');
sub finalize {
$_[0]->b64digest;
}
1;