Test::DBIC - Facilitates Automated Testing for DBIx::Class

  BEGIN {
      use Test::DBIC;

      eval 'require DBD::SQLite';
      if ($@) {
          plan skip_all => 'DBD::SQLite not installed';
      } else {
          plan tests => 1;  # change this to the correct number of tests
      }
  };

  my $schema = Test::DBIC->init_schema(
      sample_data_file => 't/var/sample_data.txt',
  );

package Test::DBIC;

use strict;
use warnings;

our $VERSION = '0.01003';

BEGIN {
    # little trick by Ovid to pretend to subclass+exporter Test::More
    use base qw/Test::Builder::Module Class::Accessor::Grouped/;
    use Test::More;
    use File::Spec::Functions qw/catfile catdir/;

    @Test::DBIC::EXPORT = @Test::More::EXPORT;

    __PACKAGE__->mk_group_accessors('inherited', qw/db_dir db_file/);
};

__PACKAGE__->db_dir(catdir('t', 'var'));

__PACKAGE__->db_file('test.db');

## cribbed and modified from DBICTest in DBIx::Class tests
sub init_schema {
    my ($self, %args) = @_;
    my $db_dir  = $args{'db_dir'}  || $self->db_dir;
    my $db_file = $args{'db_file'} || $self->db_file;
    my $namespace = $args{'namespace'} || 'DBIC::TestSchema';
    my $schema_class = $args{'schema_class'} || 'Test::DBIC::Schema';
    my $db = catfile($db_dir, $db_file);

    eval 'use DBD::SQLite';
    if ($@) {
       BAIL_OUT('DBD::SQLite not installed');

        return;
    };

    eval "use $schema_class";
    if ($@) {
        BAIL_OUT("Could not load $schema_class: $@");

        return;
    };

    if (opendir DIR, $db_dir) {
        my @files = grep { /^$db_file[-\.]/ } readdir DIR;
        closedir DIR;
        foreach my $file (@files) {
            if ($file =~ /^([-\@\w.]+)$/) {
                $file = $db_dir . '/' . $1; # remove taintedness
            }
            unlink($file) if -e $file;
        }
    }
    unlink($db) if -e $db;
    mkdir($db_dir) unless -d $db_dir;

    my $dsn = 'dbi:SQLite:' . $db;
    my $schema = $schema_class->compose_namespace($namespace)->connect($dsn);
    $schema->storage->on_connect_do([
        'PRAGMA synchronous = OFF',
        'PRAGMA temp_store = MEMORY'
    ]);

    unless ($args{'no_deploy'}) {
        __PACKAGE__->deploy_schema($schema, %args);
        __PACKAGE__->populate_schema($schema, %args) unless $args{'no_populate'};
    }

    return $schema;
};

sub deploy_schema {
    my ($self, $schema, %options) = @_;
    my $eval = $options{'eval_deploy'};

    eval 'use SQL::Translator';
    if (!$@ && ($options{'sqlt_deploy'} or $ENV{"DBICTEST_SQLT_DEPLOY"})) {
        if (my $existing_namespace = $options{'existing_namespace'} || '') {
            foreach my $tableclass ($self->tableclasses_to_load($schema, %options)) {
                $schema->load_classes({
                    $existing_namespace => [$tableclass],
                });
            }
            my @tables = ();
            foreach my $source ($schema->sources) {
                push @tables, $schema->source($source)->from;
            };
            $self->attach_dbfile($schema, \%options, \@tables);
        }
        eval {
            #diag join("\n", $schema->storage->deployment_statements($schema), '');
            $schema->deploy();
        };
        if ($@ && !$eval) {
            die $@;
        };
    } else {
        my $sql = slurp(catfile('t', 'lib', 'sqlite.sql'));
        if ($sql) {
            my (@tables) = $sql =~ m/create\s+table\s+(.+?)(?:\s*\()/gi;
            $self->attach_dbfile($schema, \%options, \@tables);
            eval {
                ($schema->storage->dbh->do($_) || print "Error on SQL: $_\n") for split(/;\n/, $sql);
            };
            if ($@ && !$eval) {
                die $@;
            };
        } else {
            diag "cannot initialize database\n";
        }
    };
};

sub attach_dbfile {
    my ($self, $schema, $options, $tables) = @_;
    my %seen = ();
    foreach my $table (@$tables) {
        if (index($table, '.') > 0) {
            my ($prefix) = $table =~ m/^(.+?)\./;
            # diag "$table is under schema $prefix\n";
            next if $seen{$prefix}++;
            my $dbh = $schema->storage->dbh;
            if ($dbh->{Driver}{Name} eq 'SQLite') {
                my $db_dir  = $options->{'db_dir'}  || $self->db_dir;
                my $db_file = $options->{'db_file'} || $self->db_file;
                my $db = catfile($db_dir, $db_file);
                #diag "attaching file $db.$prefix as schema $prefix\n";
                $dbh->do("attach '$db.$prefix' as $prefix");
            }
        }
    }
}

sub slurp {
    my $file = shift;
    my $content;
    if (open IN, $file) {;
        { local $/ = undef; $content = <IN>; }
        close IN;
    } else {
        diag "failed to read $file\n";
    }
    return $content;
}

sub clear_schema {
    my ($self, $schema, %options) = @_;

    foreach my $source ($schema->sources) {
        $schema->resultset($source)->delete_all;
    };
};

sub populate_schema {
    my ($self, $schema, %options) = @_;
    
    if ($options{'clear'}) {
        $self->clear_schema($schema, %options);
    };

    if ($options{'sample_data_file'}) {
        $self->populate_from_file($schema, %options);
    }
    if ($options{'sample_data'}) {
        $self->populate_from_array($schema, %options);
    }
};

sub tableclasses_to_load {
    my ($self, $schema, %options) = @_;
    my @classes = ();
    if ($options{'sample_data_file'}) {
        push @classes, $self->tableclasses_from_file($schema, %options);
    }
    if ($options{'sample_data'}) {
        push @classes, $self->tableclasses_from_array($schema, %options);
    }
    return @classes;
}

sub populate_from_file {
    my ($self, $schema, %options) = @_;
    # expects a file in the format
    # tableclass_name
    # column1, column2, column3
    # data1, data2, data3
    # data1, data2, data3
    # ---
    # tableclass_name
    # ...
    use IO::File;
    my $fh = IO::File->new($options{'sample_data_file'}) || diag "failed to read sample data file: $options{'sample_data_file'}: $!\n";
    return unless $fh;
    my ($tableclass, @columns, @data);
    while (my $line = $fh->getline) {
        chomp($line);
        if ($line eq '---') {
            if ($tableclass and @columns and @data) {
                #diag "populating $tableclass with " . scalar(@data) . " rows\n";
                $self->populate_table($schema, \%options, $tableclass, \@columns, \@data);
            }
            undef $tableclass;
            @columns = ();
            @data = ();
        } elsif (!defined($tableclass)) {
            $tableclass = $line;
            #diag "preparing to populate $tableclass\n";
        } elsif (!@columns) {
            @columns = split(/,\s*/, $line);
            #diag "$tableclass has columns: " . join(', ', @columns) . "\n";
        } else {
            my @row = split(/,\s*/, $line);
            push @data, \@row;
        }
    }
    if ($tableclass and @columns and @data) {
        #diag "populating $tableclass with " . scalar(@data) . " rows\n";
        $self->populate_table($schema, \%options, $tableclass, \@columns, \@data);
    }
    undef $tableclass;
    @columns = ();
    @data = ();
}

sub tableclasses_from_file {
    my ($self, $schema, %options) = @_;
    # expects a file in the format
    # tableclass_name
    # column1, column2, column3
    # data1, data2, data3
    # data1, data2, data3
    # ---
    # tableclass_name
    # ...
    use IO::File;
    my $fh = IO::File->new($options{'sample_data_file'}) || diag "failed to read sample data file: $options{'sample_data_file'}: $!\n";
    return unless $fh;
    my @classes = ();
    my $tableclass;
    while (my $line = $fh->getline) {
        chomp($line);
        if ($line eq '---') {
            undef $tableclass;
        } elsif (!defined($tableclass)) {
            $tableclass = $line;
            push @classes, $tableclass;
            #diag "preparing to populate $tableclass\n";
        }
    }
    return @classes;
}

sub populate_from_array {
    my ($self, $schema, %options) = @_;
    return unless (ref($options{'sample_data'}) eq 'ARRAY');
    my $c = 0;
    while ($c < @{$options{'sample_data'}}) {
        my $tableclass = $options{'sample_data'}[$c++];
        my $data = $options{'sample_data'}[$c++];
        my $columns = shift(@$data);
        $self->populate_table($schema, \%options, $tableclass, $columns, $data);
        unshift(@$data, $columns); # put things back how we found them
    }
}

sub tableclasses_from_array {
    my ($self, $schema, %options) = @_;
    return unless (ref($options{'sample_data'}) eq 'ARRAY');
    my @classes = ();
    my $c = 0;
    while ($c < @{$options{'sample_data'}}) {
        push @classes, $options{'sample_data'}[$c++];
        $c++; # ignore datasets
    }
    return @classes;
}

sub populate_table {
    my ($self, $schema, $options, $tableclass, $columns, $data) = @_;
    if (my $existing_namespace = $options->{'existing_namespace'} || '') {
        $schema->load_classes({
            $existing_namespace => [$tableclass],
        });
    }
    $schema->populate($tableclass, [
        $columns,
        @$data,
    ]);
}

1;
__END__