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