File Coverage

blib/lib/Test/SQLite.pm

Criterion	Covered	Total	%
statement	41	41	100.0
branch	20	24	83.3
condition	15	15	100.0
subroutine	10	10	100.0
pod	0	1	0.0
total	86	91	94.5

package Test::SQLite;
our $AUTHORITY = 'cpan:GENE';

# ABSTRACT: SQLite setup/teardown for tests

our $VERSION = '0.0410';

use strictures 2;
use DBI ();
use File::Copy qw(copy);
use File::Temp ();
use Moo;
use namespace::clean;


has database => (
    is        => 'ro',
    isa       => sub { die 'database does not exist' unless -e $_[0] },
    predicate => 'has_database',
);


has schema => (
    is        => 'ro',
    isa       => sub { die 'schema does not exist' unless -e $_[0] },
    predicate => 'has_schema',
);


has memory => (
    is        => 'ro',
    predicate => 'has_memory',
);


has db_attrs => (
    is      => 'ro',
    default => sub { return { RaiseError => 1, AutoCommit => 1 } },
);


has dsn => (
    is       => 'lazy',
    init_arg => undef,
);

sub _build_dsn {
    my ($self) = @_;
    return 'dbi:SQLite:dbname=' . ( $self->has_memory ? $self->_database : $self->_database->filename );
}


has dbh => (
    is       => 'lazy',
    init_arg => undef,
);

sub _build_dbh {
    my ($self) = @_;
    return DBI->connect( $self->dsn, '', '', $self->db_attrs );
}

has _database => (
    is       => 'lazy',
    init_arg => undef,
);

sub _build__database {
    my ($self) = @_;

    my $tempfile = $self->has_memory
        ? ':memory:'
        : File::Temp->new( unlink => 1, suffix => '.db', EXLOCK => 0 );

    if ( $self->has_database ) {
        copy( $self->database, $tempfile->filename )
            or die "Can't copy " . $self->database . ": $!";
    }
    elsif ( $self->has_schema ) {
        open my $schema, '<', $self->schema
            or die "Can't read " . $self->schema . ": $!";

        my $dbh = DBI->connect( "dbi:SQLite:dbname=$tempfile", '', '', { RaiseError => 1, AutoCommit => 0 } )
            or die "Can't connect to $tempfile: " . $DBI::errstr;

        my $sql = '';
        while ( my $line = readline($schema) ) {
            next if $line =~ /^\s*--/;
            next if $line =~ /^\s*$/;

            $sql .= $line;

            if ( $line =~ /;/ ) {
                $dbh->do($sql)
                    or die 'Error executing SQL for ' . $self->schema . ': ' . $dbh->errstr;

                $sql = '';
            }
        }

        $dbh->commit;

        $dbh->disconnect;
    }

    return $tempfile;
}


sub BUILD {
    my ( $self, $args ) = @_;
    die 'The schema, database and memory arguments may not be used together.'
        if ( $self->has_database and $self->has_schema )
            or ( $self->has_database and $self->has_memory )
            or ( $self->has_schema and $self->has_memory );
}

1;

__END__