Commit | Line | Data |
66afce69 |
1 | use strict; |
2 | use warnings; |
3 | use Test::More; |
b24cb177 |
4 | use Test::Exception; |
a0e0a56a |
5 | use File::Path qw/rmtree make_path/; |
66afce69 |
6 | use Class::Unload; |
ffc705f3 |
7 | use File::Temp qw/tempfile tempdir/; |
8 | use IO::File; |
66afce69 |
9 | use lib qw(t/lib); |
10 | use make_dbictest_db2; |
11 | |
12 | my $DUMP_DIR = './t/_common_dump'; |
13 | rmtree $DUMP_DIR; |
a0e0a56a |
14 | my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema'; |
66afce69 |
15 | |
66afce69 |
16 | # test dynamic schema in 0.04006 mode |
17 | { |
18 | my $res = run_loader(); |
a0e0a56a |
19 | my $warning = $res->{warnings}[0]; |
66afce69 |
20 | |
a0e0a56a |
21 | like $warning, qr/dynamic schema/i, |
66afce69 |
22 | 'dynamic schema in backcompat mode detected'; |
a0e0a56a |
23 | like $warning, qr/run in 0\.04006 mode/i, |
66afce69 |
24 | 'dynamic schema in 0.04006 mode warning'; |
a0e0a56a |
25 | like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, |
26 | 'warning refers to upgrading doc'; |
27 | |
28 | run_v4_tests($res); |
29 | } |
66afce69 |
30 | |
a0e0a56a |
31 | # setting naming accessor on dynamic schema should disable warning (even when |
32 | # we're setting it to 'v4' .) |
33 | { |
34 | my $res = run_loader(naming => 'v4'); |
66afce69 |
35 | |
a0e0a56a |
36 | is_deeply $res->{warnings}, [], 'no warnings with naming attribute set'; |
f53dcdf0 |
37 | |
38 | run_v4_tests($res); |
a0e0a56a |
39 | } |
40 | |
41 | # test upgraded dynamic schema |
42 | { |
43 | my $res = run_loader(naming => 'current'); |
66afce69 |
44 | |
a0e0a56a |
45 | # to dump a schema for debugging... |
46 | # { |
47 | # mkdir '/tmp/HLAGH'; |
48 | # $schema->_loader->{dump_directory} = '/tmp/HLAGH'; |
49 | # $schema->_loader->_dump_to_dir(values %{ $res->{classes} }); |
50 | # } |
66afce69 |
51 | |
a0e0a56a |
52 | is_deeply $res->{warnings}, [], 'no warnings with naming attribute set'; |
66afce69 |
53 | |
a0e0a56a |
54 | run_v5_tests($res); |
55 | } |
56 | |
ffc705f3 |
57 | # test upgraded dynamic schema with external content loaded |
58 | { |
59 | my $temp_dir = tempdir; |
60 | push @INC, $temp_dir; |
61 | |
62 | my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS; |
63 | make_path $external_result_dir; |
64 | |
b24cb177 |
65 | # make external content for Result that will be singularized |
ffc705f3 |
66 | IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF"); |
67 | package ${SCHEMA_CLASS}::Quuxs; |
68 | sub a_method { 'hlagh' } |
b24cb177 |
69 | |
70 | __PACKAGE__->has_one('bazrel', 'DBIXCSL_Test::Schema::Bazs', |
71 | { 'foreign.baz_num' => 'self.baz_id' }); |
72 | |
73 | 1; |
74 | EOF |
75 | |
76 | # make external content for Result that will NOT be singularized |
77 | IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF"); |
78 | package ${SCHEMA_CLASS}::Bar; |
79 | |
80 | __PACKAGE__->has_one('foorel', 'DBIXCSL_Test::Schema::Foos', |
81 | { 'foreign.fooid' => 'self.foo_id' }); |
82 | |
ffc705f3 |
83 | 1; |
84 | EOF |
85 | |
86 | my $res = run_loader(naming => 'current'); |
87 | my $schema = $res->{schema}; |
88 | |
89 | is scalar @{ $res->{warnings} }, 1, |
90 | 'correct nummber of warnings for upgraded dynamic schema with external ' . |
91 | 'content for unsingularized Result.'; |
92 | |
93 | my $warning = $res->{warnings}[0]; |
94 | like $warning, qr/Detected external content/i, |
95 | 'detected external content warning'; |
96 | |
b24cb177 |
97 | lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } |
ffc705f3 |
98 | 'external custom content for unsingularized Result was loaded by upgraded ' . |
99 | 'dynamic Schema'; |
100 | |
b24cb177 |
101 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, |
102 | $res->{classes}{bazs} } |
103 | 'unsingularized class names in external content are translated'; |
104 | |
105 | lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel, |
106 | $res->{classes}{foos} } |
107 | 'unsingularized class names in external content from unchanged Result class ' . |
108 | 'names are translated'; |
109 | |
ffc705f3 |
110 | run_v5_tests($res); |
111 | |
112 | rmtree $temp_dir; |
113 | pop @INC; |
114 | } |
115 | |
30a4c064 |
116 | # test upgraded static schema with external content loaded |
117 | { |
118 | my $temp_dir = tempdir; |
119 | push @INC, $temp_dir; |
120 | |
121 | my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS; |
122 | make_path $external_result_dir; |
123 | |
b24cb177 |
124 | # make external content for Result that will be singularized |
30a4c064 |
125 | IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF"); |
126 | package ${SCHEMA_CLASS}::Quuxs; |
127 | sub a_method { 'dongs' } |
b24cb177 |
128 | |
129 | __PACKAGE__->has_one('bazrel2', 'DBIXCSL_Test::Schema::Bazs', |
130 | { 'foreign.baz_num' => 'self.baz_id' }); |
131 | |
132 | 1; |
133 | EOF |
134 | |
135 | # make external content for Result that will NOT be singularized |
136 | IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF"); |
137 | package ${SCHEMA_CLASS}::Bar; |
138 | |
139 | __PACKAGE__->has_one('foorel2', 'DBIXCSL_Test::Schema::Foos', |
140 | { 'foreign.fooid' => 'self.foo_id' }); |
141 | |
30a4c064 |
142 | 1; |
143 | EOF |
144 | |
145 | write_v4_schema_pm(); |
146 | |
147 | my $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current'); |
148 | my $schema = $res->{schema}; |
149 | |
150 | run_v5_tests($res); |
151 | |
b24cb177 |
152 | lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'dongs' } |
30a4c064 |
153 | 'external custom content for unsingularized Result was loaded by upgraded ' . |
154 | 'static Schema'; |
155 | |
b24cb177 |
156 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2, |
157 | $res->{classes}{bazs} } |
158 | 'unsingularized class names in external content are translated'; |
159 | |
160 | lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel2, |
161 | $res->{classes}{foos} } |
162 | 'unsingularized class names in external content from unchanged Result class ' . |
163 | 'names are translated in static schema'; |
164 | |
30a4c064 |
165 | my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs}); |
166 | my $code = do { local ($/, @ARGV) = (undef, $file); <> }; |
167 | |
168 | like $code, qr/package ${SCHEMA_CLASS}::Quux;/, |
169 | 'package line translated correctly from external custom content in static dump'; |
170 | |
171 | like $code, qr/sub a_method { 'dongs' }/, |
172 | 'external custom content loaded into static dump correctly'; |
173 | |
174 | rmtree $temp_dir; |
175 | pop @INC; |
176 | } |
177 | |
b24cb177 |
178 | # test running against v4 schema without upgrade, twice, then upgrade |
a0e0a56a |
179 | { |
30a4c064 |
180 | write_v4_schema_pm(); |
a0e0a56a |
181 | |
182 | # now run the loader |
183 | my $res = run_loader(dump_directory => $DUMP_DIR); |
184 | my $warning = $res->{warnings}[0]; |
185 | |
186 | like $warning, qr/static schema/i, |
187 | 'static schema in backcompat mode detected'; |
188 | like $warning, qr/0.04006/, |
189 | 'correct version detected'; |
190 | like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, |
191 | 'refers to upgrading doc'; |
192 | |
ffc705f3 |
193 | is scalar @{ $res->{warnings} }, 3, |
194 | 'correct number of warnings for static schema in backcompat mode'; |
195 | |
a0e0a56a |
196 | run_v4_tests($res); |
197 | |
198 | # add some custom content to a Result that will be replaced |
199 | my $schema = $res->{schema}; |
200 | my $quuxs_pm = $schema->_loader |
201 | ->_get_dump_filename($res->{classes}{quuxs}); |
202 | { |
203 | local ($^I, @ARGV) = ('', $quuxs_pm); |
204 | while (<>) { |
205 | if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { |
206 | print; |
b24cb177 |
207 | print <<EOF; |
208 | sub a_method { 'mtfnpy' } |
209 | |
210 | __PACKAGE__->has_one('bazrel3', 'DBIXCSL_Test::Schema::Bazs', |
211 | { 'foreign.baz_num' => 'self.baz_id' }); |
212 | EOF |
a0e0a56a |
213 | } |
214 | else { |
215 | print; |
216 | } |
217 | } |
218 | } |
219 | |
b24cb177 |
220 | # Rerun the loader in backcompat mode to make sure it's still in backcompat |
221 | # mode. |
222 | $res = run_loader(dump_directory => $DUMP_DIR); |
223 | run_v4_tests($res); |
224 | |
a0e0a56a |
225 | # now upgrade the schema |
226 | $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current'); |
227 | $schema = $res->{schema}; |
228 | |
229 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
230 | 'correct warnings on upgrading static schema (with "naming" set)'; |
231 | |
232 | like $res->{warnings}[1], qr/dump completed/i, |
233 | 'correct warnings on upgrading static schema (with "naming" set)'; |
234 | |
235 | is scalar @{ $res->{warnings} }, 2, |
f53dcdf0 |
236 | 'correct number of warnings on upgrading static schema (with "naming" set)' |
237 | or diag @{ $res->{warnings} }; |
a0e0a56a |
238 | |
239 | run_v5_tests($res); |
240 | |
241 | (my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g; |
242 | my $result_count =()= glob "$result_dir/*"; |
243 | |
244 | is $result_count, 4, |
245 | 'un-singularized results were replaced during upgrade'; |
246 | |
247 | # check that custom content was preserved |
b24cb177 |
248 | lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' } |
a0e0a56a |
249 | 'custom content was carried over from un-singularized Result'; |
b24cb177 |
250 | |
251 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel3, |
252 | $res->{classes}{bazs} } |
253 | 'unsingularized class names in custom content are translated'; |
254 | |
255 | my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs}); |
256 | my $code = do { local ($/, @ARGV) = (undef, $file); <> }; |
257 | |
258 | like $code, qr/sub a_method { 'mtfnpy' }/, |
259 | 'custom content from unsingularized Result loaded into static dump correctly'; |
260 | } |
261 | |
262 | # Test upgrading an already singular result with custom content that refers to |
263 | # old class names. |
264 | { |
265 | write_v4_schema_pm(); |
266 | my $res = run_loader(dump_directory => $DUMP_DIR); |
267 | my $schema = $res->{schema}; |
268 | run_v4_tests($res); |
269 | |
270 | # add some custom content to a Result that will be replaced |
271 | my $bar_pm = $schema->_loader |
272 | ->_get_dump_filename($res->{classes}{bar}); |
273 | { |
274 | local ($^I, @ARGV) = ('', $bar_pm); |
275 | while (<>) { |
276 | if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { |
277 | print; |
278 | print <<EOF; |
279 | sub a_method { 'lalala' } |
280 | |
281 | __PACKAGE__->has_one('foorel3', 'DBIXCSL_Test::Schema::Foos', |
282 | { 'foreign.fooid' => 'self.foo_id' }); |
283 | EOF |
284 | } |
285 | else { |
286 | print; |
287 | } |
288 | } |
289 | } |
290 | |
291 | # now upgrade the schema |
292 | $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current'); |
293 | $schema = $res->{schema}; |
294 | run_v5_tests($res); |
295 | |
296 | # check that custom content was preserved |
297 | lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'lalala' } |
298 | 'custom content was preserved from Result pre-upgrade'; |
299 | |
300 | lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel3, |
301 | $res->{classes}{foos} } |
302 | 'unsingularized class names in custom content from Result with unchanged ' . |
303 | 'name are translated'; |
304 | |
305 | my $file = $schema->_loader->_get_dump_filename($res->{classes}{bar}); |
306 | my $code = do { local ($/, @ARGV) = (undef, $file); <> }; |
307 | |
308 | like $code, qr/sub a_method { 'lalala' }/, |
309 | 'custom content from Result with unchanged name loaded into static dump ' . |
310 | 'correctly'; |
66afce69 |
311 | } |
312 | |
313 | done_testing; |
314 | |
ffc705f3 |
315 | END { |
316 | rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}; |
317 | } |
a0e0a56a |
318 | |
dbe9e0f7 |
319 | sub run_loader { |
320 | my %loader_opts = @_; |
321 | |
322 | eval { |
323 | foreach my $source_name ($SCHEMA_CLASS->clone->sources) { |
324 | Class::Unload->unload("${SCHEMA_CLASS}::${source_name}"); |
325 | } |
326 | |
327 | Class::Unload->unload($SCHEMA_CLASS); |
328 | }; |
329 | undef $@; |
330 | |
331 | my @connect_info = $make_dbictest_db2::dsn; |
332 | my @loader_warnings; |
333 | local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); }; |
334 | eval qq{ |
335 | package $SCHEMA_CLASS; |
336 | use base qw/DBIx::Class::Schema::Loader/; |
337 | |
338 | __PACKAGE__->loader_options(\%loader_opts); |
339 | __PACKAGE__->connection(\@connect_info); |
340 | }; |
341 | |
342 | ok(!$@, "Loader initialization") or diag $@; |
343 | |
344 | my $schema = $SCHEMA_CLASS->clone; |
345 | my (%monikers, %classes); |
346 | foreach my $source_name ($schema->sources) { |
347 | my $table_name = $schema->source($source_name)->from; |
348 | $monikers{$table_name} = $source_name; |
349 | $classes{$table_name} = "${SCHEMA_CLASS}::${source_name}"; |
350 | } |
351 | |
352 | return { |
353 | schema => $schema, |
354 | warnings => \@loader_warnings, |
355 | monikers => \%monikers, |
356 | classes => \%classes, |
357 | }; |
358 | } |
359 | |
30a4c064 |
360 | sub write_v4_schema_pm { |
361 | (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//; |
362 | rmtree $schema_dir; |
363 | make_path $schema_dir; |
364 | my $schema_pm = "$schema_dir/Schema.pm"; |
365 | open my $fh, '>', $schema_pm or die $!; |
366 | print $fh <<'EOF'; |
367 | package DBIXCSL_Test::Schema; |
368 | |
369 | use strict; |
370 | use warnings; |
371 | |
372 | use base 'DBIx::Class::Schema'; |
373 | |
374 | __PACKAGE__->load_classes; |
375 | |
376 | |
377 | # Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25 |
378 | # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog |
379 | |
380 | |
381 | # You can replace this text with custom content, and it will be preserved on regeneration |
382 | 1; |
383 | EOF |
384 | } |
385 | |
dbe9e0f7 |
386 | sub run_v4_tests { |
387 | my $res = shift; |
388 | my $schema = $res->{schema}; |
389 | |
390 | is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ], |
391 | [qw/Foos Bar Bazs Quuxs/], |
392 | 'correct monikers in 0.04006 mode'; |
393 | |
394 | isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }), |
395 | $res->{classes}{bar}, |
396 | 'found a bar'); |
397 | |
398 | isa_ok eval { $bar->foo_id }, $res->{classes}{foos}, |
399 | 'correct rel name in 0.04006 mode'; |
400 | |
401 | ok my $baz = eval { $schema->resultset('Bazs')->find(1) }; |
402 | |
403 | isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet', |
404 | 'correct rel type and name for UNIQUE FK in 0.04006 mode'; |
405 | } |
406 | |
407 | sub run_v5_tests { |
408 | my $res = shift; |
409 | my $schema = $res->{schema}; |
410 | |
411 | is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ], |
412 | [qw/Foo Bar Baz Quux/], |
413 | 'correct monikers in current mode'; |
414 | |
415 | ok my $bar = eval { $schema->resultset('Bar')->find(1) }; |
416 | |
417 | isa_ok eval { $bar->foo }, $res->{classes}{foos}, |
418 | 'correct rel name in current mode'; |
419 | |
420 | ok my $baz = eval { $schema->resultset('Baz')->find(1) }; |
421 | |
422 | isa_ok eval { $baz->quux }, $res->{classes}{quuxs}, |
423 | 'correct rel type and name for UNIQUE FK in current mode'; |
424 | } |