5 use File::Path qw/rmtree make_path/;
7 use File::Temp qw/tempfile tempdir/;
9 use File::Slurp 'slurp';
10 use DBIx::Class::Schema::Loader ();
11 use Lingua::EN::Inflect::Number ();
13 use make_dbictest_db_with_unique;
15 my $DUMP_DIR = './t/_common_dump';
17 my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema';
21 sub class_content_like;
23 # test dynamic schema in 0.04006 mode
25 my $res = run_loader();
26 my $warning = $res->{warnings}[0];
28 like $warning, qr/dynamic schema/i,
29 'dynamic schema in backcompat mode detected';
30 like $warning, qr/run in 0\.04006 mode/i,
31 'dynamic schema in 0.04006 mode warning';
32 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
33 'warning refers to upgrading doc';
38 # setting naming accessor on dynamic schema should disable warning (even when
39 # we're setting it to 'v4' .)
41 my $res = run_loader(naming => 'v4');
42 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
46 # test upgraded dynamic schema
48 my $res = run_loader(naming => 'current');
49 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
53 # test upgraded dynamic schema with external content loaded
55 my $temp_dir = setup_load_external({
60 my $res = run_loader(naming => 'current');
61 my $schema = $res->{schema};
63 is scalar @{ $res->{warnings} }, 1,
64 'correct nummber of warnings for upgraded dynamic schema with external ' .
65 'content for unsingularized Result.';
67 my $warning = $res->{warnings}[0];
68 like $warning, qr/Detected external content/i,
69 'detected external content warning';
71 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
72 'external custom content for unsingularized Result was loaded by upgraded ' .
75 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
76 $res->{classes}{bazs} }
77 'unsingularized class names in external content are translated';
79 lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'hlagh' }
80 'external content from unchanged Result class';
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';
90 # test upgraded dynamic schema with use_namespaces with external content loaded
92 my $temp_dir = setup_load_external({
97 my $res = run_loader(naming => 'current', use_namespaces => 1);
98 my $schema = $res->{schema};
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.';
104 my $warning = $res->{warnings}[0];
105 like $warning, qr/Detected external content/i,
106 'detected external content warning';
108 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
109 'external custom content for unsingularized Result was loaded by upgraded ' .
112 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
113 $res->{classes}{bazs} }
114 'unsingularized class names in external content are translated';
116 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
117 $res->{classes}{foos} }
118 'unsingularized class names in external content from unchanged Result class ' .
119 'names are translated';
124 # test upgraded static schema with external content loaded
128 my $temp_dir = setup_load_external({
133 write_v4_schema_pm();
135 my $res = run_loader(static => 1, naming => 'current');
136 my $schema = $res->{schema};
140 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
141 'external custom content for unsingularized Result was loaded by upgraded ' .
144 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
145 $res->{classes}{bazs} }
146 'unsingularized class names in external content are translated';
148 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
149 $res->{classes}{foos} }
150 'unsingularized class names in external content from unchanged Result class ' .
151 'names are translated in static schema';
153 class_content_like $schema, $res->{classes}{quuxs}, qr/package ${SCHEMA_CLASS}::Quux;/,
154 'package line translated correctly from external custom content in static dump';
156 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
157 'external custom content loaded into static dump correctly';
160 # test running against v4 schema without upgrade, twice, then upgrade
163 write_v4_schema_pm();
164 my $res = run_loader(static => 1);
165 my $warning = $res->{warnings}[1];
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';
174 is scalar @{ $res->{warnings} }, 4,
175 'correct number of warnings for static schema in backcompat mode';
179 add_custom_content($res->{schema}, {
183 # Rerun the loader in backcompat mode to make sure it's still in backcompat
185 $res = run_loader(static => 1);
188 # now upgrade the schema
194 my $schema = $res->{schema};
196 like $res->{warnings}[0], qr/Dumping manual schema/i,
197 'correct warnings on upgrading static schema (with "naming" set)';
199 like $res->{warnings}[1], qr/dump completed/i,
200 'correct warnings on upgrading static schema (with "naming" set)';
202 is scalar @{ $res->{warnings} }, 2,
203 'correct number of warnings on upgrading static schema (with "naming" set)'
204 or diag @{ $res->{warnings} };
208 is result_count('Result'), $RESULT_COUNT,
209 'un-singularized results were replaced during upgrade';
211 # check that custom content was preserved
212 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
213 'custom content was carried over from un-singularized Result';
215 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
216 $res->{classes}{bazs} }
217 'unsingularized class names in custom content are translated';
219 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
220 'custom content from unsingularized Result loaded into static dump correctly';
223 # test running against v4 schema without upgrade, then upgrade with
224 # use_namespaces not explicitly set
227 write_v4_schema_pm();
228 my $res = run_loader(static => 1);
229 my $warning = $res->{warnings}[1];
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';
238 is scalar @{ $res->{warnings} }, 4,
239 'correct number of warnings for static schema in backcompat mode';
243 add_custom_content($res->{schema}, {
247 # now upgrade the schema
252 my $schema = $res->{schema};
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)';
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)';
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)';
266 is scalar @{ $res->{warnings} }, 3,
267 'correct number of warnings on upgrading static schema (with "naming" set)'
268 or diag @{ $res->{warnings} };
272 is result_count(), $RESULT_COUNT,
273 'un-singularized results were replaced during upgrade';
275 # check that custom content was preserved
276 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
277 'custom content was carried over from un-singularized Result';
279 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
280 $res->{classes}{bazs} }
281 'unsingularized class names in custom content are translated';
283 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
284 'custom content from unsingularized Result loaded into static dump correctly';
287 # test running against v4 schema with load_namespaces, upgrade to current but
288 # downgrade to load_classes, with external content
292 my $temp_dir = setup_load_external({
295 }, { result_namespace => 'Result' });
297 write_v4_schema_pm(use_namespaces => 1);
299 my $res = run_loader(static => 1);
300 my $warning = $res->{warnings}[0];
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';
309 is scalar @{ $res->{warnings} }, 3,
310 'correct number of warnings for static schema in backcompat mode';
314 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quuxs',
315 'use_namespaces in backcompat mode';
317 add_custom_content($res->{schema}, {
320 result_namespace => 'Result',
321 rel_name_map => { QuuxBaz => 'bazrel2' },
324 # now upgrade the schema to current but downgrade to load_classes
330 my $schema = $res->{schema};
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)';
336 like $res->{warnings}[1], qr/dump completed/i,
337 'correct warnings on upgrading static schema (with "naming" set and ' .
338 'use_namespaces => 0)';
340 is scalar @{ $res->{warnings} }, 2,
341 'correct number of warnings on upgrading static schema (with "naming" set)'
342 or diag @{ $res->{warnings} };
346 is result_count(), $RESULT_COUNT,
347 'un-singularized results were replaced during upgrade and Result dir removed';
349 ok ((not -d result_dir('Result')),
350 'Result dir was removed for load_classes downgrade');
352 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
353 'load_classes in upgraded mode';
355 # check that custom and external content was preserved
356 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
357 'custom content was carried over from un-singularized Result';
359 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
360 'external content was carried over from un-singularized Result';
362 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
363 $res->{classes}{bazs} }
364 'unsingularized class names in custom content are translated';
366 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
367 $res->{classes}{bazs} }
368 'unsingularized class names in external content are translated';
370 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
371 $res->{classes}{foos} }
372 'unsingularized class names in external content from unchanged Result class ' .
373 'names are translated in static schema';
375 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
376 'external content from unsingularized Result loaded into static dump correctly';
378 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
379 'custom content from unsingularized Result loaded into static dump correctly';
382 # test a regular schema with use_namespaces => 0 upgraded to
383 # use_namespaces => 1
385 my $res = run_loader(
392 like $res->{warnings}[0], qr/Dumping manual schema/i,
393 'correct warnings on dumping static schema with use_namespaces => 0';
395 like $res->{warnings}[1], qr/dump completed/i,
396 'correct warnings on dumping static schema with use_namespaces => 0';
398 is scalar @{ $res->{warnings} }, 2,
399 'correct number of warnings on dumping static schema with use_namespaces => 0'
400 or diag @{ $res->{warnings} };
404 my $schema = $res->{schema};
405 add_custom_content($res->{schema}, {
409 # test that with no use_namespaces option, there is a warning and
410 # load_classes is preserved
411 $res = run_loader(static => 1, naming => 'current');
413 like $res->{warnings}[0], qr/load_classes/i,
414 'correct warnings on re-dumping static schema with load_classes';
416 like $res->{warnings}[1], qr/Dumping manual schema/i,
417 'correct warnings on re-dumping static schema with load_classes';
419 like $res->{warnings}[2], qr/dump completed/i,
420 'correct warnings on re-dumping static schema with load_classes';
422 is scalar @{ $res->{warnings} }, 3,
423 'correct number of warnings on re-dumping static schema with load_classes'
424 or diag @{ $res->{warnings} };
426 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
427 'load_classes preserved on re-dump';
431 # now upgrade the schema to use_namespaces
437 $schema = $res->{schema};
439 like $res->{warnings}[0], qr/Dumping manual schema/i,
440 'correct warnings on upgrading to use_namespaces';
442 like $res->{warnings}[1], qr/dump completed/i,
443 'correct warnings on upgrading to use_namespaces';
445 is scalar @{ $res->{warnings} }, 2,
446 'correct number of warnings on upgrading to use_namespaces'
447 or diag @{ $res->{warnings} };
451 my @schema_files = schema_files();
453 is 1, (scalar @schema_files),
454 "schema dir contains only 1 entry";
456 like $schema_files[0], qr{/Result\z},
457 "schema dir contains only a Result/ directory";
459 # check that custom content was preserved
460 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
461 'custom content was carried over during use_namespaces upgrade';
463 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
464 $res->{classes}{bazs} }
465 'un-namespaced class names in custom content are translated';
467 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
468 'custom content from un-namespaced Result loaded into static dump correctly';
471 # test a regular schema with default use_namespaces => 1, redump, and downgrade
474 my $res = run_loader(clean_dumpdir => 1, static => 1, naming => 'current');
476 like $res->{warnings}[0], qr/Dumping manual schema/i,
477 'correct warnings on dumping static schema';
479 like $res->{warnings}[1], qr/dump completed/i,
480 'correct warnings on dumping static schema';
482 is scalar @{ $res->{warnings} }, 2,
483 'correct number of warnings on dumping static schema'
484 or diag @{ $res->{warnings} };
488 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
489 'defaults to use_namespaces on regular dump';
491 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result' });
493 # test that with no use_namespaces option, use_namespaces is preserved
494 $res = run_loader(static => 1, naming => 'current');
496 like $res->{warnings}[0], qr/Dumping manual schema/i,
497 'correct warnings on re-dumping static schema';
499 like $res->{warnings}[1], qr/dump completed/i,
500 'correct warnings on re-dumping static schema';
502 is scalar @{ $res->{warnings} }, 2,
503 'correct number of warnings on re-dumping static schema'
504 or diag @{ $res->{warnings} };
506 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
507 'use_namespaces preserved on re-dump';
511 # now downgrade the schema to load_classes
517 my $schema = $res->{schema};
519 like $res->{warnings}[0], qr/Dumping manual schema/i,
520 'correct warnings on downgrading to load_classes';
522 like $res->{warnings}[1], qr/dump completed/i,
523 'correct warnings on downgrading to load_classes';
525 is scalar @{ $res->{warnings} }, 2,
526 'correct number of warnings on downgrading to load_classes'
527 or diag @{ $res->{warnings} };
531 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
532 'load_classes downgrade correct';
534 is result_count(), $RESULT_COUNT,
535 'correct number of Results after upgrade and Result dir removed';
537 ok ((not -d result_dir('Result')),
538 'Result dir was removed for load_classes downgrade');
540 # check that custom content was preserved
541 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
542 'custom content was carried over during load_classes downgrade';
544 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
545 $res->{classes}{bazs} }
546 'namespaced class names in custom content are translated during load_classes '.
549 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
550 'custom content from namespaced Result loaded into static dump correctly '.
551 'during load_classes downgrade';
554 # test a regular schema with use_namespaces => 1 and a custom result_namespace
555 # downgraded to load_classes
557 my $res = run_loader(
560 result_namespace => 'MyResult',
564 like $res->{warnings}[0], qr/Dumping manual schema/i,
565 'correct warnings on dumping static schema';
567 like $res->{warnings}[1], qr/dump completed/i,
568 'correct warnings on dumping static schema';
570 is scalar @{ $res->{warnings} }, 2,
571 'correct number of warnings on dumping static schema'
572 or diag @{ $res->{warnings} };
576 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
577 'defaults to use_namespaces and uses custom result_namespace';
579 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'MyResult' });
581 # test that with no use_namespaces option, use_namespaces is preserved, and
582 # the custom result_namespace is preserved
583 $res = run_loader(static => 1, naming => 'current');
585 like $res->{warnings}[0], qr/Dumping manual schema/i,
586 'correct warnings on re-dumping static schema';
588 like $res->{warnings}[1], qr/dump completed/i,
589 'correct warnings on re-dumping static schema';
591 is scalar @{ $res->{warnings} }, 2,
592 'correct number of warnings on re-dumping static schema'
593 or diag @{ $res->{warnings} };
595 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
596 'use_namespaces and custom result_namespace preserved on re-dump';
600 # now downgrade the schema to load_classes
606 my $schema = $res->{schema};
608 like $res->{warnings}[0], qr/Dumping manual schema/i,
609 'correct warnings on downgrading to load_classes';
611 like $res->{warnings}[1], qr/dump completed/i,
612 'correct warnings on downgrading to load_classes';
614 is scalar @{ $res->{warnings} }, 2,
615 'correct number of warnings on downgrading to load_classes'
616 or diag @{ $res->{warnings} };
620 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
621 'load_classes downgrade correct';
623 is result_count(), $RESULT_COUNT,
624 'correct number of Results after upgrade and Result dir removed';
626 ok ((not -d result_dir('MyResult')),
627 'Result dir was removed for load_classes downgrade');
629 # check that custom content was preserved
630 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
631 'custom content was carried over during load_classes downgrade';
633 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
634 $res->{classes}{bazs} }
635 'namespaced class names in custom content are translated during load_classes '.
638 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
639 'custom content from namespaced Result loaded into static dump correctly '.
640 'during load_classes downgrade';
643 # rewrite from one result_namespace to another, with external content
646 my $temp_dir = setup_load_external({ Quux => 'Baz', Bar => 'Foo' }, { result_namespace => 'Result' });
648 my $res = run_loader(static => 1, naming => 'current');
650 # add some custom content to a Result that will be replaced
651 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result', rel_name_map => { QuuxBaz => 'bazrel2' } });
653 # Rewrite implicit 'Result' to 'MyResult'
656 result_namespace => 'MyResult',
659 my $schema = $res->{schema};
661 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
662 'using new result_namespace';
664 is result_count('MyResult'), $RESULT_COUNT,
665 'correct number of Results after rewritten result_namespace';
667 ok ((not -d schema_dir('Result')),
668 'original Result dir was removed when rewriting result_namespace');
670 # check that custom content was preserved
671 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
672 'custom content was carried over when rewriting result_namespace';
674 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
675 $res->{classes}{bazs} }
676 'class names in custom content are translated when rewriting result_namespace';
678 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
679 'custom content from namespaced Result loaded into static dump correctly '.
680 'when rewriting result_namespace';
682 # Now rewrite 'MyResult' to 'Mtfnpy'
685 result_namespace => 'Mtfnpy',
688 $schema = $res->{schema};
690 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Mtfnpy::Quux',
691 'using new result_namespace';
693 is result_count('Mtfnpy'), $RESULT_COUNT,
694 'correct number of Results after rewritten result_namespace';
696 ok ((not -d result_dir('MyResult')),
697 'original Result dir was removed when rewriting result_namespace');
699 # check that custom and external content was preserved
700 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
701 'external content was carried over when rewriting result_namespace';
703 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
704 'custom content was carried over when rewriting result_namespace';
706 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
707 $res->{classes}{bazs} }
708 'class names in custom content are translated when rewriting result_namespace';
710 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
711 $res->{classes}{bazs} }
712 'class names in external content are translated when rewriting '.
715 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
716 $res->{classes}{foos} }
717 'class names in external content are translated when rewriting '.
720 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
721 'custom content from namespaced Result loaded into static dump correctly '.
722 'when rewriting result_namespace';
724 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
725 'external content from unsingularized Result loaded into static dump correctly';
728 # test upgrading a v4 schema, then check that the version string is correct
731 write_v4_schema_pm();
732 run_loader(static => 1);
733 my $res = run_loader(static => 1, naming => 'current');
734 my $schema = $res->{schema};
736 my $file = $schema->_loader->_get_dump_filename($SCHEMA_CLASS);
737 my $code = slurp $file;
740 $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m;
742 is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION,
743 'correct version dumped after upgrade of v4 static schema';
746 # Test upgrading an already singular result with custom content that refers to
750 write_v4_schema_pm();
751 my $res = run_loader(static => 1);
752 my $schema = $res->{schema};
755 # add some custom content to a Result that will be replaced
756 add_custom_content($schema, { Bar => 'Foos' });
758 # now upgrade the schema
759 $res = run_loader(static => 1, naming => 'current');
760 $schema = $res->{schema};
763 # check that custom content was preserved
764 lives_and { is $schema->resultset('Bar')->find(1)->b_method, 'dongs' }
765 'custom content was preserved from Result pre-upgrade';
767 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
768 $res->{classes}{foos} }
769 'unsingularized class names in custom content from Result with unchanged ' .
770 'name are translated';
772 class_content_like $schema, $res->{classes}{bar}, qr/sub b_method { 'dongs' }/,
773 'custom content from Result with unchanged name loaded into static dump ' .
777 # test creating static schema in v5 mode then upgrade to current with external
782 write_v5_schema_pm();
784 my $res = run_loader(static => 1);
786 like $res->{warnings}[0], qr/0.05003 static schema/, 'backcompat warning';
790 my $temp_dir = setup_load_external({
791 Baz => 'StationsVisited',
792 StationsVisited => 'Quux',
793 }, { result_namespace => 'Result' });
795 add_custom_content($res->{schema}, {
796 Baz => 'StationsVisited',
798 result_namespace => 'Result',
799 rel_name_map => { BazStationsvisited => 'custom_content_rel' },
802 $res = run_loader(static => 1, naming => 'current');
803 my $schema = $res->{schema};
807 lives_and { is $schema->resultset('Baz')->find(1)->a_method, 'hlagh' }
808 'external custom content loaded for v5 -> v6';
810 lives_and { isa_ok $schema->resultset('Baz')->find(1)->stationsvisitedrel,
811 $res->{classes}{stations_visited} }
812 'external content rewritten for v5 -> v6';
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';
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';
823 # test creating static schema in v6 mode then upgrade to current with external
828 write_v6_schema_pm();
830 my $res = run_loader(static => 1);
832 like $res->{warnings}[0], qr/0.06001 static schema/, 'backcompat warning';
836 my $temp_dir = setup_load_external({
837 Routechange => 'Quux',
838 }, { result_namespace => 'Result' });
840 add_custom_content($res->{schema}, {
841 Routechange => 'Quux',
843 result_namespace => 'Result',
844 rel_name_map => { RoutechangeQuux => 'custom_content_rel' },
847 $res = run_loader(static => 1, naming => 'current');
848 my $schema = $res->{schema};
852 lives_and { is $schema->resultset('RouteChange')->find(1)->a_method, 'hlagh' }
853 'external custom content loaded for v6 -> v7';
855 lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->quuxrel,
856 $res->{classes}{quuxs} }
857 'external content rewritten for v6 -> v7';
859 lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->custom_content_rel,
860 $res->{classes}{quuxs} }
861 'custom content rewritten for v6 -> v7';
867 rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
876 my %loader_opts = @_;
878 $loader_opts{dump_directory} = $DUMP_DIR if delete $loader_opts{static};
879 $loader_opts{preserve_case} = 1 if $loader_opts{naming} && $loader_opts{naming} eq 'current';
881 clean_dumpdir() if delete $loader_opts{clean_dumpdir};
884 foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
885 Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
888 Class::Unload->unload($SCHEMA_CLASS);
892 my @connect_info = $make_dbictest_db_with_unique::dsn;
894 local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); };
896 package $SCHEMA_CLASS;
897 use base qw/DBIx::Class::Schema::Loader/;
899 __PACKAGE__->loader_options(\%loader_opts);
900 __PACKAGE__->connection(\@connect_info);
903 ok(!$@, "Loader initialization") or diag $@;
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;
910 $classes{$table_name} = $schema->source($source_name)->result_class;
915 warnings => \@loader_warnings,
916 monikers => \%monikers,
917 classes => \%classes,
921 sub write_v4_schema_pm {
924 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
926 make_path $schema_dir;
927 my $schema_pm = "$schema_dir/Schema.pm";
928 open my $fh, '>', $schema_pm or die $!;
929 if (not $opts{use_namespaces}) {
931 package DBIXCSL_Test::Schema;
936 use base 'DBIx::Class::Schema';
938 __PACKAGE__->load_classes;
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
945 # You can replace this text with custom content, and it will be preserved on regeneration
951 package DBIXCSL_Test::Schema;
956 use base 'DBIx::Class::Schema';
958 __PACKAGE__->load_namespaces;
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
965 # You can replace this text with custom content, and it will be preserved on
972 sub write_v5_schema_pm {
975 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
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) {
982 package DBIXCSL_Test::Schema;
984 # Created by DBIx::Class::Schema::Loader
985 # DO NOT MODIFY THE FIRST PART OF THIS FILE
990 use base 'DBIx::Class::Schema';
992 __PACKAGE__->load_classes;
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
999 # You can replace this text with custom content, and it will be preserved on regeneration
1005 package DBIXCSL_Test::Schema;
1007 # Created by DBIx::Class::Schema::Loader
1008 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1013 use base 'DBIx::Class::Schema';
1015 __PACKAGE__->load_namespaces;
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
1022 # You can replace this text with custom content, and it will be preserved on regeneration
1028 sub write_v6_schema_pm {
1031 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
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) {
1038 package DBIXCSL_Test::Schema;
1040 # Created by DBIx::Class::Schema::Loader
1041 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1046 use base 'DBIx::Class::Schema';
1048 __PACKAGE__->load_classes;
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
1055 # You can replace this text with custom content, and it will be preserved on regeneration
1061 package DBIXCSL_Test::Schema;
1063 # Created by DBIx::Class::Schema::Loader
1064 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1069 use base 'DBIx::Class::Schema';
1071 __PACKAGE__->load_namespaces;
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
1078 # You can replace this text with custom content, and it will be preserved on regeneration
1086 my $schema = $res->{schema};
1088 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1089 [qw/Foos Bar Bazs Quuxs StationsVisited Routechange Email/],
1090 'correct monikers in 0.04006 mode';
1092 isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
1093 $res->{classes}{bar},
1096 isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
1097 'correct rel name in 0.04006 mode';
1099 ok my $baz = eval { $schema->resultset('Bazs')->find(1) };
1101 isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
1102 'correct rel type and name for UNIQUE FK in 0.04006 mode';
1104 ok my $foo = eval { $schema->resultset('Foos')->find(1) };
1106 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
1107 'correct rel name inflection in 0.04006 mode';
1109 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')),
1110 'correct column accessor in 0.04006 mode');
1112 is $schema->resultset('Routechange')->find(1)->foo2bar, 3,
1113 'correct column accessor for column with word ending with digit in v4 mode';
1118 my $schema = $res->{schema};
1120 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1121 [qw/Foo Bar Baz Quux StationsVisited Routechange Email/],
1122 'correct monikers in v5 mode';
1124 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1126 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1127 'correct rel name in v5 mode';
1129 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1131 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1132 'correct rel type and name for UNIQUE FK in v5 mode';
1134 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1136 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
1137 'correct rel name inflection in v5 mode';
1139 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')),
1140 'correct column accessor in v5 mode');
1142 is $schema->resultset('Routechange')->find(1)->foo2bar, 3,
1143 'correct column accessor for column with word ending with digit in v5 mode';
1148 my $schema = $res->{schema};
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';
1154 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1156 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1157 'correct rel name in v6 mode';
1159 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1161 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1162 'correct rel type and name for UNIQUE FK in v6 mode';
1164 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1166 isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet',
1167 'correct rel name inflection in v6 mode';
1169 ok my $route_change = eval { $schema->resultset('Routechange')->find(1) };
1171 isa_ok eval { $route_change->quuxsid }, $res->{classes}{quuxs},
1172 'correct rel name in v6 mode';
1174 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')),
1175 'correct column accessor in v6 mode');
1177 is $schema->resultset('Routechange')->find(1)->foo2bar, 3,
1178 'correct column accessor for column with word ending with digit in v6 mode';
1183 my $schema = $res->{schema};
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';
1189 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1191 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1192 'correct rel name in current mode';
1194 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1196 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1197 'correct rel type and name for UNIQUE FK in current mode';
1199 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1201 isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet',
1202 'correct rel name inflection in current mode';
1204 ok my $route_change = eval { $schema->resultset('RouteChange')->find(1) };
1206 isa_ok eval { $route_change->quux }, $res->{classes}{quuxs},
1207 'correct rel name based on mixed-case column name in current mode';
1209 ok (($schema->resultset('RouteChange')->find(1)->can('quuxs_id')),
1210 'correct column accessor in current mode');
1212 is $schema->resultset('RouteChange')->find(1)->foo2_bar, 3,
1213 'correct column accessor for column with word ending with digit in current mode';
1217 package DBICSL::Test::TempExtDir;
1219 use overload '""' => sub { ${$_[0]} };
1223 File::Path::rmtree ${$_[0]};
1227 sub setup_load_external {
1228 my ($rels, $opts) = @_;
1230 my $temp_dir = tempdir(CLEANUP => 1);
1231 push @INC, $temp_dir;
1233 my $external_result_dir = join '/', $temp_dir, (split /::/, $SCHEMA_CLASS),
1234 ($opts->{result_namespace} || ());
1236 make_path $external_result_dir;
1238 while (my ($from, $to) = each %$rels) {
1239 write_ext_result($external_result_dir, $from, $to, $opts);
1242 my $guard = bless \$temp_dir, 'DBICSL::Test::TempExtDir';
1247 sub write_ext_result {
1248 my ($result_dir, $from, $to, $opts) = @_;
1250 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1251 my $from_class = _qualify_class($from, $opts->{result_namespace});
1252 my $to_class = _qualify_class($to, $opts->{result_namespace});
1253 my $condition = _rel_condition($from, $to);
1255 IO::File->new(">$result_dir/${from}.pm")->print(<<"EOF");
1256 package ${from_class};
1257 sub a_method { 'hlagh' }
1259 __PACKAGE__->has_one('$relname', '$to_class',
1271 return Lingua::EN::Inflect::Number::to_S(lc $to) . 'rel';
1274 sub _qualify_class {
1275 my ($class, $result_namespace) = @_;
1277 return $SCHEMA_CLASS . '::'
1278 . ($result_namespace ? $result_namespace . '::' : '')
1283 my ($from, $to) = @_;
1285 return join '', map ucfirst(Lingua::EN::Inflect::Number::to_S(lc($_))), $from, $to;
1288 sub _rel_condition {
1289 my ($from, $to) = @_;
1292 QuuxBaz => q{'foreign.baz_num' => 'self.baz_id'},
1293 BarFoo => q{'foreign.fooid' => 'self.foo_id'},
1294 BazStationsvisited => q{'foreign.id' => 'self.stations_visited_id'},
1295 StationsvisitedQuux => q{'foreign.quuxid' => 'self.quuxs_id'},
1296 RoutechangeQuux => q{'foreign.quuxid' => 'self.QuuxsId'},
1297 }->{_rel_key($from, $to)};
1300 sub class_content_like {
1301 my ($schema, $class, $re, $test_name) = @_;
1303 my $file = $schema->_loader->_get_dump_filename($class);
1304 my $code = slurp $file;
1306 like $code, $re, $test_name;
1309 sub add_custom_content {
1310 my ($schema, $rels, $opts) = @_;
1312 while (my ($from, $to) = each %$rels) {
1313 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1314 my $from_class = _qualify_class($from, $opts->{result_namespace});
1315 my $to_class = _qualify_class($to, $opts->{result_namespace});
1316 my $condition = _rel_condition($from, $to);
1318 my $content = <<"EOF";
1319 package ${from_class};
1320 sub b_method { 'dongs' }
1322 __PACKAGE__->has_one('$relname', '$to_class',
1328 _write_custom_content($schema, $from_class, $content);
1332 sub _write_custom_content {
1333 my ($schema, $class, $content) = @_;
1335 my $pm = $schema->_loader->_get_dump_filename($class);
1337 local ($^I, @ARGV) = ('.bak', $pm);
1339 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
1348 unlink "${pm}.bak" or die $^E;
1353 my $path = shift || '';
1355 my $dir = result_dir($path);
1357 my $file_count =()= glob "$dir/*";
1363 my $path = shift || '';
1365 my $dir = result_dir($path);
1367 return glob "$dir/*";
1370 sub schema_files { result_files(@_) }
1373 my $path = shift || '';
1375 (my $dir = "$DUMP_DIR/$SCHEMA_CLASS/$path") =~ s{::}{/}g;
1381 sub schema_dir { result_dir(@_) }
1383 # vim:et sts=4 sw=4 tw=0: