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