File Coverage

blib/lib/DBIx/ThinSQL/SQLite.pm

Criterion	Covered	Total	%
statement	61	61	100.0
branch	17	22	77.2
condition	9	17	52.9
subroutine	19	19	100.0
pod	3	3	100.0
total	109	122	89.3

package DBIx::ThinSQL::SQLite;
use 5.010;
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.17';

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 }

# Legacy method
sub create_sqlite_sequence {
    return;
}

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

    $dbh->do( 'CREATE TABLE '
          . $name
          . '_sequence (seq INTEGER PRIMARY KEY AUTOINCREMENT);' )
      or _croak( $dbh->errstr );

    $dbh->do( 'INSERT INTO ' . $name . '_sequence(seq) VALUES(0)' )
      or _croak( $dbh->errstr );

    $dbh->do( 'DELETE FROM ' . $name . '_sequence' )
      or _croak( $dbh->errstr );
}

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

    my $ref = $dbh->selectrow_arrayref(
        'SELECT seq FROM sqlite_sequence WHERE name = ?',
        undef, $name . '_sequence' );

    _croak("currval: unknown sequence: $name") unless $ref;

    $log->debug( "currval('$name') -> " . $ref->[0] );
    return $ref->[0];
}

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

    $dbh->do( 'INSERT INTO ' . $name . '_sequence(seq) VALUES(NULL)' )
      or _croak( 'nextval: unknown sequence: ' . $name );

    $dbh->do( 'DELETE FROM ' . $name . '_sequence' );
    return $dbh->selectrow_arrayref('SELECT last_insert_rowid();')->[0];
}

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__