File Coverage

blib/lib/DBIx/ThinSQL/SQLite.pm

Criterion	Covered	Total	%
statement	82	82	100.0
branch	17	22	77.2
condition	9	17	52.9
subroutine	19	19	100.0
pod	3	3	100.0
total	130	143	90.9

package DBIx::ThinSQL::SQLite;
use 5.008005;
use strict;
use warnings;
use Log::Any qw/$log/;
use Exporter::Tidy all =>
  [qw/create_sqlite_sequence create_functions create_methods/];

our $VERSION = '0.0.16';

my %sqlite_functions = (
    debug => sub {
        my $dbh = shift;

        $dbh->sqlite_create_function(
            'debug', -1,
            sub {
                if ( @_ && defined $_[0] && $_[0] =~ m/^\s*(select|pragma)/i ) {
                    $dbh->log_debug(@_);
                }
                else {
                    $log->debug( join( ' ', map { $_ // 'NULL' } @_ ) );
                }
            }
        );
    },
    warn => sub {
        my $dbh = shift;

        $dbh->sqlite_create_function(
            'warn', -1,
            sub {
                if ( @_ && defined $_[0] && $_[0] =~ m/^\s*(select|pragma)/i ) {
                    $dbh->log_warn(@_);
                }
                else {
                    warn join( ' ', map { $_ // 'NULL' } @_ );
                }
            }
        );
    },
    create_sequence => sub {
        my $dbh = shift;
        $dbh->sqlite_create_function( 'create_sequence', 1,
            sub { _create_sequence( $dbh, @_ ) } );
    },
    currval => sub {
        my $dbh = shift;
        $dbh->sqlite_create_function( 'currval', 1,
            sub { _currval( $dbh, @_ ) } );
    },
    nextval => sub {
        my $dbh = shift;
        $dbh->sqlite_create_function( 'nextval', 1,
            sub { _nextval( $dbh, @_ ) } );
    },
    sha1 => sub {
        require Digest::SHA;
        my $dbh = shift;
        $dbh->sqlite_create_function(
            'sha1', -1,
            sub {
                Digest::SHA::sha1(
                    map { utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_ }
                    grep { defined $_ } @_
                );
            }
        );
    },
    sha1_hex => sub {
        require Digest::SHA;
        my $dbh = shift;
        $dbh->sqlite_create_function(
            'sha1_hex',
            -1,
            sub {
                Digest::SHA::sha1_hex(
                    map { utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_ }
                    grep { defined $_ } @_
                );
            }
        );
    },
    sha1_base64 => sub {
        require Digest::SHA;
        my $dbh = shift;
        $dbh->sqlite_create_function(
            'sha1_base64',
            -1,
            sub {
                Digest::SHA::sha1_base64(
                    map { utf8::is_utf8($_) ? Encode::encode_utf8($_) : $_ }
                    grep { defined $_ } @_
                );
            }
        );
    },
    agg_sha1 => sub {
        require Digest::SHA;
        my $dbh = shift;
        $dbh->sqlite_create_aggregate( 'agg_sha1', 2,
            'DBIx::ThinSQL::SQLite::agg_sha1' );
    },
    agg_sha1_hex => sub {
        require Digest::SHA;
        my $dbh = shift;
        $dbh->sqlite_create_aggregate( 'agg_sha1_hex', 2,
            'DBIx::ThinSQL::SQLite::agg_sha1_hex' );
    },
    agg_sha1_base64 => sub {
        require Digest::SHA;
        my $dbh = shift;
        $dbh->sqlite_create_aggregate( 'agg_sha1_base64', 2,
            'DBIx::ThinSQL::SQLite::agg_sha1_base64' );
    },
);

sub _croak { require Carp; goto &Carp::croak }

sub create_sqlite_sequence {
    my $dbh = shift;

    local $dbh->{RaiseError} = 1;
    local $dbh->{PrintError} = 0;

    my $temp = '_temp' . join( '', map { int( rand($_) ) } 1000 .. 1005 );
    $dbh->do("CREATE TABLE $temp(x integer primary key autoincrement)");
    $dbh->do("DROP TABLE $temp");

    return;
}

sub _create_sequence {
    my $dbh = shift;
    my $name = shift || _croak('usage: create_sequence($name)');

    local $dbh->{RaiseError} = 1;
    local $dbh->{PrintError} = 0;

    # 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(
            'SELECT seq FROM sqlite_sequence WHERE name = ?',
            undef, $name
        )
    );
    $val && _croak("create_sequence: sequence already exists: $name");
    $log->debug("INSERT INTO sqlite_sequence VALUES('$name',0)");
    $dbh->do( 'INSERT INTO sqlite_sequence(name,seq) VALUES(?,?+0)',
        undef, $name, 0 );
}

sub _currval {
    my $dbh = shift;
    my $name = shift || die 'usage: currval($name)';

    local $dbh->{RaiseError} = 1;
    local $dbh->{PrintError} = 0;

    my ($val) = (
        $dbh->selectrow_array(
            'SELECT seq FROM sqlite_sequence WHERE name = ?',
            undef, $name
        )
    );

    if ( defined $val ) {
        $log->debug( "currval('$name') -> " . $val );
        return $val;
    }

    _croak("currval: unknown sequence: $name");
}

sub _nextval {
    my $dbh = shift;
    my $name = shift || die 'usage: nextval($name)';

    local $dbh->{RaiseError} = 1;
    local $dbh->{PrintError} = 0;
    my $val;

    my $i = 0;
    while (1) {
        _croak 'could not obtain nextval' if $i++ > 10;

        my ($current) = (
            $dbh->selectrow_array(
                'SELECT seq FROM sqlite_sequence WHERE name = ?', undef,
                $name
            )
        );
        _croak("nextval: unknown sequence: $name") unless defined $current;

        next
          unless $dbh->do(
            'UPDATE sqlite_sequence SET seq = ?+0 '
              . 'WHERE name = ? AND seq = ?+0',
            undef, $current + 1, $name, $current
          );

        $log->debug( "nextval('$name') -> " . ( $current + 1 ) );

        return $current + 1;
    }
}

sub create_functions {
    _croak('usage: create_functions($dbh,@functions)') unless @_ >= 2;

    my $dbh = shift;
    _croak('handle has no sqlite_create_function!')
      unless eval { $dbh->can('sqlite_create_function') };

    foreach my $name (@_) {
        my $subref = $sqlite_functions{$name};
        _croak( 'unknown function: ' . $name ) unless $subref;
        $subref->($dbh);
    }
}

my %thinsql_methods = (
    create_sqlite_sequence => \&_create_sqlite_sequence,
    create_sequence        => \&_create_sequence,
    currval                => \&_currval,
    nextval                => \&_nextval,
);

sub create_methods {
    _croak('usage: create_methods(@methods)') unless @_ >= 1;

    foreach my $name (@_) {
        my $subref = $thinsql_methods{$name};
        _croak( 'unknown method: ' . $name ) unless $subref;

        no strict 'refs';
        *{ 'DBIx::ThinSQL::db::' . $name } = $subref;
    }
}

package DBIx::ThinSQL::SQLite::agg_sha1;

sub new {
    my $class = shift;
    return bless [], $class;
}

sub step {
    my $self = shift;
    push( @$self,
        utf8::is_utf8( $_[0] // '' )
        ? [ Encode::encode_utf8( $_[0] // '' ), $_[1] // '' ]
        : [ $_[0] // '', $_[1] // '' ] );
}

sub _sort {
    return map { $_->[0] } sort { $a->[1] cmp $b->[1] } @{ $_[0] };
}

sub finalize {
    return Digest::SHA::sha1( $_[0]->_sort );
}

package DBIx::ThinSQL::SQLite::agg_sha1_hex;
our @ISA = ('DBIx::ThinSQL::SQLite::agg_sha1');

sub finalize {
    return Digest::SHA::sha1_hex( $_[0]->_sort );
}

package DBIx::ThinSQL::SQLite::agg_sha1_base64;
our @ISA = ('DBIx::ThinSQL::SQLite::agg_sha1');

sub finalize {
    return Digest::SHA::sha1_base64( $_[0]->_sort );
}

1;
__END__