RT#22364 (ASH) hopefully fixed with updated prereq

[dbsrgits/DBIx-Class-UUIDColumns.git] / t / lib / DBIC / Test.pm

# $Id: Test.pm 3236 2007-05-05 16:24:35Z claco $\r
package DBIC::Test;\r
use strict;\r
use warnings;\r
\r
BEGIN {\r
    # little trick by Ovid to pretend to subclass+exporter Test::More\r
    use base qw/Test::Builder::Module Class::Accessor::Grouped/;\r
    use Test::More;\r
    use File::Spec::Functions qw/catfile catdir/;\r
\r
    @DBIC::Test::EXPORT = @Test::More::EXPORT;\r
\r
    __PACKAGE__->mk_group_accessors('inherited', qw/db_dir db_file/);\r
};\r
\r
__PACKAGE__->db_dir(catdir('t', 'var'));\r
__PACKAGE__->db_file('test.db');\r
\r
## cribbed and modified from DBICTest in DBIx::Class tests\r
sub init_schema {\r
    my ($self, %args) = @_;\r
    my $db_dir  = $args{'db_dir'}  || $self->db_dir;\r
    my $db_file = $args{'db_file'} || $self->db_file;\r
    my $namespace = $args{'namespace'} || 'DBIC::TestSchema';\r
    my $db = catfile($db_dir, $db_file);\r
\r
    eval 'use DBD::SQLite';\r
    if ($@) {\r
       BAIL_OUT('DBD::SQLite not installed');\r
\r
        return;\r
    };\r
\r
    eval 'use DBIC::Test::Schema';\r
    if ($@) {\r
        BAIL_OUT("Could not load DBIC::Test::Schema: $@");\r
\r
        return;\r
    };\r
\r
    unlink($db) if -e $db;\r
    unlink($db . '-journal') if -e $db . '-journal';\r
    mkdir($db_dir) unless -d $db_dir;\r
\r
    my $dsn = 'dbi:SQLite:' . $db;\r
    my $schema = DBIC::Test::Schema->compose_namespace($namespace)->connect($dsn);\r
    $schema->storage->on_connect_do([\r
        'PRAGMA synchronous = OFF',\r
        'PRAGMA temp_store = MEMORY'\r
    ]);\r
\r
    __PACKAGE__->deploy_schema($schema, %args);\r
    __PACKAGE__->populate_schema($schema, %args) unless $args{'no_populate'};\r
\r
    return $schema;\r
};\r
\r
sub deploy_schema {\r
    my ($self, $schema, %options) = @_;\r
    my $eval = $options{'eval_deploy'};\r
\r
    eval 'use SQL::Translator';\r
    if (!$@ && !$options{'no_deploy'}) {\r
        eval {\r
            $schema->deploy();\r
        };\r
        if ($@ && !$eval) {\r
            die $@;\r
        };\r
    } else {\r
        open IN, catfile('t', 'sql', 'test.sqlite.sql');\r
        my $sql;\r
        { local $/ = undef; $sql = <IN>; }\r
        close IN;\r
        eval {\r
            ($schema->storage->dbh->do($_) || print "Error on SQL: $_\n") for split(/;\n/, $sql);\r
        };\r
        if ($@ && !$eval) {\r
            die $@;\r
        };\r
    };\r
};\r
\r
sub clear_schema {\r
    my ($self, $schema, %options) = @_;\r
\r
    foreach my $source ($schema->sources) {\r
        $schema->resultset($source)->delete_all;\r
    };\r
};\r
\r
sub populate_schema {\r
    my ($self, $schema, %options) = @_;\r
    \r
    if ($options{'clear'}) {\r
        $self->clear_schema($schema, %options);\r
    };\r
};\r
\r
sub is_uuid {\r
    my $value = defined $_[0] ? shift : '';\r
\r
    return ($value =~ m/  ^[0-9a-f]{8}-\r
                           [0-9a-f]{4}-\r
                           [0-9a-f]{4}-\r
                           [0-9a-f]{4}-\r
                           [0-9a-f]{12}$\r
                      /ix);\r
};\r
\r
1;\r