Commit | Line | Data |
a19bdae0 |
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; |