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', |
6dde4613 |
177 | warnings => [ |
178 | qr/Dumping manual schema for DBICTest::Schema::13 to directory /, |
179 | qr/Schema dump completed/, |
180 | ], |
181 | regexes => { |
182 | Foo => [ |
183 | qr/package DBICTest::Schema::13::Foo;\nour \$skip_me = "bad mojo";\n1;/ |
184 | ], |
185 | }, |
186 | ); |
187 | |
188 | # test skipping external content |
189 | do_dump_test( |
190 | classname => 'DBICTest::Schema::14', |
191 | options => { skip_load_external => 1 }, |
6dde4613 |
192 | warnings => [ |
193 | qr/Dumping manual schema for DBICTest::Schema::14 to directory /, |
194 | qr/Schema dump completed/, |
195 | ], |
196 | neg_regexes => { |
197 | Foo => [ |
198 | qr/package DBICTest::Schema::14::Foo;\nour \$skip_me = "bad mojo";\n1;/ |
199 | ], |
200 | }, |
201 | ); |
202 | |
203 | rmtree($DUMP_PATH, 1, 1); |
204 | |
73099af4 |
205 | # test config_file |
206 | |
207 | my ($fh, $config_file) = tempfile; |
208 | |
209 | print $fh <<'EOF'; |
210 | { skip_relationships => 1 } |
211 | EOF |
212 | close $fh; |
213 | |
214 | do_dump_test( |
215 | classname => 'DBICTest::Schema::14', |
216 | options => { config_file => $config_file }, |
73099af4 |
217 | warnings => [ |
218 | qr/Dumping manual schema for DBICTest::Schema::14 to directory /, |
219 | qr/Schema dump completed/, |
220 | ], |
221 | neg_regexes => { |
222 | Foo => [ |
223 | qr/has_many/, |
224 | ], |
225 | }, |
226 | ); |
227 | |
228 | unlink $config_file; |
229 | |
f812ef60 |
230 | rmtree($DUMP_PATH, 1, 1); |
231 | |
232 | do_dump_test( |
233 | classname => 'DBICTest::Schema::14', |
234 | test_db_class => 'make_dbictest_db_clashing_monikers', |
235 | error => qr/tables 'bar', 'bars' reduced to the same source moniker 'Bar'/, |
236 | ); |
237 | |
238 | rmtree($DUMP_PATH, 1, 1); |
239 | |
9de8c789 |
240 | # test out the POD |
241 | |
a4187fdf |
242 | do_dump_test( |
243 | classname => 'DBICTest::DumpMore::1', |
f170d55b |
244 | options => { |
245 | custom_column_info => sub { |
246 | my ($table, $col, $info) = @_; |
247 | return +{ extra => { is_footext => 1 } } if $col eq 'footext'; |
248 | } |
249 | }, |
a4187fdf |
250 | warnings => [ |
251 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
252 | qr/Schema dump completed/, |
253 | ], |
254 | regexes => { |
255 | schema => [ |
256 | qr/package DBICTest::DumpMore::1;/, |
257 | qr/->load_classes/, |
258 | ], |
259 | Foo => [ |
9de8c789 |
260 | qr/package DBICTest::DumpMore::1::Foo;/, |
261 | qr/=head1 NAME\n\nDBICTest::DumpMore::1::Foo\n\n=cut\n\n/, |
262 | qr/=head1 ACCESSORS\n\n/, |
9334ac26 |
263 | qr/=head2 fooid\n\n data_type: 'integer'\n is_auto_increment: 1\n is_nullable: 1\n\n/, |
517a30e2 |
264 | qr/=head2 footext\n\n data_type: 'text'\n default_value: 'footext'\n extra: {is_footext => 1}\n is_nullable: 1\n\n/, |
9de8c789 |
265 | qr/->set_primary_key/, |
266 | qr/=head1 RELATIONS\n\n/, |
267 | qr/=head2 bars\n\nType: has_many\n\nRelated object: L<DBICTest::DumpMore::1::Bar>\n\n=cut\n\n/, |
268 | qr/1;\n$/, |
a4187fdf |
269 | ], |
270 | Bar => [ |
9de8c789 |
271 | qr/package DBICTest::DumpMore::1::Bar;/, |
272 | qr/=head1 NAME\n\nDBICTest::DumpMore::1::Bar\n\n=cut\n\n/, |
273 | qr/=head1 ACCESSORS\n\n/, |
9334ac26 |
274 | qr/=head2 barid\n\n data_type: 'integer'\n is_auto_increment: 1\n is_nullable: 1\n\n/, |
517a30e2 |
275 | qr/=head2 fooref\n\n data_type: 'integer'\n is_foreign_key: 1\n is_nullable: 1\n\n/, |
9de8c789 |
276 | qr/->set_primary_key/, |
277 | qr/=head1 RELATIONS\n\n/, |
278 | qr/=head2 fooref\n\nType: belongs_to\n\nRelated object: L<DBICTest::DumpMore::1::Foo>\n\n=cut\n\n/, |
279 | qr/1;\n$/, |
a4187fdf |
280 | ], |
281 | }, |
282 | ); |
283 | |
284 | append_to_class('DBICTest::DumpMore::1::Foo',q{# XXX This is my custom content XXX}); |
285 | |
286 | do_dump_test( |
287 | classname => 'DBICTest::DumpMore::1', |
a4187fdf |
288 | warnings => [ |
289 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
290 | qr/Schema dump completed/, |
291 | ], |
292 | regexes => { |
293 | schema => [ |
294 | qr/package DBICTest::DumpMore::1;/, |
295 | qr/->load_classes/, |
296 | ], |
297 | Foo => [ |
298 | qr/package DBICTest::DumpMore::1::Foo;/, |
299 | qr/->set_primary_key/, |
300 | qr/1;\n# XXX This is my custom content XXX/, |
301 | ], |
302 | Bar => [ |
303 | qr/package DBICTest::DumpMore::1::Bar;/, |
304 | qr/->set_primary_key/, |
305 | qr/1;\n$/, |
306 | ], |
307 | }, |
308 | ); |
605fcea8 |
309 | |
a4187fdf |
310 | do_dump_test( |
311 | classname => 'DBICTest::DumpMore::1', |
28b4691d |
312 | options => { really_erase_my_files => 1 }, |
a4187fdf |
313 | warnings => [ |
314 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
315 | qr/Deleting existing file /, |
316 | qr/Deleting existing file /, |
317 | qr/Deleting existing file /, |
318 | qr/Schema dump completed/, |
319 | ], |
320 | regexes => { |
321 | schema => [ |
322 | qr/package DBICTest::DumpMore::1;/, |
323 | qr/->load_classes/, |
324 | ], |
325 | Foo => [ |
326 | qr/package DBICTest::DumpMore::1::Foo;/, |
327 | qr/->set_primary_key/, |
328 | qr/1;\n$/, |
329 | ], |
330 | Bar => [ |
331 | qr/package DBICTest::DumpMore::1::Bar;/, |
332 | qr/->set_primary_key/, |
333 | qr/1;\n$/, |
334 | ], |
335 | }, |
336 | neg_regexes => { |
337 | Foo => [ |
338 | qr/# XXX This is my custom content XXX/, |
339 | ], |
492dce8d |
340 | }, |
341 | ); |
342 | |
eac5494b |
343 | rmtree($DUMP_PATH, 1, 1); |
344 | |
492dce8d |
345 | do_dump_test( |
346 | classname => 'DBICTest::DumpMore::1', |
347 | options => { use_namespaces => 1, generate_pod => 0 }, |
492dce8d |
348 | warnings => [ |
349 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
350 | qr/Schema dump completed/, |
351 | ], |
352 | neg_regexes => { |
353 | 'Result/Foo' => [ |
354 | qr/^=/m, |
355 | ], |
a4187fdf |
356 | }, |
357 | ); |
605fcea8 |
358 | |
eac5494b |
359 | rmtree($DUMP_PATH, 1, 1); |
360 | |
f44ecc2f |
361 | do_dump_test( |
362 | classname => 'DBICTest::DumpMore::1', |
363 | options => { use_namespaces => 1 }, |
f44ecc2f |
364 | warnings => [ |
365 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
366 | qr/Schema dump completed/, |
367 | ], |
368 | regexes => { |
369 | schema => [ |
370 | qr/package DBICTest::DumpMore::1;/, |
371 | qr/->load_namespaces/, |
372 | ], |
373 | 'Result/Foo' => [ |
374 | qr/package DBICTest::DumpMore::1::Result::Foo;/, |
375 | qr/->set_primary_key/, |
376 | qr/1;\n$/, |
377 | ], |
378 | 'Result/Bar' => [ |
379 | qr/package DBICTest::DumpMore::1::Result::Bar;/, |
380 | qr/->set_primary_key/, |
381 | qr/1;\n$/, |
382 | ], |
383 | }, |
384 | ); |
385 | |
eac5494b |
386 | rmtree($DUMP_PATH, 1, 1); |
387 | |
f44ecc2f |
388 | do_dump_test( |
389 | classname => 'DBICTest::DumpMore::1', |
390 | options => { use_namespaces => 1, |
391 | result_namespace => 'Res', |
392 | resultset_namespace => 'RSet', |
393 | default_resultset_class => 'RSetBase', |
394 | }, |
f44ecc2f |
395 | warnings => [ |
396 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
397 | qr/Schema dump completed/, |
398 | ], |
399 | regexes => { |
400 | schema => [ |
401 | qr/package DBICTest::DumpMore::1;/, |
402 | qr/->load_namespaces/, |
403 | qr/result_namespace => 'Res'/, |
404 | qr/resultset_namespace => 'RSet'/, |
405 | qr/default_resultset_class => 'RSetBase'/, |
406 | ], |
407 | 'Res/Foo' => [ |
408 | qr/package DBICTest::DumpMore::1::Res::Foo;/, |
409 | qr/->set_primary_key/, |
410 | qr/1;\n$/, |
411 | ], |
412 | 'Res/Bar' => [ |
413 | qr/package DBICTest::DumpMore::1::Res::Bar;/, |
414 | qr/->set_primary_key/, |
415 | qr/1;\n$/, |
416 | ], |
417 | }, |
418 | ); |
419 | |
eac5494b |
420 | rmtree($DUMP_PATH, 1, 1); |
421 | |
f44ecc2f |
422 | do_dump_test( |
423 | classname => 'DBICTest::DumpMore::1', |
424 | options => { use_namespaces => 1, |
425 | result_namespace => '+DBICTest::DumpMore::1::Res', |
426 | resultset_namespace => 'RSet', |
427 | default_resultset_class => 'RSetBase', |
9c9c2f2b |
428 | result_base_class => 'My::ResultBaseClass', |
429 | schema_base_class => 'My::SchemaBaseClass', |
f44ecc2f |
430 | }, |
f44ecc2f |
431 | warnings => [ |
432 | qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, |
433 | qr/Schema dump completed/, |
434 | ], |
435 | regexes => { |
436 | schema => [ |
437 | qr/package DBICTest::DumpMore::1;/, |
438 | qr/->load_namespaces/, |
439 | qr/result_namespace => '\+DBICTest::DumpMore::1::Res'/, |
440 | qr/resultset_namespace => 'RSet'/, |
441 | qr/default_resultset_class => 'RSetBase'/, |
9c9c2f2b |
442 | qr/use base 'My::SchemaBaseClass'/, |
f44ecc2f |
443 | ], |
444 | 'Res/Foo' => [ |
445 | qr/package DBICTest::DumpMore::1::Res::Foo;/, |
9c9c2f2b |
446 | qr/use base 'My::ResultBaseClass'/, |
f44ecc2f |
447 | qr/->set_primary_key/, |
448 | qr/1;\n$/, |
449 | ], |
450 | 'Res/Bar' => [ |
451 | qr/package DBICTest::DumpMore::1::Res::Bar;/, |
9c9c2f2b |
452 | qr/use base 'My::ResultBaseClass'/, |
f44ecc2f |
453 | qr/->set_primary_key/, |
454 | qr/1;\n$/, |
455 | ], |
456 | }, |
457 | ); |
c634fde9 |
458 | |
eac5494b |
459 | rmtree($DUMP_PATH, 1, 1); |
460 | |
8048320c |
461 | do_dump_test( |
462 | classname => 'DBICTest::DumpMore::1', |
463 | options => { |
464 | use_namespaces => 1, |
465 | result_base_class => 'My::MissingResultBaseClass', |
466 | }, |
467 | error => qr/My::MissingResultBaseClass.*is not installed/, |
468 | ); |
f44ecc2f |
469 | |
d27f2b7b |
470 | done_testing; |
471 | |
9de8c789 |
472 | END { rmtree($DUMP_PATH, 1, 1) unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP} } |