File Coverage

blib/lib/Test/DBIC/DBDConnector.pm
Criterion Covered Total %
statement 53 53 100.0
branch 16 16 100.0
condition n/a
subroutine 8 8 100.0
pod 4 4 100.0
total 81 81 100.0


line stmt bran cond sub pod time code
1             use v5.10.1;
2 3     3   24571 use Moo::Role;
  3         12  
3 3     3   15  
  3         33  
  3         17  
4             our $VERSION = '0.01';
5              
6             with 'MooX::Params::CompiledValidators';
7             requires qw( MyDBD_connection_parameters MyDBD_check_wants_deploy );
8              
9             use Types::Standard qw( Maybe Any StrMatch CodeRef );
10 3     3   977  
  3         8  
  3         28  
11             has schema_class => (
12             is => 'ro',
13             isa => StrMatch [qr{^ [A-Za-z]\w+ (?:[:]{2}[A-Za-z]\w+)* $}x],
14             required => 1
15             );
16             has dbi_connect_info => (
17             is => 'ro',
18             isa => Maybe [Any],
19             required => 0
20             );
21             has pre_deploy_hook => (
22             is => 'ro',
23             isa => Maybe [CodeRef],
24             required => 0
25             );
26             has post_connect_hook => (
27             is => 'ro',
28             isa => Maybe [CodeRef],
29             required => 0
30             );
31              
32             use Test::Builder::Module;
33 3     3   2662  
  3         8  
  3         36  
34              
35 32     32 1 298 =head1 NAME
36              
37             Test::DBIC::DBDConnector - A L<Moo::Role> for implementing DBD-versions of a DBIC test-class
38              
39             =head1 SYNOPSIS
40              
41             package Test::DBIC::SQLite;
42             use Moo;
43             with 'Test::DBIC::DBDConnector';
44              
45             sub MyDBD_connection_parameters {
46             my $class = shift;
47             my ($db_name) = @_;
48              
49             $db_name //= ':memory:';
50             return [ "dbi:SQLite:dbname=$db_name" ];
51             }
52              
53             sub MyDBD_check_wants_deploy {
54             my $class = shift;
55             my ($connection_params) = @_;
56              
57             my ($db_name) = $connection_params->[0] =~ m{dbname=(.+)(?:;|$)};
58             my $wants_deploy = $db_name eq ':memory:'
59             ? 1
60             : ((not -f $db_name) ? 1 : 0);
61             return $wants_deploy;
62             }
63              
64             use namespace::autoclean 0.16;
65             1;
66              
67             package main;
68             use Test::More;
69             my $td = Test::DBIC::SQLite->new(schema_class => 'My::Schema');
70             my $schema = $td->connect_dbic_ok();
71             ...
72             $td->drop_dbic_ok();
73             done_testing();
74              
75             output:
76              
77             ok 1 - the schema ISA My::Schema
78             1..1
79              
80             =head1 DESCRIPTION
81              
82             This L<Moo::Role> is intended to be the base for this type of tester module. It
83             is part of the L<Test::DBIC::SQLite> distribution because I<SQLite> is also used
84             for testing L<DBIx::Class>, so the only way to test this role (that deploys a
85             L<DBIx::Class::Schema> subclass to a database), was to write a working
86             implementation of L<Test::DBIC::SQLite> although there already was one.
87              
88             =head2 Test::DBIC::YourDBD->connect_dbic_ok(%arguments)
89              
90             =head3 Arguments
91              
92             These are named parameters.
93              
94             =over
95              
96             =item B<schema_class> => C<$your_schema_class> (Required)
97              
98             This is the L<DBIx::Class::Schema> subclass for your ORM.
99              
100             =item B<dbi_connect_info> => C<$your_dbd_connect_info> (Optional)
101              
102             This argument is B<always> passed to the Driver-Specific-Implementation of C<<
103             MyDBD_connection_parameters() >> that should return an array of arguments that
104             will be passed to C<< DBIx::Class::Schema->connect() >>.
105              
106             =item B<pre_deploy_hook> => C<$pre_deploy_hook> (Optional)
107              
108             A CodeRef to execute I<before> C<< $schema->deploy >> is called.
109              
110             This CodeRef is called with an instantiated C<< $your_schema_class >> object as argument.
111              
112             =item B<post_connect_hook> => C<$post_connect_hook> (Optional)
113              
114             A coderef to execute I<after> C<< $schema->deploy >> is called, if at all.
115              
116             This coderef is called with an instantiated C<< $your_schema_class >> object as argument.
117              
118             =back
119              
120             =cut
121              
122             my $self = shift;
123             my $schema_class = $self->schema_class;
124             my $test_name = "the schema ISA $schema_class";
125 17     17 1 21134  
126 17         47 # Start doing the test-procedure
127 17         44 eval "require $schema_class";
128             if (my $error = $@) {
129             $self->builder->diag("Error loading '$schema_class': $error");
130 17         805 return $self->builder->ok(0, $test_name);
131 17 100       355076 }
132 1         4  
133 1         187 my $connect_info = $self->dbi_connect_info;
134             my $connection_parameters = $self->MyDBD_connection_parameters($connect_info);
135             my $wants_deploy = $self->MyDBD_check_wants_deploy($connection_parameters);
136 16         59  
137 16         318 my $schema = eval {
138 16         59 $schema_class->connect(@$connection_parameters);
139             };
140 16         30 if (my $error = $@) {
141 16         83 $self->builder->diag(
142             "Error connecting '$schema_class' to '$connection_parameters->[0]': $error"
143 16 100       149902 );
144 1         3 return $self->builder->ok(0, $test_name);
145             }
146              
147 1         154 if ($wants_deploy) {
148             my $pre_deploy_hook = $self->pre_deploy_hook;
149             if ($pre_deploy_hook) {
150 15 100       44 eval { $pre_deploy_hook->($schema) };
151 14         42 if (my $error = $@) {
152 14 100       33 $self->builder->diag("Error in pre-deploy-hook: $error");
153 2         5 return $self->builder->ok(0, $test_name);
  2         14  
154 2 100       30539 }
155 1         3 }
156 1         148  
157             eval { $schema->deploy };
158             if (my $error = $@) {
159             $self->builder->diag(
160 13         21 "Error deploying '$schema_class' to '$connection_parameters->[0]': $error"
  13         37  
161 13 100       1855324 );
162 1         3 return $self->builder->ok(0, $test_name);
163             }
164             }
165 1         152 my $post_connect_hook = $self->post_connect_hook;
166             if ($post_connect_hook) {
167             eval { $post_connect_hook->($schema) };
168 13         241 if (my $error = $@) {
169 13 100       45 $self->builder->diag("Error in post-connect-hook: $error");
170 10         23 return $self->builder->ok(0, $test_name);
  10         54  
171 10 100       1709795 }
172 1         3 }
173 1         151  
174             $self->builder->is_eq(ref($schema), $schema_class, $test_name);
175             return $schema;
176             }
177 12         81  
178 12         12147 around MyDBD_connection_parameters => sub {
179             my $connection_parameters = shift;
180             my $self = shift;
181              
182             my $parameters = $self->$connection_parameters(@_);
183             push @$parameters, undef while @$parameters < 3;
184              
185             my $options = $parameters->[3] // { };
186             $options->{ignore_version} //= 1;
187             $parameters->[3] = $options;
188             return $parameters;
189             };
190              
191             =begin proxy-method
192              
193             =head2 builder
194              
195             This method just returns C<< Test::Builder::Module->builder >>
196              
197             =end proxy-method
198              
199             =head2 Test::DBIC::YourDBD->MyDBD_connection_parameters()
200              
201             C<MyDBD_connection_parameters> is a class method that you must implement in your class.
202              
203             This role provides an C<around> for this method that makes sure the
204             C<ignore_version> option is added with a true value in the extra connection
205             options hash. One can check this in the connect method of the schema-class.
206              
207             =head3 Arguments
208              
209             It gets the second argument from C<dbic_connect_ok()>, this will be DBD specific.
210              
211             =head3 Response
212              
213             This method should return an ArrayRef with the list of arguments to pass to C<<
214             YourDBD::DBIC::Schema->connect() >>
215              
216             =cut
217              
218             =head2 Test::DBIC::YourDBD->MyDBD_check_wants_deploy()
219              
220             C<MyDBD_check_wants_deploy> is a class method that you must implement in your class.
221              
222             =head3 Arguments
223              
224             It gets the second argument from C<dbic_connect_ok()>, this will be DBD specific.
225              
226             =cut
227              
228             =begin override
229              
230             =head2 import_extra
231              
232             This method is called by L<Test::Builder::Module>.
233              
234             =end override
235              
236             =cut
237              
238             strict->import;
239             warnings->import;
240             Test::Builder::Module->import;
241             }
242 3     3 1 149  
243 3         30 =begin hide
244 3         15  
245             =head2 ValidationTemplates
246              
247             Current templates use L<Types::Standard>:
248              
249             =over
250              
251             =item schema_class => StrMatch[qr{^ [A-Za-z]\w+ (?:[:]{2}[A-Za-z]\w+)* $}x]
252              
253             =item dbi_connect_info => Any
254              
255             =item pre_deploy_hook => CodeRef
256              
257             =item post_connect_hook => CodeRef
258              
259             =back
260              
261             This local version of the C<ValidationTemplates()> can be augmented by using C<around>
262              
263             around ValidationTemplates => sub {
264             my $vt = shift;
265             my $class = shift;
266              
267             use Types::Standard qw( HashRef );
268             my $templates = $class->$vt;
269             return {
270             %$templates,
271             dbi_connect_info => { type => HashRef },
272             };
273             };
274              
275             =end hide
276              
277             =cut
278              
279             return {
280             schema_class => { type => StrMatch[qr{^ [A-Za-z]\w+ (?:[:]{2}[A-Za-z]\w+)* $}x] },
281             dbi_connect_info => { type => Any },
282             pre_deploy_hook => { type => Maybe[CodeRef] },
283             post_connect_hook => { type => Maybe[CodeRef] },
284             };
285 124     124 1 537 }
286              
287             1;
288              
289             =head1 COPYRIGHT
290              
291             E<copy> MMXXI - Abe Timmerman <abeltje@cpan.org>
292              
293             =head1 LICENSE
294              
295             This program is free software; you can redistribute it and/or modify
296             it under the same terms as Perl itself.
297              
298             This program is distributed in the hope that it will be useful,
299             but WITHOUT ANY WARRANTY; without even the implied warranty of
300             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
301              
302             =cut