Commit | Line | Data |
605fcea8 |
1 | use strict; |
2 | use Test::More; |
605fcea8 |
3 | use File::Path; |
ff746964 |
4 | use IPC::Open3; |
f170d55b |
5 | use Data::Dumper::Concise; |
73099af4 |
6 | use DBIx::Class::Schema::Loader (); |
7 | use File::Temp 'tempfile'; |
8 | use lib qw(t/lib); |
605fcea8 |
9 | |
a4187fdf |
10 | my $DUMP_PATH = './t/_dump'; |
605fcea8 |
11 | |
f812ef60 |
12 | my $TEST_DB_CLASS = 'make_dbictest_db'; |
13 | |
ff746964 |
14 | sub dump_directly { |
a4187fdf |
15 | my %tdata = @_; |
605fcea8 |
16 | |
a4187fdf |
17 | my $schema_class = $tdata{classname}; |
605fcea8 |
18 | |
19 | no strict 'refs'; |
20 | @{$schema_class . '::ISA'} = ('DBIx::Class::Schema::Loader'); |
ff746964 |
21 | $schema_class->loader_options(%{$tdata{options}}); |
605fcea8 |
22 | |
a4187fdf |
23 | my @warns; |
605fcea8 |
24 | eval { |
a4187fdf |
25 | local $SIG{__WARN__} = sub { push(@warns, @_) }; |
f812ef60 |
26 | $schema_class->connect(get_dsn(\%tdata)); |
605fcea8 |
27 | }; |
28 | my $err = $@; |
29 | $schema_class->storage->disconnect if !$err && $schema_class->storage; |
30 | undef *{$schema_class}; |
a4187fdf |
31 | |
8048320c |
32 | check_error($err, $tdata{error}); |
a4187fdf |
33 | |
ff746964 |
34 | return @warns; |
35 | } |
36 | |
37 | sub dump_dbicdump { |
38 | my %tdata = @_; |
39 | |
17ca645f |
40 | # use $^X so we execute ./script/dbicdump with the same perl binary that the tests were executed with |
41 | my @cmd = ($^X, qw(./script/dbicdump)); |
ff746964 |
42 | |
43 | while (my ($opt, $val) = each(%{ $tdata{options} })) { |
f170d55b |
44 | $val = Dumper($val) if ref $val; |
ff746964 |
45 | push @cmd, '-o', "$opt=$val"; |
46 | } |
47 | |
f812ef60 |
48 | push @cmd, $tdata{classname}, get_dsn(\%tdata); |
ff746964 |
49 | |
17ca645f |
50 | # make sure our current @INC gets used by dbicdump |
f1059ad4 |
51 | use Config; |
8048320c |
52 | local $ENV{PERL5LIB} = join $Config{path_sep}, @INC, ($ENV{PERL5LIB} || ''); |
17ca645f |
53 | |
ff746964 |
54 | my ($in, $out, $err); |
55 | my $pid = open3($in, $out, $err, @cmd); |
56 | |
8048320c |
57 | my @out = <$out>; |
ff746964 |
58 | waitpid($pid, 0); |
59 | |
8048320c |
60 | my ($error, @warns); |
61 | |
62 | if ($? >> 8 != 0) { |
63 | $error = $out[0]; |
64 | check_error($error, $tdata{error}); |
65 | } |
66 | else { |
67 | @warns = @out; |
68 | } |
69 | |
ff746964 |
70 | return @warns; |
71 | } |
72 | |
f812ef60 |
73 | sub get_dsn { |
74 | my $opts = shift; |
75 | |
76 | my $test_db_class = $opts->{test_db_class} || $TEST_DB_CLASS; |
77 | |
78 | eval "require $test_db_class;"; |
79 | die $@ if $@; |
80 | |
81 | my $dsn = do { |
82 | no strict 'refs'; |
83 | ${$test_db_class . '::dsn'}; |
84 | }; |
85 | |
86 | return $dsn; |
87 | } |
88 | |
8048320c |
89 | sub check_error { |
90 | my ($got, $expected) = @_; |
91 | |
92 | return unless $got && $expected; |
93 | |
94 | if (ref $expected eq 'Regexp') { |
95 | like $got, $expected, 'error matches expected pattern'; |
96 | return; |
97 | } |
98 | |
99 | is $got, $expected, 'error matches'; |
100 | } |
101 | |
ff746964 |
102 | sub do_dump_test { |
103 | my %tdata = @_; |
104 | |
105 | $tdata{options}{dump_directory} = $DUMP_PATH; |
f22644d7 |
106 | $tdata{options}{use_namespaces} ||= 0; |
ff746964 |
107 | |
108 | for my $dumper (\&dump_directly, \&dump_dbicdump) { |
109 | test_dumps(\%tdata, $dumper->(%tdata)); |
110 | } |
111 | } |
112 | |
113 | sub test_dumps { |
114 | my ($tdata, @warns) = @_; |
115 | |
116 | my %tdata = %{$tdata}; |
117 | |
118 | my $schema_class = $tdata{classname}; |
a4187fdf |
119 | my $check_warns = $tdata{warnings}; |
ff746964 |
120 | is(@warns, @$check_warns, "$schema_class warning count"); |
8048320c |
121 | |
a4187fdf |
122 | for(my $i = 0; $i <= $#$check_warns; $i++) { |
ff746964 |
123 | like($warns[$i], $check_warns->[$i], "$schema_class warning $i"); |
a4187fdf |
124 | } |
125 | |
126 | my $file_regexes = $tdata{regexes}; |
127 | my $file_neg_regexes = $tdata{neg_regexes} || {}; |
128 | my $schema_regexes = delete $file_regexes->{schema}; |
129 | |
130 | my $schema_path = $DUMP_PATH . '/' . $schema_class; |
131 | $schema_path =~ s{::}{/}g; |
f812ef60 |
132 | |
133 | dump_file_like($schema_path . '.pm', @$schema_regexes) if $schema_regexes; |
134 | |
a4187fdf |
135 | foreach my $src (keys %$file_regexes) { |
136 | my $src_file = $schema_path . '/' . $src . '.pm'; |
137 | dump_file_like($src_file, @{$file_regexes->{$src}}); |
138 | } |
139 | foreach my $src (keys %$file_neg_regexes) { |
140 | my $src_file = $schema_path . '/' . $src . '.pm'; |
141 | dump_file_not_like($src_file, @{$file_neg_regexes->{$src}}); |
142 | } |
605fcea8 |
143 | } |
144 | |
a4187fdf |
145 | sub dump_file_like { |
146 | my $path = shift; |
147 | open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!"; |
148 | my $contents = do { local $/; <$dumpfh>; }; |
149 | close($dumpfh); |
ff746964 |
150 | my $num = 1; |
151 | like($contents, $_, "like $path " . $num++) for @_; |
a4187fdf |
152 | } |
605fcea8 |
153 | |
a4187fdf |
154 | sub dump_file_not_like { |
155 | my $path = shift; |
156 | open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!"; |
157 | my $contents = do { local $/; <$dumpfh>; }; |
158 | close($dumpfh); |
ff746964 |
159 | my $num = 1; |
160 | unlike($contents, $_, "unlike $path ". $num++) for @_; |
605fcea8 |
161 | } |
162 | |
a4187fdf |
163 | sub append_to_class { |
164 | my ($class, $string) = @_; |
165 | $class =~ s{::}{/}g; |
166 | $class = $DUMP_PATH . '/' . $class . '.pm'; |
167 | open(my $appendfh, '>>', $class) or die "Failed to open '$class' for append: $!"; |
168 | print $appendfh $string; |
169 | close($appendfh); |
170 | } |
171 | |
172 | rmtree($DUMP_PATH, 1, 1); |
173 | |
6dde4613 |
174 | # test loading external content |
175 | do_dump_test( |
176 | classname => 'DBICTest::Schema::13', |
177 | options => { }, |
178 | error => '', |
179 | warnings => [ |
180 | qr/Dumping manual schema for DBICTest::Schema::13 to directory /, |
181 | qr/Schema dump completed/, |
182 | ], |
183 | regexes => { |
184 | Foo => [ |
185 | qr/package DBICTest::Schema::13::Foo;\nour \$skip_me = "bad mojo";\n1;/ |
186 | ], |
187 | }, |
188 | ); |
189 | |
190 | # test skipping external content |
191 | do_dump_test( |
192 | classname => 'DBICTest::Schema::14', |
193 | options => { skip_load_external => 1 }, |
194 | error => '', |
195 | warnings => [ |
196 | qr/Dumping manual schema for DBICTest::Schema::14 to directory /, |
197 | qr/Schema dump completed/, |
198 | ], |
199 | neg_regexes => { |
200 | Foo => [ |
201 | qr/package DBICTest::Schema::14::Foo;\nour \$skip_me = "bad mojo";\n1;/ |
202 | ], |
203 | }, |
204 | ); |
205 | |
206 | rmtree($DUMP_PATH, 1, 1); |
207 | |
73099af4 |
208 | # test config_file |
209 | |
210 | my ($fh, $config_file) = tempfile; |
211 | |
212 | print $fh <<'EOF'; |
213 | { skip_relationships => 1 } |
214 | EOF |
215 | close $fh; |
216 | |
217 | do_dump_test( |
218 | classname => 'DBICTest::Schema::14', |
219 | options => { config_file => $config_file }, |
220 | error => '', |
221 | warnings => [ |
222 | qr/Dumping manual schema for DBICTest::Schema::14 to directory /, |
223 | qr/Schema dump completed/, |
224 | ], |
225 | neg_regexes => { |
226 | Foo => [ |
227 | qr/has_many/, |
228 | ], |
229 | }, |
230 | ); |
231 | |
232 | unlink $config_file; |
233 | |
f812ef60 |
234 | rmtree($DUMP_PATH, 1, 1); |
235 | |
236 | do_dump_test( |
237 | classname => 'DBICTest::Schema::14', |
238 | test_db_class => 'make_dbictest_db_clashing_monikers', |
239 | error => qr/tables 'bar', 'bars' reduced to the same source moniker 'Bar'/, |
240 | ); |
241 | |
242 | rmtree($DUMP_PATH, 1, 1); |
243 | |
9de8c789 |
244 | # test out the POD |
245 | |
a4187fdf |
246 | do_dump_test( |
247 | classname => 'DBICTest::DumpMore::1', |
f170d55b |
248 | options => { |
249 | custom_column_info => sub { |
250 | my ($table, $col, $info) = @_; |
251 | return +{ extra => { is_footext => 1 } } if $col eq 'footext'; |
252 | } |
253 | }, |
a4187fdf |
254 | error => '', |
255 | warnings => [ |
256 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
257 | qr/Schema dump completed/, |
258 | ], |
259 | regexes => { |
260 | schema => [ |
261 | qr/package DBICTest::DumpMore::1;/, |
262 | qr/->load_classes/, |
263 | ], |
264 | Foo => [ |
9de8c789 |
265 | qr/package DBICTest::DumpMore::1::Foo;/, |
266 | qr/=head1 NAME\n\nDBICTest::DumpMore::1::Foo\n\n=cut\n\n/, |
267 | qr/=head1 ACCESSORS\n\n/, |
f812ef60 |
268 | qr/=head2 fooid\n\n data_type: 'INTEGER'\n is_nullable: 1\n\n/, |
269 | qr/=head2 footext\n\n data_type: 'TEXT'\n default_value: 'footext'\n extra: {is_footext => 1}\n is_nullable: 1\n\n/, |
9de8c789 |
270 | qr/->set_primary_key/, |
271 | qr/=head1 RELATIONS\n\n/, |
272 | qr/=head2 bars\n\nType: has_many\n\nRelated object: L<DBICTest::DumpMore::1::Bar>\n\n=cut\n\n/, |
273 | qr/1;\n$/, |
a4187fdf |
274 | ], |
275 | Bar => [ |
9de8c789 |
276 | qr/package DBICTest::DumpMore::1::Bar;/, |
277 | qr/=head1 NAME\n\nDBICTest::DumpMore::1::Bar\n\n=cut\n\n/, |
278 | qr/=head1 ACCESSORS\n\n/, |
f812ef60 |
279 | qr/=head2 barid\n\n data_type: 'INTEGER'\n is_nullable: 1\n\n/, |
280 | qr/=head2 fooref\n\n data_type: 'INTEGER'\n is_foreign_key: 1\n is_nullable: 1\n\n/, |
9de8c789 |
281 | qr/->set_primary_key/, |
282 | qr/=head1 RELATIONS\n\n/, |
283 | qr/=head2 fooref\n\nType: belongs_to\n\nRelated object: L<DBICTest::DumpMore::1::Foo>\n\n=cut\n\n/, |
284 | qr/1;\n$/, |
a4187fdf |
285 | ], |
286 | }, |
287 | ); |
288 | |
289 | append_to_class('DBICTest::DumpMore::1::Foo',q{# XXX This is my custom content XXX}); |
290 | |
291 | do_dump_test( |
292 | classname => 'DBICTest::DumpMore::1', |
293 | options => { }, |
294 | error => '', |
295 | warnings => [ |
296 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
297 | qr/Schema dump completed/, |
298 | ], |
299 | regexes => { |
300 | schema => [ |
301 | qr/package DBICTest::DumpMore::1;/, |
302 | qr/->load_classes/, |
303 | ], |
304 | Foo => [ |
305 | qr/package DBICTest::DumpMore::1::Foo;/, |
306 | qr/->set_primary_key/, |
307 | qr/1;\n# XXX This is my custom content XXX/, |
308 | ], |
309 | Bar => [ |
310 | qr/package DBICTest::DumpMore::1::Bar;/, |
311 | qr/->set_primary_key/, |
312 | qr/1;\n$/, |
313 | ], |
314 | }, |
315 | ); |
605fcea8 |
316 | |
a4187fdf |
317 | do_dump_test( |
318 | classname => 'DBICTest::DumpMore::1', |
28b4691d |
319 | options => { really_erase_my_files => 1 }, |
a4187fdf |
320 | error => '', |
321 | warnings => [ |
322 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
323 | qr/Deleting existing file /, |
324 | qr/Deleting existing file /, |
325 | qr/Deleting existing file /, |
326 | qr/Schema dump completed/, |
327 | ], |
328 | regexes => { |
329 | schema => [ |
330 | qr/package DBICTest::DumpMore::1;/, |
331 | qr/->load_classes/, |
332 | ], |
333 | Foo => [ |
334 | qr/package DBICTest::DumpMore::1::Foo;/, |
335 | qr/->set_primary_key/, |
336 | qr/1;\n$/, |
337 | ], |
338 | Bar => [ |
339 | qr/package DBICTest::DumpMore::1::Bar;/, |
340 | qr/->set_primary_key/, |
341 | qr/1;\n$/, |
342 | ], |
343 | }, |
344 | neg_regexes => { |
345 | Foo => [ |
346 | qr/# XXX This is my custom content XXX/, |
347 | ], |
492dce8d |
348 | }, |
349 | ); |
350 | |
351 | do_dump_test( |
352 | classname => 'DBICTest::DumpMore::1', |
353 | options => { use_namespaces => 1, generate_pod => 0 }, |
354 | error => '', |
355 | warnings => [ |
356 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
357 | qr/Schema dump completed/, |
358 | ], |
359 | neg_regexes => { |
360 | 'Result/Foo' => [ |
361 | qr/^=/m, |
362 | ], |
a4187fdf |
363 | }, |
364 | ); |
605fcea8 |
365 | |
f44ecc2f |
366 | do_dump_test( |
367 | classname => 'DBICTest::DumpMore::1', |
368 | options => { use_namespaces => 1 }, |
369 | error => '', |
370 | warnings => [ |
371 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
372 | qr/Schema dump completed/, |
373 | ], |
374 | regexes => { |
375 | schema => [ |
376 | qr/package DBICTest::DumpMore::1;/, |
377 | qr/->load_namespaces/, |
378 | ], |
379 | 'Result/Foo' => [ |
380 | qr/package DBICTest::DumpMore::1::Result::Foo;/, |
381 | qr/->set_primary_key/, |
382 | qr/1;\n$/, |
383 | ], |
384 | 'Result/Bar' => [ |
385 | qr/package DBICTest::DumpMore::1::Result::Bar;/, |
386 | qr/->set_primary_key/, |
387 | qr/1;\n$/, |
388 | ], |
389 | }, |
390 | ); |
391 | |
392 | do_dump_test( |
393 | classname => 'DBICTest::DumpMore::1', |
394 | options => { use_namespaces => 1, |
395 | result_namespace => 'Res', |
396 | resultset_namespace => 'RSet', |
397 | default_resultset_class => 'RSetBase', |
398 | }, |
399 | error => '', |
400 | warnings => [ |
401 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
402 | qr/Schema dump completed/, |
403 | ], |
404 | regexes => { |
405 | schema => [ |
406 | qr/package DBICTest::DumpMore::1;/, |
407 | qr/->load_namespaces/, |
408 | qr/result_namespace => 'Res'/, |
409 | qr/resultset_namespace => 'RSet'/, |
410 | qr/default_resultset_class => 'RSetBase'/, |
411 | ], |
412 | 'Res/Foo' => [ |
413 | qr/package DBICTest::DumpMore::1::Res::Foo;/, |
414 | qr/->set_primary_key/, |
415 | qr/1;\n$/, |
416 | ], |
417 | 'Res/Bar' => [ |
418 | qr/package DBICTest::DumpMore::1::Res::Bar;/, |
419 | qr/->set_primary_key/, |
420 | qr/1;\n$/, |
421 | ], |
422 | }, |
423 | ); |
424 | |
425 | do_dump_test( |
426 | classname => 'DBICTest::DumpMore::1', |
427 | options => { use_namespaces => 1, |
428 | result_namespace => '+DBICTest::DumpMore::1::Res', |
429 | resultset_namespace => 'RSet', |
430 | default_resultset_class => 'RSetBase', |
9c9c2f2b |
431 | result_base_class => 'My::ResultBaseClass', |
432 | schema_base_class => 'My::SchemaBaseClass', |
f44ecc2f |
433 | }, |
434 | error => '', |
435 | warnings => [ |
436 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
437 | qr/Schema dump completed/, |
438 | ], |
439 | regexes => { |
440 | schema => [ |
441 | qr/package DBICTest::DumpMore::1;/, |
442 | qr/->load_namespaces/, |
443 | qr/result_namespace => '\+DBICTest::DumpMore::1::Res'/, |
444 | qr/resultset_namespace => 'RSet'/, |
445 | qr/default_resultset_class => 'RSetBase'/, |
9c9c2f2b |
446 | qr/use base 'My::SchemaBaseClass'/, |
f44ecc2f |
447 | ], |
448 | 'Res/Foo' => [ |
449 | qr/package DBICTest::DumpMore::1::Res::Foo;/, |
9c9c2f2b |
450 | qr/use base 'My::ResultBaseClass'/, |
f44ecc2f |
451 | qr/->set_primary_key/, |
452 | qr/1;\n$/, |
453 | ], |
454 | 'Res/Bar' => [ |
455 | qr/package DBICTest::DumpMore::1::Res::Bar;/, |
9c9c2f2b |
456 | qr/use base 'My::ResultBaseClass'/, |
f44ecc2f |
457 | qr/->set_primary_key/, |
458 | qr/1;\n$/, |
459 | ], |
460 | }, |
461 | ); |
c634fde9 |
462 | |
8048320c |
463 | do_dump_test( |
464 | classname => 'DBICTest::DumpMore::1', |
465 | options => { |
466 | use_namespaces => 1, |
467 | result_base_class => 'My::MissingResultBaseClass', |
468 | }, |
469 | error => qr/My::MissingResultBaseClass.*is not installed/, |
470 | ); |
f44ecc2f |
471 | |
d27f2b7b |
472 | done_testing; |
473 | |
9de8c789 |
474 | END { rmtree($DUMP_PATH, 1, 1) unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP} } |