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; |
281d0f3e |
9 | use File::Slurp 'slurp'; |
68d49e50 |
10 | use DBIx::Class::Schema::Loader (); |
08e80fda |
11 | use Lingua::EN::Inflect::Number (); |
66afce69 |
12 | use lib qw(t/lib); |
c496748b |
13 | use make_dbictest_db_with_unique; |
66afce69 |
14 | |
15 | my $DUMP_DIR = './t/_common_dump'; |
16 | rmtree $DUMP_DIR; |
a0e0a56a |
17 | my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema'; |
66afce69 |
18 | |
08e80fda |
19 | sub class_content_like; |
20 | |
66afce69 |
21 | # test dynamic schema in 0.04006 mode |
22 | { |
23 | my $res = run_loader(); |
a0e0a56a |
24 | my $warning = $res->{warnings}[0]; |
66afce69 |
25 | |
a0e0a56a |
26 | like $warning, qr/dynamic schema/i, |
66afce69 |
27 | 'dynamic schema in backcompat mode detected'; |
a0e0a56a |
28 | like $warning, qr/run in 0\.04006 mode/i, |
66afce69 |
29 | 'dynamic schema in 0.04006 mode warning'; |
a0e0a56a |
30 | like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, |
31 | 'warning refers to upgrading doc'; |
32 | |
33 | run_v4_tests($res); |
34 | } |
66afce69 |
35 | |
a0e0a56a |
36 | # setting naming accessor on dynamic schema should disable warning (even when |
37 | # we're setting it to 'v4' .) |
38 | { |
39 | my $res = run_loader(naming => 'v4'); |
a0e0a56a |
40 | is_deeply $res->{warnings}, [], 'no warnings with naming attribute set'; |
f53dcdf0 |
41 | run_v4_tests($res); |
a0e0a56a |
42 | } |
43 | |
44 | # test upgraded dynamic schema |
45 | { |
46 | my $res = run_loader(naming => 'current'); |
a0e0a56a |
47 | is_deeply $res->{warnings}, [], 'no warnings with naming attribute set'; |
ecf930e6 |
48 | run_v6_tests($res); |
a0e0a56a |
49 | } |
50 | |
ffc705f3 |
51 | # test upgraded dynamic schema with external content loaded |
52 | { |
08e80fda |
53 | my $temp_dir = setup_load_external({ |
54 | Quuxs => 'Bazs', |
55 | Bar => 'Foos', |
56 | }); |
ffc705f3 |
57 | |
58 | my $res = run_loader(naming => 'current'); |
59 | my $schema = $res->{schema}; |
60 | |
61 | is scalar @{ $res->{warnings} }, 1, |
62 | 'correct nummber of warnings for upgraded dynamic schema with external ' . |
63 | 'content for unsingularized Result.'; |
64 | |
65 | my $warning = $res->{warnings}[0]; |
66 | like $warning, qr/Detected external content/i, |
67 | 'detected external content warning'; |
68 | |
b24cb177 |
69 | lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } |
ffc705f3 |
70 | 'external custom content for unsingularized Result was loaded by upgraded ' . |
71 | 'dynamic Schema'; |
72 | |
b24cb177 |
73 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, |
74 | $res->{classes}{bazs} } |
75 | 'unsingularized class names in external content are translated'; |
76 | |
08e80fda |
77 | lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'hlagh' } |
78 | 'external content from unchanged Result class'; |
79 | |
b24cb177 |
80 | lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel, |
81 | $res->{classes}{foos} } |
82 | 'unsingularized class names in external content from unchanged Result class ' . |
83 | 'names are translated'; |
84 | |
ecf930e6 |
85 | run_v6_tests($res); |
ffc705f3 |
86 | } |
87 | |
805dbe0a |
88 | # test upgraded dynamic schema with use_namespaces with external content loaded |
89 | { |
08e80fda |
90 | my $temp_dir = setup_load_external({ |
91 | Quuxs => 'Bazs', |
92 | Bar => 'Foos', |
93 | }); |
805dbe0a |
94 | |
95 | my $res = run_loader(naming => 'current', use_namespaces => 1); |
96 | my $schema = $res->{schema}; |
97 | |
98 | is scalar @{ $res->{warnings} }, 2, |
99 | 'correct nummber of warnings for upgraded dynamic schema with external ' . |
100 | 'content for unsingularized Result with use_namespaces.'; |
101 | |
102 | my $warning = $res->{warnings}[0]; |
103 | like $warning, qr/Detected external content/i, |
104 | 'detected external content warning'; |
105 | |
106 | lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } |
107 | 'external custom content for unsingularized Result was loaded by upgraded ' . |
108 | 'dynamic Schema'; |
109 | |
08e80fda |
110 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, |
805dbe0a |
111 | $res->{classes}{bazs} } |
112 | 'unsingularized class names in external content are translated'; |
113 | |
08e80fda |
114 | lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel, |
805dbe0a |
115 | $res->{classes}{foos} } |
116 | 'unsingularized class names in external content from unchanged Result class ' . |
117 | 'names are translated'; |
118 | |
ecf930e6 |
119 | run_v6_tests($res); |
805dbe0a |
120 | } |
121 | |
30a4c064 |
122 | # test upgraded static schema with external content loaded |
123 | { |
08e80fda |
124 | clean_dumpdir(); |
b24cb177 |
125 | |
08e80fda |
126 | my $temp_dir = setup_load_external({ |
127 | Quuxs => 'Bazs', |
128 | Bar => 'Foos', |
129 | }); |
30a4c064 |
130 | |
131 | write_v4_schema_pm(); |
132 | |
08e80fda |
133 | my $res = run_loader(static => 1, naming => 'current'); |
30a4c064 |
134 | my $schema = $res->{schema}; |
135 | |
ecf930e6 |
136 | run_v6_tests($res); |
30a4c064 |
137 | |
08e80fda |
138 | lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } |
30a4c064 |
139 | 'external custom content for unsingularized Result was loaded by upgraded ' . |
140 | 'static Schema'; |
141 | |
08e80fda |
142 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, |
b24cb177 |
143 | $res->{classes}{bazs} } |
144 | 'unsingularized class names in external content are translated'; |
145 | |
08e80fda |
146 | lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel, |
b24cb177 |
147 | $res->{classes}{foos} } |
148 | 'unsingularized class names in external content from unchanged Result class ' . |
149 | 'names are translated in static schema'; |
150 | |
08e80fda |
151 | class_content_like $schema, $res->{classes}{quuxs}, qr/package ${SCHEMA_CLASS}::Quux;/, |
30a4c064 |
152 | 'package line translated correctly from external custom content in static dump'; |
153 | |
08e80fda |
154 | class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/, |
30a4c064 |
155 | 'external custom content loaded into static dump correctly'; |
30a4c064 |
156 | } |
157 | |
b24cb177 |
158 | # test running against v4 schema without upgrade, twice, then upgrade |
a0e0a56a |
159 | { |
08e80fda |
160 | clean_dumpdir(); |
30a4c064 |
161 | write_v4_schema_pm(); |
08e80fda |
162 | my $res = run_loader(static => 1); |
a1a91c42 |
163 | my $warning = $res->{warnings}[1]; |
a0e0a56a |
164 | |
165 | like $warning, qr/static schema/i, |
166 | 'static schema in backcompat mode detected'; |
167 | like $warning, qr/0.04006/, |
168 | 'correct version detected'; |
169 | like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, |
170 | 'refers to upgrading doc'; |
171 | |
a1a91c42 |
172 | is scalar @{ $res->{warnings} }, 4, |
ffc705f3 |
173 | 'correct number of warnings for static schema in backcompat mode'; |
174 | |
a0e0a56a |
175 | run_v4_tests($res); |
176 | |
08e80fda |
177 | add_custom_content($res->{schema}, { |
178 | Quuxs => 'Bazs' |
179 | }); |
a0e0a56a |
180 | |
b24cb177 |
181 | # Rerun the loader in backcompat mode to make sure it's still in backcompat |
182 | # mode. |
08e80fda |
183 | $res = run_loader(static => 1); |
b24cb177 |
184 | run_v4_tests($res); |
185 | |
a0e0a56a |
186 | # now upgrade the schema |
a1a91c42 |
187 | $res = run_loader( |
08e80fda |
188 | static => 1, |
a1a91c42 |
189 | naming => 'current', |
190 | use_namespaces => 1 |
191 | ); |
08e80fda |
192 | my $schema = $res->{schema}; |
a0e0a56a |
193 | |
194 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
195 | 'correct warnings on upgrading static schema (with "naming" set)'; |
196 | |
197 | like $res->{warnings}[1], qr/dump completed/i, |
198 | 'correct warnings on upgrading static schema (with "naming" set)'; |
199 | |
200 | is scalar @{ $res->{warnings} }, 2, |
f53dcdf0 |
201 | 'correct number of warnings on upgrading static schema (with "naming" set)' |
202 | or diag @{ $res->{warnings} }; |
a0e0a56a |
203 | |
ecf930e6 |
204 | run_v6_tests($res); |
a0e0a56a |
205 | |
ecf930e6 |
206 | is result_count('Result'), 6, |
a1a91c42 |
207 | 'un-singularized results were replaced during upgrade'; |
208 | |
209 | # check that custom content was preserved |
08e80fda |
210 | lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' } |
a1a91c42 |
211 | 'custom content was carried over from un-singularized Result'; |
212 | |
08e80fda |
213 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, |
a1a91c42 |
214 | $res->{classes}{bazs} } |
215 | 'unsingularized class names in custom content are translated'; |
216 | |
08e80fda |
217 | class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, |
a1a91c42 |
218 | 'custom content from unsingularized Result loaded into static dump correctly'; |
219 | } |
220 | |
221 | # test running against v4 schema without upgrade, then upgrade with |
222 | # use_namespaces not explicitly set |
223 | { |
08e80fda |
224 | clean_dumpdir(); |
a1a91c42 |
225 | write_v4_schema_pm(); |
08e80fda |
226 | my $res = run_loader(static => 1); |
a1a91c42 |
227 | my $warning = $res->{warnings}[1]; |
228 | |
229 | like $warning, qr/static schema/i, |
230 | 'static schema in backcompat mode detected'; |
231 | like $warning, qr/0.04006/, |
232 | 'correct version detected'; |
233 | like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, |
234 | 'refers to upgrading doc'; |
235 | |
236 | is scalar @{ $res->{warnings} }, 4, |
237 | 'correct number of warnings for static schema in backcompat mode'; |
238 | |
239 | run_v4_tests($res); |
240 | |
08e80fda |
241 | add_custom_content($res->{schema}, { |
242 | Quuxs => 'Bazs' |
243 | }); |
a1a91c42 |
244 | |
245 | # now upgrade the schema |
246 | $res = run_loader( |
08e80fda |
247 | static => 1, |
a1a91c42 |
248 | naming => 'current' |
249 | ); |
08e80fda |
250 | my $schema = $res->{schema}; |
a1a91c42 |
251 | |
252 | like $res->{warnings}[0], qr/load_classes/i, |
253 | 'correct warnings on upgrading static schema (with "naming" set and ' . |
254 | 'use_namespaces not set)'; |
255 | |
256 | like $res->{warnings}[1], qr/Dumping manual schema/i, |
257 | 'correct warnings on upgrading static schema (with "naming" set and ' . |
258 | 'use_namespaces not set)'; |
259 | |
260 | like $res->{warnings}[2], qr/dump completed/i, |
261 | 'correct warnings on upgrading static schema (with "naming" set and ' . |
262 | 'use_namespaces not set)'; |
263 | |
264 | is scalar @{ $res->{warnings} }, 3, |
265 | 'correct number of warnings on upgrading static schema (with "naming" set)' |
266 | or diag @{ $res->{warnings} }; |
267 | |
ecf930e6 |
268 | run_v6_tests($res); |
a1a91c42 |
269 | |
ecf930e6 |
270 | is result_count(), 6, |
a0e0a56a |
271 | 'un-singularized results were replaced during upgrade'; |
272 | |
273 | # check that custom content was preserved |
08e80fda |
274 | lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' } |
a0e0a56a |
275 | 'custom content was carried over from un-singularized Result'; |
b24cb177 |
276 | |
08e80fda |
277 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, |
a4b94090 |
278 | $res->{classes}{bazs} } |
279 | 'unsingularized class names in custom content are translated'; |
280 | |
08e80fda |
281 | class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, |
a4b94090 |
282 | 'custom content from unsingularized Result loaded into static dump correctly'; |
283 | } |
284 | |
ecf930e6 |
285 | # test running against v4 schema with load_namespaces, upgrade to current but |
77bf4429 |
286 | # downgrade to load_classes, with external content |
a4b94090 |
287 | { |
08e80fda |
288 | clean_dumpdir(); |
77bf4429 |
289 | |
08e80fda |
290 | my $temp_dir = setup_load_external({ |
291 | Quuxs => 'Bazs', |
292 | Bar => 'Foos', |
293 | }, { result_namespace => 'Result' }); |
77bf4429 |
294 | |
a4b94090 |
295 | write_v4_schema_pm(use_namespaces => 1); |
77bf4429 |
296 | |
08e80fda |
297 | my $res = run_loader(static => 1); |
a4b94090 |
298 | my $warning = $res->{warnings}[0]; |
299 | |
300 | like $warning, qr/static schema/i, |
301 | 'static schema in backcompat mode detected'; |
302 | like $warning, qr/0.04006/, |
303 | 'correct version detected'; |
304 | like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, |
305 | 'refers to upgrading doc'; |
306 | |
307 | is scalar @{ $res->{warnings} }, 3, |
308 | 'correct number of warnings for static schema in backcompat mode'; |
309 | |
310 | run_v4_tests($res); |
311 | |
77bf4429 |
312 | is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quuxs', |
313 | 'use_namespaces in backcompat mode'; |
314 | |
08e80fda |
315 | add_custom_content($res->{schema}, { |
316 | Quuxs => 'Bazs', |
317 | }, { |
318 | result_namespace => 'Result', |
319 | rel_name_map => { QuuxBaz => 'bazrel2' }, |
320 | }); |
a4b94090 |
321 | |
ecf930e6 |
322 | # now upgrade the schema to current but downgrade to load_classes |
a4b94090 |
323 | $res = run_loader( |
08e80fda |
324 | static => 1, |
a4b94090 |
325 | naming => 'current', |
326 | use_namespaces => 0, |
327 | ); |
08e80fda |
328 | my $schema = $res->{schema}; |
a4b94090 |
329 | |
330 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
331 | 'correct warnings on upgrading static schema (with "naming" set and ' . |
332 | 'use_namespaces => 0)'; |
333 | |
334 | like $res->{warnings}[1], qr/dump completed/i, |
335 | 'correct warnings on upgrading static schema (with "naming" set and ' . |
336 | 'use_namespaces => 0)'; |
337 | |
338 | is scalar @{ $res->{warnings} }, 2, |
339 | 'correct number of warnings on upgrading static schema (with "naming" set)' |
340 | or diag @{ $res->{warnings} }; |
341 | |
ecf930e6 |
342 | run_v6_tests($res); |
a4b94090 |
343 | |
ecf930e6 |
344 | is result_count(), 6, |
a4b94090 |
345 | 'un-singularized results were replaced during upgrade and Result dir removed'; |
346 | |
08e80fda |
347 | ok ((not -d result_dir('Result')), |
a4b94090 |
348 | 'Result dir was removed for load_classes downgrade'); |
349 | |
540a8149 |
350 | is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', |
351 | 'load_classes in upgraded mode'; |
352 | |
77bf4429 |
353 | # check that custom and external content was preserved |
08e80fda |
354 | lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' } |
a4b94090 |
355 | 'custom content was carried over from un-singularized Result'; |
356 | |
08e80fda |
357 | lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } |
77bf4429 |
358 | 'external content was carried over from un-singularized Result'; |
359 | |
08e80fda |
360 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2, |
b24cb177 |
361 | $res->{classes}{bazs} } |
362 | 'unsingularized class names in custom content are translated'; |
363 | |
08e80fda |
364 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, |
77bf4429 |
365 | $res->{classes}{bazs} } |
366 | 'unsingularized class names in external content are translated'; |
367 | |
08e80fda |
368 | lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel, |
77bf4429 |
369 | $res->{classes}{foos} } |
370 | 'unsingularized class names in external content from unchanged Result class ' . |
371 | 'names are translated in static schema'; |
372 | |
08e80fda |
373 | class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/, |
77bf4429 |
374 | 'external content from unsingularized Result loaded into static dump correctly'; |
375 | |
08e80fda |
376 | class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, |
377 | 'custom content from unsingularized Result loaded into static dump correctly'; |
b24cb177 |
378 | } |
379 | |
540a8149 |
380 | # test a regular schema with use_namespaces => 0 upgraded to |
381 | # use_namespaces => 1 |
382 | { |
540a8149 |
383 | my $res = run_loader( |
08e80fda |
384 | clean_dumpdir => 1, |
385 | static => 1, |
540a8149 |
386 | use_namespaces => 0, |
387 | ); |
388 | |
389 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
390 | 'correct warnings on dumping static schema with use_namespaces => 0'; |
391 | |
392 | like $res->{warnings}[1], qr/dump completed/i, |
393 | 'correct warnings on dumping static schema with use_namespaces => 0'; |
394 | |
395 | is scalar @{ $res->{warnings} }, 2, |
396 | 'correct number of warnings on dumping static schema with use_namespaces => 0' |
397 | or diag @{ $res->{warnings} }; |
398 | |
ecf930e6 |
399 | run_v6_tests($res); |
540a8149 |
400 | |
540a8149 |
401 | my $schema = $res->{schema}; |
08e80fda |
402 | add_custom_content($res->{schema}, { |
403 | Quux => 'Baz' |
404 | }); |
540a8149 |
405 | |
406 | # test that with no use_namespaces option, there is a warning and |
407 | # load_classes is preserved |
08e80fda |
408 | $res = run_loader(static => 1); |
540a8149 |
409 | |
410 | like $res->{warnings}[0], qr/load_classes/i, |
411 | 'correct warnings on re-dumping static schema with load_classes'; |
412 | |
413 | like $res->{warnings}[1], qr/Dumping manual schema/i, |
414 | 'correct warnings on re-dumping static schema with load_classes'; |
415 | |
416 | like $res->{warnings}[2], qr/dump completed/i, |
417 | 'correct warnings on re-dumping static schema with load_classes'; |
418 | |
419 | is scalar @{ $res->{warnings} }, 3, |
420 | 'correct number of warnings on re-dumping static schema with load_classes' |
421 | or diag @{ $res->{warnings} }; |
422 | |
423 | is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', |
424 | 'load_classes preserved on re-dump'; |
425 | |
ecf930e6 |
426 | run_v6_tests($res); |
540a8149 |
427 | |
428 | # now upgrade the schema to use_namespaces |
429 | $res = run_loader( |
08e80fda |
430 | static => 1, |
540a8149 |
431 | use_namespaces => 1, |
432 | ); |
433 | $schema = $res->{schema}; |
434 | |
435 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
436 | 'correct warnings on upgrading to use_namespaces'; |
437 | |
438 | like $res->{warnings}[1], qr/dump completed/i, |
439 | 'correct warnings on upgrading to use_namespaces'; |
440 | |
441 | is scalar @{ $res->{warnings} }, 2, |
442 | 'correct number of warnings on upgrading to use_namespaces' |
443 | or diag @{ $res->{warnings} }; |
444 | |
ecf930e6 |
445 | run_v6_tests($res); |
540a8149 |
446 | |
08e80fda |
447 | my @schema_files = schema_files(); |
540a8149 |
448 | |
449 | is 1, (scalar @schema_files), |
08e80fda |
450 | "schema dir contains only 1 entry"; |
540a8149 |
451 | |
452 | like $schema_files[0], qr{/Result\z}, |
453 | "schema dir contains only a Result/ directory"; |
454 | |
455 | # check that custom content was preserved |
08e80fda |
456 | lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' } |
540a8149 |
457 | 'custom content was carried over during use_namespaces upgrade'; |
458 | |
08e80fda |
459 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, |
540a8149 |
460 | $res->{classes}{bazs} } |
461 | 'un-namespaced class names in custom content are translated'; |
462 | |
08e80fda |
463 | class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, |
540a8149 |
464 | 'custom content from un-namespaced Result loaded into static dump correctly'; |
465 | } |
466 | |
467 | # test a regular schema with default use_namespaces => 1, redump, and downgrade |
468 | # to load_classes |
469 | { |
08e80fda |
470 | my $res = run_loader(clean_dumpdir => 1, static => 1); |
540a8149 |
471 | |
472 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
473 | 'correct warnings on dumping static schema'; |
474 | |
475 | like $res->{warnings}[1], qr/dump completed/i, |
476 | 'correct warnings on dumping static schema'; |
477 | |
478 | is scalar @{ $res->{warnings} }, 2, |
479 | 'correct number of warnings on dumping static schema' |
480 | or diag @{ $res->{warnings} }; |
481 | |
ecf930e6 |
482 | run_v6_tests($res); |
540a8149 |
483 | |
484 | is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux', |
485 | 'defaults to use_namespaces on regular dump'; |
486 | |
08e80fda |
487 | add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result' }); |
540a8149 |
488 | |
489 | # test that with no use_namespaces option, use_namespaces is preserved |
08e80fda |
490 | $res = run_loader(static => 1); |
540a8149 |
491 | |
492 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
493 | 'correct warnings on re-dumping static schema'; |
494 | |
495 | like $res->{warnings}[1], qr/dump completed/i, |
496 | 'correct warnings on re-dumping static schema'; |
497 | |
498 | is scalar @{ $res->{warnings} }, 2, |
499 | 'correct number of warnings on re-dumping static schema' |
500 | or diag @{ $res->{warnings} }; |
501 | |
502 | is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux', |
503 | 'use_namespaces preserved on re-dump'; |
504 | |
ecf930e6 |
505 | run_v6_tests($res); |
540a8149 |
506 | |
507 | # now downgrade the schema to load_classes |
508 | $res = run_loader( |
08e80fda |
509 | static => 1, |
540a8149 |
510 | use_namespaces => 0, |
511 | ); |
08e80fda |
512 | my $schema = $res->{schema}; |
540a8149 |
513 | |
514 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
515 | 'correct warnings on downgrading to load_classes'; |
516 | |
517 | like $res->{warnings}[1], qr/dump completed/i, |
518 | 'correct warnings on downgrading to load_classes'; |
519 | |
520 | is scalar @{ $res->{warnings} }, 2, |
521 | 'correct number of warnings on downgrading to load_classes' |
522 | or diag @{ $res->{warnings} }; |
523 | |
ecf930e6 |
524 | run_v6_tests($res); |
540a8149 |
525 | |
526 | is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', |
527 | 'load_classes downgrade correct'; |
528 | |
ecf930e6 |
529 | is result_count(), 6, |
540a8149 |
530 | 'correct number of Results after upgrade and Result dir removed'; |
531 | |
08e80fda |
532 | ok ((not -d result_dir('Result')), |
540a8149 |
533 | 'Result dir was removed for load_classes downgrade'); |
534 | |
535 | # check that custom content was preserved |
08e80fda |
536 | lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' } |
540a8149 |
537 | 'custom content was carried over during load_classes downgrade'; |
538 | |
08e80fda |
539 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, |
540a8149 |
540 | $res->{classes}{bazs} } |
541 | 'namespaced class names in custom content are translated during load_classes '. |
542 | 'downgrade'; |
543 | |
08e80fda |
544 | class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, |
540a8149 |
545 | 'custom content from namespaced Result loaded into static dump correctly '. |
546 | 'during load_classes downgrade'; |
547 | } |
548 | |
549 | # test a regular schema with use_namespaces => 1 and a custom result_namespace |
550 | # downgraded to load_classes |
551 | { |
540a8149 |
552 | my $res = run_loader( |
08e80fda |
553 | clean_dumpdir => 1, |
554 | static => 1, |
540a8149 |
555 | result_namespace => 'MyResult', |
556 | ); |
557 | |
558 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
559 | 'correct warnings on dumping static schema'; |
560 | |
561 | like $res->{warnings}[1], qr/dump completed/i, |
562 | 'correct warnings on dumping static schema'; |
563 | |
564 | is scalar @{ $res->{warnings} }, 2, |
565 | 'correct number of warnings on dumping static schema' |
566 | or diag @{ $res->{warnings} }; |
567 | |
ecf930e6 |
568 | run_v6_tests($res); |
540a8149 |
569 | |
570 | is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', |
571 | 'defaults to use_namespaces and uses custom result_namespace'; |
572 | |
08e80fda |
573 | add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'MyResult' }); |
540a8149 |
574 | |
575 | # test that with no use_namespaces option, use_namespaces is preserved, and |
576 | # the custom result_namespace is preserved |
08e80fda |
577 | $res = run_loader(static => 1); |
540a8149 |
578 | |
579 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
580 | 'correct warnings on re-dumping static schema'; |
581 | |
582 | like $res->{warnings}[1], qr/dump completed/i, |
583 | 'correct warnings on re-dumping static schema'; |
584 | |
585 | is scalar @{ $res->{warnings} }, 2, |
586 | 'correct number of warnings on re-dumping static schema' |
587 | or diag @{ $res->{warnings} }; |
588 | |
589 | is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', |
590 | 'use_namespaces and custom result_namespace preserved on re-dump'; |
591 | |
ecf930e6 |
592 | run_v6_tests($res); |
540a8149 |
593 | |
594 | # now downgrade the schema to load_classes |
595 | $res = run_loader( |
08e80fda |
596 | static => 1, |
540a8149 |
597 | use_namespaces => 0, |
598 | ); |
08e80fda |
599 | my $schema = $res->{schema}; |
540a8149 |
600 | |
601 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
602 | 'correct warnings on downgrading to load_classes'; |
603 | |
604 | like $res->{warnings}[1], qr/dump completed/i, |
605 | 'correct warnings on downgrading to load_classes'; |
606 | |
607 | is scalar @{ $res->{warnings} }, 2, |
608 | 'correct number of warnings on downgrading to load_classes' |
609 | or diag @{ $res->{warnings} }; |
610 | |
ecf930e6 |
611 | run_v6_tests($res); |
540a8149 |
612 | |
613 | is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', |
614 | 'load_classes downgrade correct'; |
615 | |
ecf930e6 |
616 | is result_count(), 6, |
540a8149 |
617 | 'correct number of Results after upgrade and Result dir removed'; |
618 | |
08e80fda |
619 | ok ((not -d result_dir('MyResult')), |
540a8149 |
620 | 'Result dir was removed for load_classes downgrade'); |
621 | |
622 | # check that custom content was preserved |
08e80fda |
623 | lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' } |
540a8149 |
624 | 'custom content was carried over during load_classes downgrade'; |
625 | |
08e80fda |
626 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, |
540a8149 |
627 | $res->{classes}{bazs} } |
628 | 'namespaced class names in custom content are translated during load_classes '. |
629 | 'downgrade'; |
630 | |
08e80fda |
631 | class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, |
540a8149 |
632 | 'custom content from namespaced Result loaded into static dump correctly '. |
633 | 'during load_classes downgrade'; |
634 | } |
635 | |
77bf4429 |
636 | # rewrite from one result_namespace to another, with external content |
540a8149 |
637 | { |
08e80fda |
638 | clean_dumpdir(); |
639 | my $temp_dir = setup_load_external({ Quux => 'Baz', Bar => 'Foo' }, { result_namespace => 'Result' }); |
77bf4429 |
640 | |
08e80fda |
641 | my $res = run_loader(static => 1); |
540a8149 |
642 | |
643 | # add some custom content to a Result that will be replaced |
08e80fda |
644 | add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result', rel_name_map => { QuuxBaz => 'bazrel2' } }); |
540a8149 |
645 | |
646 | # Rewrite implicit 'Result' to 'MyResult' |
647 | $res = run_loader( |
08e80fda |
648 | static => 1, |
540a8149 |
649 | result_namespace => 'MyResult', |
650 | ); |
08e80fda |
651 | my $schema = $res->{schema}; |
540a8149 |
652 | |
653 | is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', |
654 | 'using new result_namespace'; |
655 | |
ecf930e6 |
656 | is result_count('MyResult'), 6, |
540a8149 |
657 | 'correct number of Results after rewritten result_namespace'; |
658 | |
08e80fda |
659 | ok ((not -d schema_dir('Result')), |
540a8149 |
660 | 'original Result dir was removed when rewriting result_namespace'); |
661 | |
662 | # check that custom content was preserved |
08e80fda |
663 | lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' } |
540a8149 |
664 | 'custom content was carried over when rewriting result_namespace'; |
665 | |
08e80fda |
666 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2, |
540a8149 |
667 | $res->{classes}{bazs} } |
668 | 'class names in custom content are translated when rewriting result_namespace'; |
669 | |
08e80fda |
670 | class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, |
540a8149 |
671 | 'custom content from namespaced Result loaded into static dump correctly '. |
672 | 'when rewriting result_namespace'; |
673 | |
674 | # Now rewrite 'MyResult' to 'Mtfnpy' |
675 | $res = run_loader( |
08e80fda |
676 | static => 1, |
540a8149 |
677 | result_namespace => 'Mtfnpy', |
678 | ); |
679 | $schema = $res->{schema}; |
680 | |
681 | is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Mtfnpy::Quux', |
682 | 'using new result_namespace'; |
683 | |
ecf930e6 |
684 | is result_count('Mtfnpy'), 6, |
540a8149 |
685 | 'correct number of Results after rewritten result_namespace'; |
686 | |
08e80fda |
687 | ok ((not -d result_dir('MyResult')), |
540a8149 |
688 | 'original Result dir was removed when rewriting result_namespace'); |
689 | |
77bf4429 |
690 | # check that custom and external content was preserved |
08e80fda |
691 | lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } |
692 | 'external content was carried over when rewriting result_namespace'; |
540a8149 |
693 | |
08e80fda |
694 | lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' } |
77bf4429 |
695 | 'custom content was carried over when rewriting result_namespace'; |
696 | |
08e80fda |
697 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2, |
540a8149 |
698 | $res->{classes}{bazs} } |
699 | 'class names in custom content are translated when rewriting result_namespace'; |
700 | |
08e80fda |
701 | lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, |
77bf4429 |
702 | $res->{classes}{bazs} } |
703 | 'class names in external content are translated when rewriting '. |
704 | 'result_namespace'; |
705 | |
08e80fda |
706 | lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel, |
77bf4429 |
707 | $res->{classes}{foos} } |
708 | 'class names in external content are translated when rewriting '. |
709 | 'result_namespace'; |
710 | |
08e80fda |
711 | class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, |
540a8149 |
712 | 'custom content from namespaced Result loaded into static dump correctly '. |
713 | 'when rewriting result_namespace'; |
77bf4429 |
714 | |
08e80fda |
715 | class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/, |
77bf4429 |
716 | 'external content from unsingularized Result loaded into static dump correctly'; |
540a8149 |
717 | } |
718 | |
08e80fda |
719 | # test upgrading a v4 schema, then check that the version string is correct |
68d49e50 |
720 | { |
08e80fda |
721 | clean_dumpdir(); |
68d49e50 |
722 | write_v4_schema_pm(); |
08e80fda |
723 | run_loader(static => 1); |
724 | my $res = run_loader(static => 1, naming => 'current'); |
68d49e50 |
725 | my $schema = $res->{schema}; |
726 | |
727 | my $file = $schema->_loader->_get_dump_filename($SCHEMA_CLASS); |
281d0f3e |
728 | my $code = slurp $file; |
68d49e50 |
729 | |
730 | my ($dumped_ver) = |
731 | $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m; |
732 | |
733 | is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION, |
734 | 'correct version dumped after upgrade of v4 static schema'; |
735 | } |
736 | |
b24cb177 |
737 | # Test upgrading an already singular result with custom content that refers to |
738 | # old class names. |
739 | { |
08e80fda |
740 | clean_dumpdir(); |
b24cb177 |
741 | write_v4_schema_pm(); |
08e80fda |
742 | my $res = run_loader(static => 1); |
743 | my $schema = $res->{schema}; |
b24cb177 |
744 | run_v4_tests($res); |
745 | |
746 | # add some custom content to a Result that will be replaced |
08e80fda |
747 | add_custom_content($schema, { Bar => 'Foos' }); |
b24cb177 |
748 | |
749 | # now upgrade the schema |
08e80fda |
750 | $res = run_loader(static => 1, naming => 'current'); |
b24cb177 |
751 | $schema = $res->{schema}; |
ecf930e6 |
752 | run_v6_tests($res); |
b24cb177 |
753 | |
754 | # check that custom content was preserved |
08e80fda |
755 | lives_and { is $schema->resultset('Bar')->find(1)->b_method, 'dongs' } |
b24cb177 |
756 | 'custom content was preserved from Result pre-upgrade'; |
757 | |
08e80fda |
758 | lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel, |
b24cb177 |
759 | $res->{classes}{foos} } |
760 | 'unsingularized class names in custom content from Result with unchanged ' . |
761 | 'name are translated'; |
762 | |
08e80fda |
763 | class_content_like $schema, $res->{classes}{bar}, qr/sub b_method { 'dongs' }/, |
b24cb177 |
764 | 'custom content from Result with unchanged name loaded into static dump ' . |
765 | 'correctly'; |
66afce69 |
766 | } |
767 | |
40914006 |
768 | # test creating static schema in v5 mode then upgrade to current with external |
769 | # content loaded |
770 | # XXX needs real load_external tests |
771 | { |
772 | clean_dumpdir(); |
773 | |
774 | write_v5_schema_pm(); |
775 | |
776 | my $res = run_loader(static => 1); |
777 | |
778 | like $res->{warnings}[0], qr/0.05003 static schema/, 'backcompat warning'; |
779 | |
780 | run_v5_tests($res); |
781 | |
782 | my $temp_dir = setup_load_external({ |
783 | Baz => 'StationsVisited', |
784 | StationsVisited => 'Quux', |
785 | }, { result_namespace => 'Result' }); |
786 | |
787 | add_custom_content($res->{schema}, { |
788 | Baz => 'StationsVisited', |
789 | }, { |
790 | result_namespace => 'Result', |
791 | rel_name_map => { BazStationsvisited => 'custom_content_rel' }, |
792 | }); |
793 | |
794 | $res = run_loader(static => 1, naming => 'current'); |
795 | my $schema = $res->{schema}; |
796 | |
797 | run_v6_tests($res); |
798 | |
799 | lives_and { is $schema->resultset('Baz')->find(1)->a_method, 'hlagh' } |
800 | 'external custom content loaded for v5 -> v6'; |
801 | |
802 | lives_and { isa_ok $schema->resultset('Baz')->find(1)->stationsvisitedrel, |
803 | $res->{classes}{stations_visited} } |
804 | 'external content rewritten for v5 -> v6'; |
805 | |
806 | lives_and { isa_ok $schema->resultset('Baz')->find(1)->custom_content_rel, |
807 | $res->{classes}{stations_visited} } |
808 | 'custom content rewritten for v5 -> v6'; |
809 | |
810 | lives_and { isa_ok $schema->resultset('StationVisited')->find(1)->quuxrel, |
811 | $res->{classes}{quuxs} } |
812 | 'external content rewritten for v5 -> v6 for upgraded Result class names'; |
813 | } |
814 | |
66afce69 |
815 | done_testing; |
816 | |
ffc705f3 |
817 | END { |
818 | rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}; |
819 | } |
a0e0a56a |
820 | |
08e80fda |
821 | sub clean_dumpdir { |
822 | rmtree $DUMP_DIR; |
823 | make_path $DUMP_DIR; |
824 | } |
825 | |
dbe9e0f7 |
826 | sub run_loader { |
827 | my %loader_opts = @_; |
828 | |
08e80fda |
829 | $loader_opts{dump_directory} = $DUMP_DIR if delete $loader_opts{static}; |
830 | |
831 | clean_dumpdir() if delete $loader_opts{clean_dumpdir}; |
832 | |
dbe9e0f7 |
833 | eval { |
834 | foreach my $source_name ($SCHEMA_CLASS->clone->sources) { |
835 | Class::Unload->unload("${SCHEMA_CLASS}::${source_name}"); |
836 | } |
837 | |
838 | Class::Unload->unload($SCHEMA_CLASS); |
839 | }; |
840 | undef $@; |
841 | |
c496748b |
842 | my @connect_info = $make_dbictest_db_with_unique::dsn; |
dbe9e0f7 |
843 | my @loader_warnings; |
844 | local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); }; |
845 | eval qq{ |
846 | package $SCHEMA_CLASS; |
847 | use base qw/DBIx::Class::Schema::Loader/; |
848 | |
849 | __PACKAGE__->loader_options(\%loader_opts); |
850 | __PACKAGE__->connection(\@connect_info); |
851 | }; |
852 | |
853 | ok(!$@, "Loader initialization") or diag $@; |
854 | |
855 | my $schema = $SCHEMA_CLASS->clone; |
856 | my (%monikers, %classes); |
857 | foreach my $source_name ($schema->sources) { |
858 | my $table_name = $schema->source($source_name)->from; |
859 | $monikers{$table_name} = $source_name; |
d073740e |
860 | $classes{$table_name} = $schema->source($source_name)->result_class; |
dbe9e0f7 |
861 | } |
862 | |
863 | return { |
864 | schema => $schema, |
865 | warnings => \@loader_warnings, |
866 | monikers => \%monikers, |
867 | classes => \%classes, |
868 | }; |
869 | } |
870 | |
30a4c064 |
871 | sub write_v4_schema_pm { |
a4b94090 |
872 | my %opts = @_; |
873 | |
30a4c064 |
874 | (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//; |
875 | rmtree $schema_dir; |
876 | make_path $schema_dir; |
877 | my $schema_pm = "$schema_dir/Schema.pm"; |
878 | open my $fh, '>', $schema_pm or die $!; |
a4b94090 |
879 | if (not $opts{use_namespaces}) { |
880 | print $fh <<'EOF'; |
30a4c064 |
881 | package DBIXCSL_Test::Schema; |
882 | |
883 | use strict; |
884 | use warnings; |
885 | |
886 | use base 'DBIx::Class::Schema'; |
887 | |
888 | __PACKAGE__->load_classes; |
889 | |
890 | |
891 | # Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25 |
892 | # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog |
893 | |
894 | |
895 | # You can replace this text with custom content, and it will be preserved on regeneration |
896 | 1; |
897 | EOF |
a4b94090 |
898 | } |
899 | else { |
900 | print $fh <<'EOF'; |
901 | package DBIXCSL_Test::Schema; |
902 | |
903 | use strict; |
904 | use warnings; |
905 | |
906 | use base 'DBIx::Class::Schema'; |
907 | |
908 | __PACKAGE__->load_namespaces; |
909 | |
910 | |
911 | # Created by DBIx::Class::Schema::Loader v0.04006 @ 2010-01-12 16:04:12 |
912 | # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:d3wRVsHBNisyhxeaWJZcZQ |
913 | |
914 | |
915 | # You can replace this text with custom content, and it will be preserved on |
916 | # regeneration |
917 | 1; |
918 | EOF |
919 | } |
30a4c064 |
920 | } |
921 | |
ecf930e6 |
922 | sub write_v5_schema_pm { |
923 | my %opts = @_; |
924 | |
925 | (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//; |
926 | rmtree $schema_dir; |
927 | make_path $schema_dir; |
928 | my $schema_pm = "$schema_dir/Schema.pm"; |
929 | open my $fh, '>', $schema_pm or die $!; |
930 | if (exists $opts{use_namespaces} && $opts{use_namespaces} == 0) { |
931 | print $fh <<'EOF'; |
932 | package DBIXCSL_Test::Schema; |
933 | |
934 | # Created by DBIx::Class::Schema::Loader |
935 | # DO NOT MODIFY THE FIRST PART OF THIS FILE |
936 | |
937 | use strict; |
938 | use warnings; |
939 | |
940 | use base 'DBIx::Class::Schema'; |
941 | |
942 | __PACKAGE__->load_classes; |
943 | |
944 | |
945 | # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-27 17:07:37 |
946 | # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:LIzC/LT5IYvWpgusfbqMrg |
947 | |
948 | |
949 | # You can replace this text with custom content, and it will be preserved on regeneration |
950 | 1; |
951 | EOF |
952 | } |
953 | else { |
954 | print $fh <<'EOF'; |
955 | package DBIXCSL_Test::Schema; |
956 | |
957 | # Created by DBIx::Class::Schema::Loader |
958 | # DO NOT MODIFY THE FIRST PART OF THIS FILE |
959 | |
960 | use strict; |
961 | use warnings; |
962 | |
963 | use base 'DBIx::Class::Schema'; |
964 | |
40914006 |
965 | __PACKAGE__->load_namespaces; |
ecf930e6 |
966 | |
967 | |
40914006 |
968 | # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-29 19:44:52 |
969 | # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:D+MYxtGxz97Ghvido5DTEg |
ecf930e6 |
970 | |
971 | |
972 | # You can replace this text with custom content, and it will be preserved on regeneration |
973 | 1; |
974 | EOF |
975 | } |
976 | } |
977 | |
dbe9e0f7 |
978 | sub run_v4_tests { |
979 | my $res = shift; |
980 | my $schema = $res->{schema}; |
981 | |
ecf930e6 |
982 | is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited email/} ], |
983 | [qw/Foos Bar Bazs Quuxs StationsVisited Email/], |
dbe9e0f7 |
984 | 'correct monikers in 0.04006 mode'; |
985 | |
986 | isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }), |
987 | $res->{classes}{bar}, |
988 | 'found a bar'); |
989 | |
990 | isa_ok eval { $bar->foo_id }, $res->{classes}{foos}, |
991 | 'correct rel name in 0.04006 mode'; |
992 | |
993 | ok my $baz = eval { $schema->resultset('Bazs')->find(1) }; |
994 | |
995 | isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet', |
996 | 'correct rel type and name for UNIQUE FK in 0.04006 mode'; |
ecf930e6 |
997 | |
998 | ok my $foo = eval { $schema->resultset('Foos')->find(1) }; |
999 | |
1000 | isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet', |
1001 | 'correct rel name inflection in 0.04006 mode'; |
dbe9e0f7 |
1002 | } |
1003 | |
1004 | sub run_v5_tests { |
1005 | my $res = shift; |
1006 | my $schema = $res->{schema}; |
1007 | |
ecf930e6 |
1008 | is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited email/} ], |
1009 | [qw/Foo Bar Baz Quux StationsVisited Email/], |
40914006 |
1010 | 'correct monikers in v5 mode'; |
ecf930e6 |
1011 | |
1012 | ok my $bar = eval { $schema->resultset('Bar')->find(1) }; |
1013 | |
1014 | isa_ok eval { $bar->foo }, $res->{classes}{foos}, |
1015 | 'correct rel name in v5 mode'; |
1016 | |
1017 | ok my $baz = eval { $schema->resultset('Baz')->find(1) }; |
1018 | |
1019 | isa_ok eval { $baz->quux }, $res->{classes}{quuxs}, |
1020 | 'correct rel type and name for UNIQUE FK in v5 mode'; |
1021 | |
1022 | ok my $foo = eval { $schema->resultset('Foo')->find(1) }; |
1023 | |
1024 | isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet', |
1025 | 'correct rel name inflection in v5 mode'; |
1026 | } |
1027 | |
1028 | sub run_v6_tests { |
1029 | my $res = shift; |
1030 | my $schema = $res->{schema}; |
1031 | |
1032 | is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited email/} ], |
1033 | [qw/Foo Bar Baz Quux StationVisited Email/], |
dbe9e0f7 |
1034 | 'correct monikers in current mode'; |
1035 | |
1036 | ok my $bar = eval { $schema->resultset('Bar')->find(1) }; |
1037 | |
1038 | isa_ok eval { $bar->foo }, $res->{classes}{foos}, |
1039 | 'correct rel name in current mode'; |
1040 | |
1041 | ok my $baz = eval { $schema->resultset('Baz')->find(1) }; |
1042 | |
1043 | isa_ok eval { $baz->quux }, $res->{classes}{quuxs}, |
1044 | 'correct rel type and name for UNIQUE FK in current mode'; |
ecf930e6 |
1045 | |
1046 | ok my $foo = eval { $schema->resultset('Foo')->find(1) }; |
1047 | |
1048 | isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet', |
1049 | 'correct rel name inflection in current mode'; |
dbe9e0f7 |
1050 | } |
08e80fda |
1051 | |
1052 | { |
1053 | package DBICSL::Test::TempExtDir; |
1054 | |
1055 | use overload '""' => sub { ${$_[0]} }; |
1056 | |
1057 | sub DESTROY { |
1058 | pop @INC; |
ca12f6c9 |
1059 | File::Path::rmtree ${$_[0]}; |
08e80fda |
1060 | } |
1061 | } |
1062 | |
1063 | sub setup_load_external { |
1064 | my ($rels, $opts) = @_; |
1065 | |
1066 | my $temp_dir = tempdir(CLEANUP => 1); |
1067 | push @INC, $temp_dir; |
1068 | |
1069 | my $external_result_dir = join '/', $temp_dir, (split /::/, $SCHEMA_CLASS), |
1070 | ($opts->{result_namespace} || ()); |
1071 | |
1072 | make_path $external_result_dir; |
1073 | |
1074 | while (my ($from, $to) = each %$rels) { |
1075 | write_ext_result($external_result_dir, $from, $to, $opts); |
1076 | } |
1077 | |
1078 | my $guard = bless \$temp_dir, 'DBICSL::Test::TempExtDir'; |
1079 | |
1080 | return $guard; |
1081 | } |
1082 | |
1083 | sub write_ext_result { |
1084 | my ($result_dir, $from, $to, $opts) = @_; |
1085 | |
1086 | my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to); |
1087 | my $from_class = _qualify_class($from, $opts->{result_namespace}); |
1088 | my $to_class = _qualify_class($to, $opts->{result_namespace}); |
1089 | my $condition = _rel_condition($from, $to); |
1090 | |
1091 | IO::File->new(">$result_dir/${from}.pm")->print(<<"EOF"); |
1092 | package ${from_class}; |
1093 | sub a_method { 'hlagh' } |
1094 | |
1095 | __PACKAGE__->has_one('$relname', '$to_class', |
1096 | { $condition }); |
1097 | |
1098 | 1; |
1099 | EOF |
1100 | |
1101 | return $relname; |
1102 | } |
1103 | |
1104 | sub _relname { |
1105 | my $to = shift; |
1106 | |
1107 | return Lingua::EN::Inflect::Number::to_S(lc $to) . 'rel'; |
1108 | } |
1109 | |
1110 | sub _qualify_class { |
1111 | my ($class, $result_namespace) = @_; |
1112 | |
1113 | return $SCHEMA_CLASS . '::' |
1114 | . ($result_namespace ? $result_namespace . '::' : '') |
1115 | . $class; |
1116 | } |
1117 | |
1118 | sub _rel_key { |
1119 | my ($from, $to) = @_; |
1120 | |
1121 | return join '', map ucfirst(Lingua::EN::Inflect::Number::to_S(lc($_))), $from, $to; |
1122 | } |
1123 | |
1124 | sub _rel_condition { |
1125 | my ($from, $to) = @_; |
1126 | |
1127 | return +{ |
1128 | QuuxBaz => q{'foreign.baz_num' => 'self.baz_id'}, |
1129 | BarFoo => q{'foreign.fooid' => 'self.foo_id'}, |
40914006 |
1130 | BazStationsvisited => q{'foreign.id' => 'self.stations_visited_id'}, |
1131 | StationsvisitedQuux => q{'foreign.quuxid' => 'self.quuxs_id'}, |
08e80fda |
1132 | }->{_rel_key($from, $to)}; |
1133 | } |
1134 | |
1135 | sub class_content_like { |
1136 | my ($schema, $class, $re, $test_name) = @_; |
1137 | |
1138 | my $file = $schema->_loader->_get_dump_filename($class); |
1139 | my $code = slurp $file; |
1140 | |
1141 | like $code, $re, $test_name; |
1142 | } |
1143 | |
1144 | sub add_custom_content { |
1145 | my ($schema, $rels, $opts) = @_; |
1146 | |
1147 | while (my ($from, $to) = each %$rels) { |
1148 | my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to); |
1149 | my $from_class = _qualify_class($from, $opts->{result_namespace}); |
1150 | my $to_class = _qualify_class($to, $opts->{result_namespace}); |
1151 | my $condition = _rel_condition($from, $to); |
1152 | |
1153 | my $content = <<"EOF"; |
1154 | package ${from_class}; |
1155 | sub b_method { 'dongs' } |
1156 | |
1157 | __PACKAGE__->has_one('$relname', '$to_class', |
1158 | { $condition }); |
1159 | |
1160 | 1; |
1161 | EOF |
1162 | |
1163 | _write_custom_content($schema, $from_class, $content); |
1164 | } |
1165 | } |
1166 | |
1167 | sub _write_custom_content { |
1168 | my ($schema, $class, $content) = @_; |
1169 | |
1170 | my $pm = $schema->_loader->_get_dump_filename($class); |
1171 | { |
1172 | local ($^I, @ARGV) = ('.bak', $pm); |
1173 | while (<>) { |
1174 | if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { |
1175 | print; |
1176 | print $content; |
1177 | } |
1178 | else { |
1179 | print; |
1180 | } |
1181 | } |
1182 | close ARGV; |
1183 | unlink "${pm}.bak" or die $^E; |
1184 | } |
1185 | } |
1186 | |
1187 | sub result_count { |
1188 | my $path = shift || ''; |
1189 | |
1190 | my $dir = result_dir($path); |
1191 | |
1192 | my $file_count =()= glob "$dir/*"; |
1193 | |
1194 | return $file_count; |
1195 | } |
1196 | |
1197 | sub result_files { |
1198 | my $path = shift || ''; |
1199 | |
1200 | my $dir = result_dir($path); |
1201 | |
1202 | return glob "$dir/*"; |
1203 | } |
1204 | |
1205 | sub schema_files { result_files(@_) } |
1206 | |
1207 | sub result_dir { |
1208 | my $path = shift || ''; |
1209 | |
1210 | (my $dir = "$DUMP_DIR/$SCHEMA_CLASS/$path") =~ s{::}{/}g; |
1211 | $dir =~ s{/+\z}{}; |
1212 | |
1213 | return $dir; |
1214 | } |
1215 | |
1216 | sub schema_dir { result_dir(@_) } |
ecf930e6 |
1217 | |
1218 | # vim:et sts=4 sw=4 tw=0: |