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