1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
# $Id$
package DBIC::Test;
use strict;
use warnings;
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/;
@DBIC::Test::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 $db = catfile($db_dir, $db_file);
eval 'use DBD::SQLite';
if ($@) {
BAIL_OUT('DBD::SQLite not installed');
return;
};
eval 'use DBIC::Test::Schema';
if ($@) {
BAIL_OUT("Could not load DBIC::Test::Schema: $@");
return;
};
unlink($db) if -e $db;
unlink($db . '-journal') if -e $db . '-journal';
mkdir($db_dir) unless -d $db_dir;
my $dsn = 'dbi:SQLite:' . $db;
my $schema = DBIC::Test::Schema->compose_namespace($namespace)->connect($dsn);
$schema->storage->on_connect_do([
'PRAGMA synchronous = OFF',
'PRAGMA temp_store = MEMORY'
]);
__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'};
open IN, catfile('t', 'sql', 'test.sqlite.sql');
my $sql;
{ local $/ = undef; $sql = <IN>; }
close IN;
eval {
($schema->storage->dbh->do($_) || print "Error on SQL: $_\n") for split(/;\n/, $sql);
};
if ($@ && !$eval) {
die $@;
};
};
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);
};
};
sub is_uuid {
my $value = defined $_[0] ? shift : '';
return ($value =~ m/ ^[0-9a-f]{8}-
[0-9a-f]{4}-
[0-9a-f]{4}-
[0-9a-f]{4}-
[0-9a-f]{12}$
/ix);
};
1;
|
