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     open IN, catfile('t', 'sql', 'test.sqlite.sql');
  64     my $sql;
  65     { local $/ = undef; $sql = <IN>; }
  66     close IN;
  67     eval {
  68         ($schema->storage->dbh->do($_) || print "Error on SQL: $_\n") for split(/;\n/, $sql);
  69     };
  70     if ($@ && !$eval) {
  71         die $@;
  72     };
  73 };
  74
  75 sub clear_schema {
  76     my ($self, $schema, %options) = @_;
  77
  78     foreach my $source ($schema->sources) {
  79         $schema->resultset($source)->delete_all;
  80     };
  81 };
  82
  83 sub populate_schema {
  84     my ($self, $schema, %options) = @_;
  85
  86     if ($options{'clear'}) {
  87         $self->clear_schema($schema, %options);
  88     };
  89 };
  90
  91 sub is_uuid {
  92     my $value = defined $_[0] ? shift : '';
  93
  94     return ($value =~ m/  ^[0-9a-f]{8}-
  95                            [0-9a-f]{4}-
  96                            [0-9a-f]{4}-
  97                            [0-9a-f]{4}-
  98                            [0-9a-f]{12}$
  99                       /ix);
 100 };
 101
 102 1;