File Coverage

blib/lib/Test/FixtureBuilder.pm

Criterion	Covered	Total	%
statement	86	90	95.5
branch	14	28	50.0
condition	3	12	25.0
subroutine	16	17	94.1
pod	5	6	83.3
total	124	153	81.0

package Test::FixtureBuilder;
use strict;
use warnings;

our $VERSION = '0.001';

use Exporter::Declare;

use Scalar::Util qw/blessed/;
use Carp qw/croak confess/;

sub after_import {
    my $class = shift;
    my ($importer, $specs) = @_;
    $importer->FIXTURE_BUILDER_META->{class} = $class;
}

gen_default_export FIXTURE_BUILDER_META => sub {
    my $meta = { class => undef };
    return sub { $meta };
};

default_export fixture_db => sub {
    my $caller = caller;
    my ($name, $code) = @_;

    croak "'$caller' does not have metadata!"
        unless $caller->can('FIXTURE_BUILDER_META');

    my $meta = $caller->FIXTURE_BUILDER_META;

    croak "Cannot set db to '$name', already set to '$meta->{db}'"
        if exists $meta->{db};
    $meta->{db} = $name;

    $meta->{builder} = $meta->{class}->new(%$meta);

    my $success = eval { $code->($meta->{builder}); 1 };
    my $error = $@;

    delete $meta->{$_} for qw/db dbh builder/;

    die $error || "Unknown Error"
        unless $success;

    return $name;
};

default_export fixture_table => sub {
    my $caller = caller;
    my ($name, $code) = @_;

    croak "'$caller' does not have metadata!"
        unless $caller->can('FIXTURE_BUILDER_META');

    my $meta = $caller->FIXTURE_BUILDER_META;

    croak "Cannot set table to '$name', already set to '$meta->{table}'"
        if exists $meta->{table};
    $meta->{table} = $name;

    my $success = eval { $code->($meta->{builder}, $name); 1 };
    my $error = $@;

    delete $meta->{$_} for qw/table/;

    die $error || "Unknown Error"
        unless $success;

    return $name;
};

default_export fixture_row => sub {
    my $caller = caller;

    croak "'$caller' does not have metadata!"
        unless $caller->can('FIXTURE_BUILDER_META');

    my $meta = $caller->FIXTURE_BUILDER_META;

    my $row = @_ > 1 ? {@_} : $_[0];

    return $meta->{builder}->insert_row( $meta->{table} => $row );
};

sub name_to_handle {
    my $class = shift;
    my ($name) = @_;

    return $name if blessed $name;

    croak "I don't know how to convert '$name' to a database handle, override name_to_handle()";
}

sub new {
    my $class = shift;
    my %params = @_;

    my $self = bless {}, $class;

    for my $field ( keys %params ) {
        croak "'$field' is not a valid accessor for '$class'"
            unless $self->can($field);

        $self->$field($params{$field});
    }

    return $self;
}

sub db {
    my $self = shift;

    return $self->dbh
        unless @_;

    my ($name) = @_;

    my $dbh = $self->name_to_handle($name);
    croak "Could not get db handle for '$name'"
        unless $dbh;

    $self->dbh( $dbh );
}

for my $field (qw/dbh class/) {
    my $accessor = sub {
        my $self = shift;

        croak "Accessor '$field' called without instance!"
            unless blessed $self && $self->isa( __PACKAGE__ );

        ($self->{$field}) = @_ if @_;

        return $self->{$field};
    };
    no strict 'refs';
    *$field = $accessor;
}

sub insert_row {
    my $self = shift;
    my ($table, $row) = @_;

    my $dbh = $self->dbh || croak "No database handle set!";

    my $quoted_table = $dbh->quote_identifier(undef, undef, $table);
    my @vals = values %$row;
    my $cols = join ',' => map { $dbh->quote_identifier($_) } keys %$row;
    my $vals = join ',' => map { '?' } @vals;

    my $sth = $dbh->prepare("INSERT INTO $quoted_table ($cols) VALUES($vals)");
    $sth->execute(@vals);

    return eval { $dbh->last_insert_id } || 0;
}

sub insert_rows {
    my $self = shift;
    my ($table, @rows) = @_;

    $self->insert_row($table => $_) for @rows;
}

1;

__END__