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