5 use File::Path qw/rmtree make_path/;
7 use File::Temp qw/tempfile tempdir/;
9 use DBIx::Class::Schema::Loader ();
10 use DBIx::Class::Schema::Loader::Utils 'slurp_file';
11 use Lingua::EN::Inflect::Number ();
13 use make_dbictest_db_with_unique;
14 use dbixcsl_test_dir qw/$tdir/;
16 my $DUMP_DIR = "$tdir/common_dump";
18 my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema';
22 sub class_content_contains;
25 # test dynamic schema in 0.04006 mode
27 my $res = run_loader();
28 my $warning = $res->{warnings}[0];
30 contains $warning, 'Dynamic schema',
31 'dynamic schema in backcompat mode detected';
32 contains $warning, 'run in 0.04006 mode',
33 'dynamic schema in 0.04006 mode warning';
34 contains $warning, 'DBIx::Class::Schema::Loader::Manual::UpgradingFromV4',
35 'warning refers to upgrading doc';
40 # setting naming accessor on dynamic schema should disable warning (even when
41 # we're setting it to 'v4' .)
43 my $res = run_loader(naming => 'v4');
44 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
48 # test upgraded dynamic schema
50 my $res = run_loader(naming => 'current');
51 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
55 # test upgraded dynamic schema with external content loaded
57 my $temp_dir = setup_load_external({
62 my $res = run_loader(naming => 'current', use_namespaces => 0);
63 my $schema = $res->{schema};
65 is scalar @{ $res->{warnings} }, 1,
66 'correct nummber of warnings for upgraded dynamic schema with external ' .
67 'content for unsingularized Result.';
69 my $warning = $res->{warnings}[0];
70 contains $warning, 'Detected external content',
71 'detected external content warning';
73 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
74 'external custom content for unsingularized Result was loaded by upgraded ' .
77 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
78 $res->{classes}{bazs} }
79 'unsingularized class names in external content are translated';
81 lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'hlagh' }
82 'external content from unchanged Result class';
84 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
85 $res->{classes}{foos} }
86 'unsingularized class names in external content from unchanged Result class ' .
87 'names are translated';
92 # test upgraded dynamic schema with use_namespaces with external content loaded
94 my $temp_dir = setup_load_external({
99 my $res = run_loader(naming => 'current', use_namespaces => 1);
100 my $schema = $res->{schema};
102 is scalar @{ $res->{warnings} }, 2,
103 'correct nummber of warnings for upgraded dynamic schema with external ' .
104 'content for unsingularized Result with use_namespaces.';
106 my $warning = $res->{warnings}[0];
107 contains $warning, "Detected external content",
108 'detected external content warning';
110 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
111 'external custom content for unsingularized Result was loaded by upgraded ' .
114 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
115 $res->{classes}{bazs} }
116 'unsingularized class names in external content are translated';
118 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
119 $res->{classes}{foos} }
120 'unsingularized class names in external content from unchanged Result class ' .
121 'names are translated';
126 # test upgraded static schema with external content loaded
130 my $temp_dir = setup_load_external({
135 write_v4_schema_pm();
137 my $res = run_loader(static => 1, naming => 'current');
138 my $schema = $res->{schema};
142 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
143 'external custom content for unsingularized Result was loaded by upgraded ' .
146 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
147 $res->{classes}{bazs} }
148 'unsingularized class names in external content are translated';
150 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
151 $res->{classes}{foos} }
152 'unsingularized class names in external content from unchanged Result class ' .
153 'names are translated in static schema';
155 class_content_contains $schema, $res->{classes}{quuxs}, "package ${SCHEMA_CLASS}::Quux;",
156 'package line translated correctly from external custom content in static dump';
158 class_content_contains $schema, $res->{classes}{quuxs}, "sub a_method { 'hlagh' }",
159 'external custom content loaded into static dump correctly';
162 # test running against v4 schema without upgrade, twice, then upgrade
165 write_v4_schema_pm();
166 my $res = run_loader(static => 1);
167 my $warning = $res->{warnings}[1];
169 contains $warning, "static schema",
170 'static schema in backcompat mode detected';
171 contains $warning, "0.04006",
172 'correct version detected';
173 contains $warning, "DBIx::Class::Schema::Loader::Manual::UpgradingFromV4",
174 'refers to upgrading doc';
176 is scalar @{ $res->{warnings} }, 4,
177 'correct number of warnings for static schema in backcompat mode';
181 add_custom_content($res->{schema}, {
185 # Rerun the loader in backcompat mode to make sure it's still in backcompat
187 $res = run_loader(static => 1);
190 # now upgrade the schema
196 my $schema = $res->{schema};
198 contains $res->{warnings}[0], "Dumping manual schema",
199 'correct warnings on upgrading static schema (with "naming" set)';
201 contains $res->{warnings}[1], "dump completed",
202 'correct warnings on upgrading static schema (with "naming" set)';
204 is scalar @{ $res->{warnings} }, 2,
205 'correct number of warnings on upgrading static schema (with "naming" set)'
206 or diag @{ $res->{warnings} };
210 is result_count('Result'), $RESULT_COUNT,
211 'un-singularized results were replaced during upgrade';
213 # check that custom content was preserved
214 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
215 'custom content was carried over from un-singularized Result';
217 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
218 $res->{classes}{bazs} }
219 'unsingularized class names in custom content are translated';
221 class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }",
222 'custom content from unsingularized Result loaded into static dump correctly';
225 # test running against v4 schema without upgrade, then upgrade with
226 # use_namespaces not explicitly set
229 write_v4_schema_pm();
230 my $res = run_loader(static => 1);
231 my $warning = $res->{warnings}[1];
233 contains $warning, "static schema",
234 'static schema in backcompat mode detected';
235 contains $warning, "0.04006",
236 'correct version detected';
237 contains $warning, "DBIx::Class::Schema::Loader::Manual::UpgradingFromV4",
238 'refers to upgrading doc';
240 is scalar @{ $res->{warnings} }, 4,
241 'correct number of warnings for static schema in backcompat mode';
245 add_custom_content($res->{schema}, {
249 # now upgrade the schema
254 my $schema = $res->{schema};
256 contains $res->{warnings}[0], "load_classes",
257 'correct warnings on upgrading static schema (with "naming" set and ' .
258 'use_namespaces not set)';
260 contains $res->{warnings}[1], "Dumping manual schema",
261 'correct warnings on upgrading static schema (with "naming" set and ' .
262 'use_namespaces not set)';
264 contains $res->{warnings}[2], "dump completed",
265 'correct warnings on upgrading static schema (with "naming" set and ' .
266 'use_namespaces not set)';
268 is scalar @{ $res->{warnings} }, 3,
269 'correct number of warnings on upgrading static schema (with "naming" set)'
270 or diag @{ $res->{warnings} };
274 is result_count(), $RESULT_COUNT,
275 'un-singularized results were replaced during upgrade';
277 # check that custom content was preserved
278 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
279 'custom content was carried over from un-singularized Result';
281 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
282 $res->{classes}{bazs} }
283 'unsingularized class names in custom content are translated';
285 class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }",
286 'custom content from unsingularized Result loaded into static dump correctly';
289 # test running against v4 schema with load_namespaces, upgrade to current but
290 # downgrade to load_classes, with external content
294 my $temp_dir = setup_load_external({
297 }, { result_namespace => 'Result' });
299 write_v4_schema_pm(use_namespaces => 1);
301 my $res = run_loader(static => 1);
302 my $warning = $res->{warnings}[0];
304 contains $warning, "static schema",
305 'static schema in backcompat mode detected';
306 contains $warning, "0.04006",
307 'correct version detected';
308 contains $warning, "DBIx::Class::Schema::Loader::Manual::UpgradingFromV4",
309 'refers to upgrading doc';
311 is scalar @{ $res->{warnings} }, 3,
312 'correct number of warnings for static schema in backcompat mode';
316 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quuxs',
317 'use_namespaces in backcompat mode';
319 add_custom_content($res->{schema}, {
322 result_namespace => 'Result',
323 rel_name_map => { QuuxBaz => 'bazrel2' },
326 # now upgrade the schema to current but downgrade to load_classes
332 my $schema = $res->{schema};
334 contains $res->{warnings}[0], "Dumping manual schema",
335 'correct warnings on upgrading static schema (with "naming" set and ' .
336 'use_namespaces => 0)';
338 contains $res->{warnings}[1], "dump completed",
339 'correct warnings on upgrading static schema (with "naming" set and ' .
340 'use_namespaces => 0)';
342 is scalar @{ $res->{warnings} }, 2,
343 'correct number of warnings on upgrading static schema (with "naming" set)'
344 or diag @{ $res->{warnings} };
348 is result_count(), $RESULT_COUNT,
349 'un-singularized results were replaced during upgrade and Result dir removed';
351 ok ((not -d result_dir('Result')),
352 'Result dir was removed for load_classes downgrade');
354 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
355 'load_classes in upgraded mode';
357 # check that custom and external content was preserved
358 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
359 'custom content was carried over from un-singularized Result';
361 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
362 'external content was carried over from un-singularized Result';
364 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
365 $res->{classes}{bazs} }
366 'unsingularized class names in custom content are translated';
368 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
369 $res->{classes}{bazs} }
370 'unsingularized class names in external content are translated';
372 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
373 $res->{classes}{foos} }
374 'unsingularized class names in external content from unchanged Result class ' .
375 'names are translated in static schema';
377 class_content_contains $schema, $res->{classes}{quuxs}, "sub a_method { 'hlagh' }",
378 'external content from unsingularized Result loaded into static dump correctly';
380 class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }",
381 'custom content from unsingularized Result loaded into static dump correctly';
384 # test a regular schema with use_namespaces => 0 upgraded to
385 # use_namespaces => 1
387 my $res = run_loader(
394 contains $res->{warnings}[0], "Dumping manual schema",
395 'correct warnings on dumping static schema with use_namespaces => 0';
397 contains $res->{warnings}[1], "dump completed",
398 'correct warnings on dumping static schema with use_namespaces => 0';
400 is scalar @{ $res->{warnings} }, 2,
401 'correct number of warnings on dumping static schema with use_namespaces => 0'
402 or diag @{ $res->{warnings} };
406 my $schema = $res->{schema};
407 add_custom_content($res->{schema}, {
411 # test that with no use_namespaces option, there is a warning and
412 # load_classes is preserved
413 $res = run_loader(static => 1, naming => 'current');
415 contains $res->{warnings}[0], "load_classes",
416 'correct warnings on re-dumping static schema with load_classes';
418 contains $res->{warnings}[1], "Dumping manual schema",
419 'correct warnings on re-dumping static schema with load_classes';
421 contains $res->{warnings}[2], "dump completed",
422 'correct warnings on re-dumping static schema with load_classes';
424 is scalar @{ $res->{warnings} }, 3,
425 'correct number of warnings on re-dumping static schema with load_classes'
426 or diag @{ $res->{warnings} };
428 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
429 'load_classes preserved on re-dump';
433 # now upgrade the schema to use_namespaces
439 $schema = $res->{schema};
441 contains $res->{warnings}[0], "Dumping manual schema",
442 'correct warnings on upgrading to use_namespaces';
444 contains $res->{warnings}[1], "dump completed",
445 'correct warnings on upgrading to use_namespaces';
447 is scalar @{ $res->{warnings} }, 2,
448 'correct number of warnings on upgrading to use_namespaces'
449 or diag @{ $res->{warnings} };
453 my @schema_files = schema_files();
455 is 1, (scalar @schema_files),
456 "schema dir contains only 1 entry";
458 like $schema_files[0], qr{/Result\z},
459 "schema dir contains only a Result/ directory";
461 # check that custom content was preserved
462 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
463 'custom content was carried over during use_namespaces upgrade';
465 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
466 $res->{classes}{bazs} }
467 'un-namespaced class names in custom content are translated';
469 class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }",
470 'custom content from un-namespaced Result loaded into static dump correctly';
473 # test a regular schema with default use_namespaces => 1, redump, and downgrade
476 my $res = run_loader(clean_dumpdir => 1, static => 1, naming => 'current');
478 contains $res->{warnings}[0], "Dumping manual schema",
479 'correct warnings on dumping static schema';
481 contains $res->{warnings}[1], "dump completed",
482 'correct warnings on dumping static schema';
484 is scalar @{ $res->{warnings} }, 2,
485 'correct number of warnings on dumping static schema'
486 or diag @{ $res->{warnings} };
490 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
491 'defaults to use_namespaces on regular dump';
493 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result' });
495 # test that with no use_namespaces option, use_namespaces is preserved
496 $res = run_loader(static => 1, naming => 'current');
498 contains $res->{warnings}[0], "Dumping manual schema",
499 'correct warnings on re-dumping static schema';
501 contains $res->{warnings}[1], "dump completed",
502 'correct warnings on re-dumping static schema';
504 is scalar @{ $res->{warnings} }, 2,
505 'correct number of warnings on re-dumping static schema'
506 or diag @{ $res->{warnings} };
508 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
509 'use_namespaces preserved on re-dump';
513 # now downgrade the schema to load_classes
519 my $schema = $res->{schema};
521 contains $res->{warnings}[0], "Dumping manual schema",
522 'correct warnings on downgrading to load_classes';
524 contains $res->{warnings}[1], "dump completed",
525 'correct warnings on downgrading to load_classes';
527 is scalar @{ $res->{warnings} }, 2,
528 'correct number of warnings on downgrading to load_classes'
529 or diag @{ $res->{warnings} };
533 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
534 'load_classes downgrade correct';
536 is result_count(), $RESULT_COUNT,
537 'correct number of Results after upgrade and Result dir removed';
539 ok ((not -d result_dir('Result')),
540 'Result dir was removed for load_classes downgrade');
542 # check that custom content was preserved
543 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
544 'custom content was carried over during load_classes downgrade';
546 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
547 $res->{classes}{bazs} }
548 'namespaced class names in custom content are translated during load_classes '.
551 class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }",
552 'custom content from namespaced Result loaded into static dump correctly '.
553 'during load_classes downgrade';
556 # test a regular schema with use_namespaces => 1 and a custom result_namespace
557 # downgraded to load_classes
559 my $res = run_loader(
562 result_namespace => 'MyResult',
566 contains $res->{warnings}[0], "Dumping manual schema",
567 'correct warnings on dumping static schema';
569 contains $res->{warnings}[1], "dump completed",
570 'correct warnings on dumping static schema';
572 is scalar @{ $res->{warnings} }, 2,
573 'correct number of warnings on dumping static schema'
574 or diag @{ $res->{warnings} };
578 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
579 'defaults to use_namespaces and uses custom result_namespace';
581 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'MyResult' });
583 # test that with no use_namespaces option, use_namespaces is preserved, and
584 # the custom result_namespace is preserved
585 $res = run_loader(static => 1, naming => 'current');
587 contains $res->{warnings}[0], "Dumping manual schema",
588 'correct warnings on re-dumping static schema';
590 contains $res->{warnings}[1], "dump completed",
591 'correct warnings on re-dumping static schema';
593 is scalar @{ $res->{warnings} }, 2,
594 'correct number of warnings on re-dumping static schema'
595 or diag @{ $res->{warnings} };
597 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
598 'use_namespaces and custom result_namespace preserved on re-dump';
602 # now downgrade the schema to load_classes
608 my $schema = $res->{schema};
610 contains $res->{warnings}[0], "Dumping manual schema",
611 'correct warnings on downgrading to load_classes';
613 contains $res->{warnings}[1], "dump completed",
614 'correct warnings on downgrading to load_classes';
616 is scalar @{ $res->{warnings} }, 2,
617 'correct number of warnings on downgrading to load_classes'
618 or diag @{ $res->{warnings} };
622 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
623 'load_classes downgrade correct';
625 is result_count(), $RESULT_COUNT,
626 'correct number of Results after upgrade and Result dir removed';
628 ok ((not -d result_dir('MyResult')),
629 'Result dir was removed for load_classes downgrade');
631 # check that custom content was preserved
632 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
633 'custom content was carried over during load_classes downgrade';
635 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
636 $res->{classes}{bazs} }
637 'namespaced class names in custom content are translated during load_classes '.
640 class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }",
641 'custom content from namespaced Result loaded into static dump correctly '.
642 'during load_classes downgrade';
645 # rewrite from one result_namespace to another, with external content
648 my $temp_dir = setup_load_external({ Quux => 'Baz', Bar => 'Foo' }, { result_namespace => 'Result' });
650 my $res = run_loader(static => 1, naming => 'current');
652 # add some custom content to a Result that will be replaced
653 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result', rel_name_map => { QuuxBaz => 'bazrel2' } });
655 # Rewrite implicit 'Result' to 'MyResult'
658 result_namespace => 'MyResult',
661 my $schema = $res->{schema};
663 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
664 'using new result_namespace';
666 is result_count('MyResult'), $RESULT_COUNT,
667 'correct number of Results after rewritten result_namespace';
669 ok ((not -d schema_dir('Result')),
670 'original Result dir was removed when rewriting result_namespace');
672 # check that custom content was preserved
673 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
674 'custom content was carried over when rewriting result_namespace';
676 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
677 $res->{classes}{bazs} }
678 'class names in custom content are translated when rewriting result_namespace';
680 class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }",
681 'custom content from namespaced Result loaded into static dump correctly '.
682 'when rewriting result_namespace';
684 # Now rewrite 'MyResult' to 'Mtfnpy'
687 result_namespace => 'Mtfnpy',
690 $schema = $res->{schema};
692 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Mtfnpy::Quux',
693 'using new result_namespace';
695 is result_count('Mtfnpy'), $RESULT_COUNT,
696 'correct number of Results after rewritten result_namespace';
698 ok ((not -d result_dir('MyResult')),
699 'original Result dir was removed when rewriting result_namespace');
701 # check that custom and external content was preserved
702 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
703 'external content was carried over when rewriting result_namespace';
705 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
706 'custom content was carried over when rewriting result_namespace';
708 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
709 $res->{classes}{bazs} }
710 'class names in custom content are translated when rewriting result_namespace';
712 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
713 $res->{classes}{bazs} }
714 'class names in external content are translated when rewriting '.
717 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
718 $res->{classes}{foos} }
719 'class names in external content are translated when rewriting '.
722 class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }",
723 'custom content from namespaced Result loaded into static dump correctly '.
724 'when rewriting result_namespace';
726 class_content_contains $schema, $res->{classes}{quuxs}, "sub a_method { 'hlagh' }",
727 'external content from unsingularized Result loaded into static dump correctly';
730 # test upgrading a v4 schema, then check that the version string is correct
733 write_v4_schema_pm();
734 run_loader(static => 1);
735 my $res = run_loader(static => 1, naming => 'current');
736 my $schema = $res->{schema};
738 my $file = $schema->loader->get_dump_filename($SCHEMA_CLASS);
739 my $code = slurp_file $file;
742 $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m;
744 is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION,
745 'correct version dumped after upgrade of v4 static schema';
748 # Test upgrading an already singular result with custom content that refers to
752 write_v4_schema_pm();
753 my $res = run_loader(static => 1);
754 my $schema = $res->{schema};
757 # add some custom content to a Result that will be replaced
758 add_custom_content($schema, { Bar => 'Foos' });
760 # now upgrade the schema
761 $res = run_loader(static => 1, naming => 'current');
762 $schema = $res->{schema};
765 # check that custom content was preserved
766 lives_and { is $schema->resultset('Bar')->find(1)->b_method, 'dongs' }
767 'custom content was preserved from Result pre-upgrade';
769 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
770 $res->{classes}{foos} }
771 'unsingularized class names in custom content from Result with unchanged ' .
772 'name are translated';
774 class_content_contains $schema, $res->{classes}{bar}, "sub b_method { 'dongs' }",
775 'custom content from Result with unchanged name loaded into static dump ' .
779 # test creating static schema in v5 mode then upgrade to current with external
784 write_v5_schema_pm();
786 my $res = run_loader(static => 1);
788 contains $res->{warnings}[0], "0.05003 static schema", 'backcompat warning';
792 my $temp_dir = setup_load_external({
793 Baz => 'StationsVisited',
794 StationsVisited => 'Quux',
795 }, { result_namespace => 'Result' });
797 add_custom_content($res->{schema}, {
798 Baz => 'StationsVisited',
800 result_namespace => 'Result',
801 rel_name_map => { BazStationsvisited => 'custom_content_rel' },
804 $res = run_loader(static => 1, naming => 'current');
805 my $schema = $res->{schema};
809 lives_and { is $schema->resultset('Baz')->find(1)->a_method, 'hlagh' }
810 'external custom content loaded for v5 -> v6';
812 lives_and { isa_ok $schema->resultset('Baz')->find(1)->stationsvisitedrel,
813 $res->{classes}{stations_visited} }
814 'external content rewritten for v5 -> v6';
816 lives_and { isa_ok $schema->resultset('Baz')->find(1)->custom_content_rel,
817 $res->{classes}{stations_visited} }
818 'custom content rewritten for v5 -> v6';
820 lives_and { isa_ok $schema->resultset('StationVisited')->find(1)->quuxrel,
821 $res->{classes}{quuxs} }
822 'external content rewritten for v5 -> v6 for upgraded Result class names';
825 # test creating static schema in v6 mode then upgrade to current with external
830 write_v6_schema_pm();
832 my $res = run_loader(static => 1);
834 contains $res->{warnings}[0], "0.06001 static schema", 'backcompat warning';
838 my $temp_dir = setup_load_external({
839 Routechange => 'Quux',
840 }, { result_namespace => 'Result' });
842 add_custom_content($res->{schema}, {
843 Routechange => 'Quux',
845 result_namespace => 'Result',
846 rel_name_map => { RoutechangeQuux => 'custom_content_rel' },
849 $res = run_loader(static => 1, naming => 'current');
850 my $schema = $res->{schema};
854 lives_and { is $schema->resultset('RouteChange')->find(1)->a_method, 'hlagh' }
855 'external custom content loaded for v6 -> v7';
857 lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->quuxrel,
858 $res->{classes}{quuxs} }
859 'external content rewritten for v6 -> v7';
861 lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->custom_content_rel,
862 $res->{classes}{quuxs} }
863 'custom content rewritten for v6 -> v7';
869 rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
878 my %loader_opts = @_;
880 $loader_opts{dump_directory} = $DUMP_DIR if delete $loader_opts{static};
881 $loader_opts{preserve_case} = 1 if $loader_opts{naming} && $loader_opts{naming} eq 'current';
883 clean_dumpdir() if delete $loader_opts{clean_dumpdir};
886 foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
887 Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
890 Class::Unload->unload($SCHEMA_CLASS);
894 my @connect_info = $make_dbictest_db_with_unique::dsn;
896 local $SIG{__WARN__} = sub { push(@loader_warnings, @_); };
898 package $SCHEMA_CLASS;
899 use base qw/DBIx::Class::Schema::Loader/;
901 __PACKAGE__->loader_options(\%loader_opts);
902 __PACKAGE__->connection(\@connect_info);
905 ok(!$@, "Loader initialization") or diag $@;
907 my $schema = $SCHEMA_CLASS->clone;
908 my (%monikers, %classes);
909 foreach my $source_name ($schema->sources) {
910 my $table_name = $schema->source($source_name)->from;
911 $monikers{$table_name} = $source_name;
912 $classes{$table_name} = $schema->source($source_name)->result_class;
917 warnings => \@loader_warnings,
918 monikers => \%monikers,
919 classes => \%classes,
923 sub write_v4_schema_pm {
926 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
928 make_path $schema_dir;
929 my $schema_pm = "$schema_dir/Schema.pm";
930 open my $fh, '>', $schema_pm or die $!;
931 if (not $opts{use_namespaces}) {
933 package DBIXCSL_Test::Schema;
938 use base 'DBIx::Class::Schema';
940 __PACKAGE__->load_classes;
943 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25
944 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog
947 # You can replace this text with custom content, and it will be preserved on regeneration
953 package DBIXCSL_Test::Schema;
958 use base 'DBIx::Class::Schema';
960 __PACKAGE__->load_namespaces;
963 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2010-01-12 16:04:12
964 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:d3wRVsHBNisyhxeaWJZcZQ
967 # You can replace this text with custom content, and it will be preserved on
974 sub write_v5_schema_pm {
977 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
979 make_path $schema_dir;
980 my $schema_pm = "$schema_dir/Schema.pm";
981 open my $fh, '>', $schema_pm or die $!;
982 if (exists $opts{use_namespaces} && $opts{use_namespaces} == 0) {
984 package DBIXCSL_Test::Schema;
986 # Created by DBIx::Class::Schema::Loader
987 # DO NOT MODIFY THE FIRST PART OF THIS FILE
992 use base 'DBIx::Class::Schema';
994 __PACKAGE__->load_classes;
997 # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-27 17:07:37
998 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:LIzC/LT5IYvWpgusfbqMrg
1001 # You can replace this text with custom content, and it will be preserved on regeneration
1007 package DBIXCSL_Test::Schema;
1009 # Created by DBIx::Class::Schema::Loader
1010 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1015 use base 'DBIx::Class::Schema';
1017 __PACKAGE__->load_namespaces;
1020 # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-29 19:44:52
1021 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:D+MYxtGxz97Ghvido5DTEg
1024 # You can replace this text with custom content, and it will be preserved on regeneration
1030 sub write_v6_schema_pm {
1033 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
1035 make_path $schema_dir;
1036 my $schema_pm = "$schema_dir/Schema.pm";
1037 open my $fh, '>', $schema_pm or die $!;
1038 if (exists $opts{use_namespaces} && $opts{use_namespaces} == 0) {
1040 package DBIXCSL_Test::Schema;
1042 # Created by DBIx::Class::Schema::Loader
1043 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1048 use base 'DBIx::Class::Schema';
1050 __PACKAGE__->load_classes;
1053 # Created by DBIx::Class::Schema::Loader v0.06001 @ 2010-04-21 19:56:03
1054 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:/fqZCb95hsGIe1g5qyQQZg
1057 # You can replace this text with custom content, and it will be preserved on regeneration
1063 package DBIXCSL_Test::Schema;
1065 # Created by DBIx::Class::Schema::Loader
1066 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1071 use base 'DBIx::Class::Schema';
1073 __PACKAGE__->load_namespaces;
1076 # Created by DBIx::Class::Schema::Loader v0.06001 @ 2010-04-21 19:54:31
1077 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:nwO5Vi47kl0X9SpEoiVO5w
1080 # You can replace this text with custom content, and it will be preserved on regeneration
1088 my $schema = $res->{schema};
1090 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1091 [qw/Foos Bar Bazs Quuxs StationsVisited Routechange Email/],
1092 'correct monikers in 0.04006 mode';
1094 isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
1095 $res->{classes}{bar},
1098 isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
1099 'correct rel name in 0.04006 mode';
1101 ok my $baz = eval { $schema->resultset('Bazs')->find(1) };
1103 isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
1104 'correct rel type and name for UNIQUE FK in 0.04006 mode';
1106 ok my $foo = eval { $schema->resultset('Foos')->find(1) };
1108 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
1109 'correct rel name inflection in 0.04006 mode';
1111 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')),
1112 'correct column accessor in 0.04006 mode');
1114 is $schema->resultset('Routechange')->find(1)->foo2bar, 3,
1115 'correct column accessor for column with word ending with digit in v4 mode';
1120 my $schema = $res->{schema};
1122 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1123 [qw/Foo Bar Baz Quux StationsVisited Routechange Email/],
1124 'correct monikers in v5 mode';
1126 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1128 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1129 'correct rel name in v5 mode';
1131 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1133 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1134 'correct rel type and name for UNIQUE FK in v5 mode';
1136 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1138 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
1139 'correct rel name inflection in v5 mode';
1141 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')),
1142 'correct column accessor in v5 mode');
1144 is $schema->resultset('Routechange')->find(1)->foo2bar, 3,
1145 'correct column accessor for column with word ending with digit in v5 mode';
1150 my $schema = $res->{schema};
1152 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1153 [qw/Foo Bar Baz Quux StationVisited Routechange Email/],
1154 'correct monikers in v6 mode';
1156 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1158 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1159 'correct rel name in v6 mode';
1161 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1163 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1164 'correct rel type and name for UNIQUE FK in v6 mode';
1166 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1168 isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet',
1169 'correct rel name inflection in v6 mode';
1171 ok my $route_change = eval { $schema->resultset('Routechange')->find(1) };
1173 isa_ok eval { $route_change->quuxsid }, $res->{classes}{quuxs},
1174 'correct rel name in v6 mode';
1176 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')),
1177 'correct column accessor in v6 mode');
1179 is $schema->resultset('Routechange')->find(1)->foo2bar, 3,
1180 'correct column accessor for column with word ending with digit in v6 mode';
1185 my $schema = $res->{schema};
1187 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1188 [qw/Foo Bar Baz Quux StationVisited RouteChange Email/],
1189 'correct monikers in current mode';
1191 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1193 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1194 'correct rel name in current mode';
1196 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1198 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1199 'correct rel type and name for UNIQUE FK in current mode';
1201 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1203 isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet',
1204 'correct rel name inflection in current mode';
1206 ok my $route_change = eval { $schema->resultset('RouteChange')->find(1) };
1208 isa_ok eval { $route_change->quux }, $res->{classes}{quuxs},
1209 'correct rel name based on mixed-case column name in current mode';
1211 ok (($schema->resultset('RouteChange')->find(1)->can('quuxs_id')),
1212 'correct column accessor in current mode');
1214 is $schema->resultset('RouteChange')->find(1)->foo2_bar, 3,
1215 'correct column accessor for column with word ending with digit in current mode';
1219 package DBICSL::Test::TempExtDir;
1221 use overload '""' => sub { ${$_[0]} };
1225 File::Path::rmtree ${$_[0]};
1229 sub setup_load_external {
1230 my ($rels, $opts) = @_;
1232 my $temp_dir = tempdir(CLEANUP => 1);
1233 push @INC, $temp_dir;
1235 my $external_result_dir = join '/', $temp_dir, (split /::/, $SCHEMA_CLASS),
1236 ($opts->{result_namespace} || ());
1238 make_path $external_result_dir;
1240 while (my ($from, $to) = each %$rels) {
1241 write_ext_result($external_result_dir, $from, $to, $opts);
1244 my $guard = bless \$temp_dir, 'DBICSL::Test::TempExtDir';
1249 sub write_ext_result {
1250 my ($result_dir, $from, $to, $opts) = @_;
1252 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1253 my $from_class = _qualify_class($from, $opts->{result_namespace});
1254 my $to_class = _qualify_class($to, $opts->{result_namespace});
1255 my $condition = _rel_condition($from, $to);
1257 IO::File->new(">$result_dir/${from}.pm")->print(<<"EOF");
1258 package ${from_class};
1259 sub a_method { 'hlagh' }
1261 __PACKAGE__->has_one('$relname', '$to_class',
1273 return Lingua::EN::Inflect::Number::to_S(lc $to) . 'rel';
1276 sub _qualify_class {
1277 my ($class, $result_namespace) = @_;
1279 return $SCHEMA_CLASS . '::'
1280 . ($result_namespace ? $result_namespace . '::' : '')
1285 my ($from, $to) = @_;
1287 return join '', map ucfirst(Lingua::EN::Inflect::Number::to_S(lc($_))), $from, $to;
1290 sub _rel_condition {
1291 my ($from, $to) = @_;
1294 QuuxBaz => q{'foreign.baz_num' => 'self.baz_id'},
1295 BarFoo => q{'foreign.fooid' => 'self.foo_id'},
1296 BazStationsvisited => q{'foreign.id' => 'self.stations_visited_id'},
1297 StationsvisitedQuux => q{'foreign.quuxid' => 'self.quuxs_id'},
1298 RoutechangeQuux => q{'foreign.quuxid' => 'self.QuuxsId'},
1299 }->{_rel_key($from, $to)};
1302 sub class_content_contains {
1303 my ($schema, $class, $substr, $test_name) = @_;
1305 my $file = $schema->loader->get_dump_filename($class);
1306 my $code = slurp_file $file;
1308 local $Test::Builder::Level = $Test::Builder::Level + 1;
1310 contains $code, $substr, $test_name;
1314 my ($haystack, $needle, $test_name) = @_;
1316 local $Test::Builder::Level = $Test::Builder::Level + 1;
1318 like $haystack, qr/\Q$needle\E/, $test_name;
1321 sub add_custom_content {
1322 my ($schema, $rels, $opts) = @_;
1324 while (my ($from, $to) = each %$rels) {
1325 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1326 my $from_class = _qualify_class($from, $opts->{result_namespace});
1327 my $to_class = _qualify_class($to, $opts->{result_namespace});
1328 my $condition = _rel_condition($from, $to);
1330 my $content = <<"EOF";
1331 package ${from_class};
1332 sub b_method { 'dongs' }
1334 __PACKAGE__->has_one('$relname', '$to_class',
1340 _write_custom_content($schema, $from_class, $content);
1344 sub _write_custom_content {
1345 my ($schema, $class, $content) = @_;
1347 my $pm = $schema->loader->get_dump_filename($class);
1349 local ($^I, @ARGV) = ('.bak', $pm);
1351 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
1360 unlink "${pm}.bak" or die $^E;
1365 my $path = shift || '';
1367 my $dir = result_dir($path);
1369 my $file_count =()= glob "$dir/*";
1375 my $path = shift || '';
1377 my $dir = result_dir($path);
1379 return glob "$dir/*";
1382 sub schema_files { result_files(@_) }
1385 my $path = shift || '';
1387 (my $dir = "$DUMP_DIR/$SCHEMA_CLASS/$path") =~ s{::}{/}g;
1393 sub schema_dir { result_dir(@_) }
1395 # vim:et sts=4 sw=4 tw=0: