t/lib/DBIC/Test.pm

   1 # $Id$
   2 package DBIC::Test;
   3 use strict;
   4 use warnings;
   5
   6 BEGIN {
   7     # little trick by Ovid to pretend to subclass+exporter Test::More
   8     use base qw/Test::Builder::Module Class::Accessor::Grouped/;
   9     use Test::More;
  10     use File::Spec::Functions qw/catfile catdir/;
  11
  12     @DBIC::Test::EXPORT = @Test::More::EXPORT;
  13
  14     __PACKAGE__->mk_group_accessors('inherited', qw/db_dir db_file/);
  15 };
  16
  17 __PACKAGE__->db_dir(catdir('t', 'var'));
  18 __PACKAGE__->db_file('test.db');
  19
  20 ## cribbed and modified from DBICTest in DBIx::Class tests
  21 sub init_schema {
  22     my ($self, %args) = @_;
  23     my $db_dir  = $args{'db_dir'}  || $self->db_dir;
  24     my $db_file = $args{'db_file'} || $self->db_file;
  25     my $namespace = $args{'namespace'} || 'DBIC::TestSchema';
  26     my $db = catfile($db_dir, $db_file);
  27
  28     eval 'use DBD::SQLite';
  29     if ($@) {
  30        BAIL_OUT('DBD::SQLite not installed');
  31
  32         return;
  33     };
  34
  35     eval 'use DBIC::Test::Schema';
  36     if ($@) {
  37         BAIL_OUT("Could not load DBIC::Test::Schema: $@");
  38
  39         return;
  40     };
  41
  42     unlink($db) if -e $db;
  43     unlink($db . '-journal') if -e $db . '-journal';
  44     mkdir($db_dir) unless -d $db_dir;
  45
  46     my $dsn = 'dbi:SQLite:' . $db;
  47     my $schema = DBIC::Test::Schema->compose_namespace($namespace)->connect($dsn);
  48     $schema->storage->on_connect_do([
  49         'PRAGMA synchronous = OFF',
  50         'PRAGMA temp_store = MEMORY'
  51     ]);
  52
  53     __PACKAGE__->deploy_schema($schema, %args);
  54     __PACKAGE__->populate_schema($schema, %args) unless $args{'no_populate'};
  55
  56     return $schema;
  57 };
  58
  59 sub deploy_schema {
  60     my ($self, $schema, %options) = @_;
  61     my $eval = $options{'eval_deploy'};
  62
  63     eval 'use SQL::Translator';
  64     if (!$@ && !$options{'no_deploy'}) {
  65         eval {
  66             $schema->deploy();
  67         };
  68         if ($@ && !$eval) {
  69             die $@;
  70         };
  71     } else {
  72         open IN, catfile('t', 'sql', 'test.sqlite.sql');
  73         my $sql;
  74         { local $/ = undef; $sql = <IN>; }
  75         close IN;
  76         eval {
  77             ($schema->storage->dbh->do($_) || print "Error on SQL: $_\n") for split(/;\n/, $sql);
  78         };
  79         if ($@ && !$eval) {
  80             die $@;
  81         };
  82     };
  83 };
  84
  85 sub clear_schema {
  86     my ($self, $schema, %options) = @_;
  87
  88     foreach my $source ($schema->sources) {
  89         $schema->resultset($source)->delete_all;
  90     };
  91 };
  92
  93 sub populate_schema {
  94     my ($self, $schema, %options) = @_;
  95
  96     if ($options{'clear'}) {
  97         $self->clear_schema($schema, %options);
  98     };
  99 };
 100
 101 sub is_uuid {
 102     my $value = defined $_[0] ? shift : '';
 103
 104     return ($value =~ m/  ^[0-9a-f]{8}-
 105                            [0-9a-f]{4}-
 106                            [0-9a-f]{4}-
 107                            [0-9a-f]{4}-
 108                            [0-9a-f]{12}$
 109                       /ix);
 110 };
 111
 112 1;