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(
391 like $res->{warnings}[0], qr/Dumping manual schema/i,
392 'correct warnings on dumping static schema with use_namespaces => 0';
394 like $res->{warnings}[1], qr/dump completed/i,
395 'correct warnings on dumping static schema with use_namespaces => 0';
397 is scalar @{ $res->{warnings} }, 2,
398 'correct number of warnings on dumping static schema with use_namespaces => 0'
399 or diag @{ $res->{warnings} };
403 my $schema = $res->{schema};
404 add_custom_content($res->{schema}, {
408 # test that with no use_namespaces option, there is a warning and
409 # load_classes is preserved
410 $res = run_loader(static => 1);
412 like $res->{warnings}[0], qr/load_classes/i,
413 'correct warnings on re-dumping static schema with load_classes';
415 like $res->{warnings}[1], qr/Dumping manual schema/i,
416 'correct warnings on re-dumping static schema with load_classes';
418 like $res->{warnings}[2], qr/dump completed/i,
419 'correct warnings on re-dumping static schema with load_classes';
421 is scalar @{ $res->{warnings} }, 3,
422 'correct number of warnings on re-dumping static schema with load_classes'
423 or diag @{ $res->{warnings} };
425 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
426 'load_classes preserved on re-dump';
430 # now upgrade the schema to use_namespaces
435 $schema = $res->{schema};
437 like $res->{warnings}[0], qr/Dumping manual schema/i,
438 'correct warnings on upgrading to use_namespaces';
440 like $res->{warnings}[1], qr/dump completed/i,
441 'correct warnings on upgrading to use_namespaces';
443 is scalar @{ $res->{warnings} }, 2,
444 'correct number of warnings on upgrading to use_namespaces'
445 or diag @{ $res->{warnings} };
449 my @schema_files = schema_files();
451 is 1, (scalar @schema_files),
452 "schema dir contains only 1 entry";
454 like $schema_files[0], qr{/Result\z},
455 "schema dir contains only a Result/ directory";
457 # check that custom content was preserved
458 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
459 'custom content was carried over during use_namespaces upgrade';
461 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
462 $res->{classes}{bazs} }
463 'un-namespaced class names in custom content are translated';
465 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
466 'custom content from un-namespaced Result loaded into static dump correctly';
469 # test a regular schema with default use_namespaces => 1, redump, and downgrade
472 my $res = run_loader(clean_dumpdir => 1, static => 1);
474 like $res->{warnings}[0], qr/Dumping manual schema/i,
475 'correct warnings on dumping static schema';
477 like $res->{warnings}[1], qr/dump completed/i,
478 'correct warnings on dumping static schema';
480 is scalar @{ $res->{warnings} }, 2,
481 'correct number of warnings on dumping static schema'
482 or diag @{ $res->{warnings} };
486 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
487 'defaults to use_namespaces on regular dump';
489 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result' });
491 # test that with no use_namespaces option, use_namespaces is preserved
492 $res = run_loader(static => 1);
494 like $res->{warnings}[0], qr/Dumping manual schema/i,
495 'correct warnings on re-dumping static schema';
497 like $res->{warnings}[1], qr/dump completed/i,
498 'correct warnings on re-dumping static schema';
500 is scalar @{ $res->{warnings} }, 2,
501 'correct number of warnings on re-dumping static schema'
502 or diag @{ $res->{warnings} };
504 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
505 'use_namespaces preserved on re-dump';
509 # now downgrade the schema to load_classes
514 my $schema = $res->{schema};
516 like $res->{warnings}[0], qr/Dumping manual schema/i,
517 'correct warnings on downgrading to load_classes';
519 like $res->{warnings}[1], qr/dump completed/i,
520 'correct warnings on downgrading to load_classes';
522 is scalar @{ $res->{warnings} }, 2,
523 'correct number of warnings on downgrading to load_classes'
524 or diag @{ $res->{warnings} };
528 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
529 'load_classes downgrade correct';
531 is result_count(), $RESULT_COUNT,
532 'correct number of Results after upgrade and Result dir removed';
534 ok ((not -d result_dir('Result')),
535 'Result dir was removed for load_classes downgrade');
537 # check that custom content was preserved
538 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
539 'custom content was carried over during load_classes downgrade';
541 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
542 $res->{classes}{bazs} }
543 'namespaced class names in custom content are translated during load_classes '.
546 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
547 'custom content from namespaced Result loaded into static dump correctly '.
548 'during load_classes downgrade';
551 # test a regular schema with use_namespaces => 1 and a custom result_namespace
552 # downgraded to load_classes
554 my $res = run_loader(
557 result_namespace => 'MyResult',
560 like $res->{warnings}[0], qr/Dumping manual schema/i,
561 'correct warnings on dumping static schema';
563 like $res->{warnings}[1], qr/dump completed/i,
564 'correct warnings on dumping static schema';
566 is scalar @{ $res->{warnings} }, 2,
567 'correct number of warnings on dumping static schema'
568 or diag @{ $res->{warnings} };
572 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
573 'defaults to use_namespaces and uses custom result_namespace';
575 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'MyResult' });
577 # test that with no use_namespaces option, use_namespaces is preserved, and
578 # the custom result_namespace is preserved
579 $res = run_loader(static => 1);
581 like $res->{warnings}[0], qr/Dumping manual schema/i,
582 'correct warnings on re-dumping static schema';
584 like $res->{warnings}[1], qr/dump completed/i,
585 'correct warnings on re-dumping static schema';
587 is scalar @{ $res->{warnings} }, 2,
588 'correct number of warnings on re-dumping static schema'
589 or diag @{ $res->{warnings} };
591 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
592 'use_namespaces and custom result_namespace preserved on re-dump';
596 # now downgrade the schema to load_classes
601 my $schema = $res->{schema};
603 like $res->{warnings}[0], qr/Dumping manual schema/i,
604 'correct warnings on downgrading to load_classes';
606 like $res->{warnings}[1], qr/dump completed/i,
607 'correct warnings on downgrading to load_classes';
609 is scalar @{ $res->{warnings} }, 2,
610 'correct number of warnings on downgrading to load_classes'
611 or diag @{ $res->{warnings} };
615 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
616 'load_classes downgrade correct';
618 is result_count(), $RESULT_COUNT,
619 'correct number of Results after upgrade and Result dir removed';
621 ok ((not -d result_dir('MyResult')),
622 'Result dir was removed for load_classes downgrade');
624 # check that custom content was preserved
625 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
626 'custom content was carried over during load_classes downgrade';
628 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
629 $res->{classes}{bazs} }
630 'namespaced class names in custom content are translated during load_classes '.
633 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
634 'custom content from namespaced Result loaded into static dump correctly '.
635 'during load_classes downgrade';
638 # rewrite from one result_namespace to another, with external content
641 my $temp_dir = setup_load_external({ Quux => 'Baz', Bar => 'Foo' }, { result_namespace => 'Result' });
643 my $res = run_loader(static => 1);
645 # add some custom content to a Result that will be replaced
646 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result', rel_name_map => { QuuxBaz => 'bazrel2' } });
648 # Rewrite implicit 'Result' to 'MyResult'
651 result_namespace => 'MyResult',
653 my $schema = $res->{schema};
655 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
656 'using new result_namespace';
658 is result_count('MyResult'), $RESULT_COUNT,
659 'correct number of Results after rewritten result_namespace';
661 ok ((not -d schema_dir('Result')),
662 'original Result dir was removed when rewriting result_namespace');
664 # check that custom content was preserved
665 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
666 'custom content was carried over when rewriting result_namespace';
668 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
669 $res->{classes}{bazs} }
670 'class names in custom content are translated when rewriting result_namespace';
672 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
673 'custom content from namespaced Result loaded into static dump correctly '.
674 'when rewriting result_namespace';
676 # Now rewrite 'MyResult' to 'Mtfnpy'
679 result_namespace => 'Mtfnpy',
681 $schema = $res->{schema};
683 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Mtfnpy::Quux',
684 'using new result_namespace';
686 is result_count('Mtfnpy'), $RESULT_COUNT,
687 'correct number of Results after rewritten result_namespace';
689 ok ((not -d result_dir('MyResult')),
690 'original Result dir was removed when rewriting result_namespace');
692 # check that custom and external content was preserved
693 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
694 'external content was carried over when rewriting result_namespace';
696 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
697 'custom content was carried over when rewriting result_namespace';
699 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
700 $res->{classes}{bazs} }
701 'class names in custom content are translated when rewriting result_namespace';
703 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
704 $res->{classes}{bazs} }
705 'class names in external content are translated when rewriting '.
708 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
709 $res->{classes}{foos} }
710 'class names in external content are translated when rewriting '.
713 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
714 'custom content from namespaced Result loaded into static dump correctly '.
715 'when rewriting result_namespace';
717 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
718 'external content from unsingularized Result loaded into static dump correctly';
721 # test upgrading a v4 schema, then check that the version string is correct
724 write_v4_schema_pm();
725 run_loader(static => 1);
726 my $res = run_loader(static => 1, naming => 'current');
727 my $schema = $res->{schema};
729 my $file = $schema->_loader->_get_dump_filename($SCHEMA_CLASS);
730 my $code = slurp $file;
733 $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m;
735 is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION,
736 'correct version dumped after upgrade of v4 static schema';
739 # Test upgrading an already singular result with custom content that refers to
743 write_v4_schema_pm();
744 my $res = run_loader(static => 1);
745 my $schema = $res->{schema};
748 # add some custom content to a Result that will be replaced
749 add_custom_content($schema, { Bar => 'Foos' });
751 # now upgrade the schema
752 $res = run_loader(static => 1, naming => 'current');
753 $schema = $res->{schema};
756 # check that custom content was preserved
757 lives_and { is $schema->resultset('Bar')->find(1)->b_method, 'dongs' }
758 'custom content was preserved from Result pre-upgrade';
760 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
761 $res->{classes}{foos} }
762 'unsingularized class names in custom content from Result with unchanged ' .
763 'name are translated';
765 class_content_like $schema, $res->{classes}{bar}, qr/sub b_method { 'dongs' }/,
766 'custom content from Result with unchanged name loaded into static dump ' .
770 # test creating static schema in v5 mode then upgrade to current with external
775 write_v5_schema_pm();
777 my $res = run_loader(static => 1);
779 like $res->{warnings}[0], qr/0.05003 static schema/, 'backcompat warning';
783 my $temp_dir = setup_load_external({
784 Baz => 'StationsVisited',
785 StationsVisited => 'Quux',
786 }, { result_namespace => 'Result' });
788 add_custom_content($res->{schema}, {
789 Baz => 'StationsVisited',
791 result_namespace => 'Result',
792 rel_name_map => { BazStationsvisited => 'custom_content_rel' },
795 $res = run_loader(static => 1, naming => 'current');
796 my $schema = $res->{schema};
800 lives_and { is $schema->resultset('Baz')->find(1)->a_method, 'hlagh' }
801 'external custom content loaded for v5 -> v6';
803 lives_and { isa_ok $schema->resultset('Baz')->find(1)->stationsvisitedrel,
804 $res->{classes}{stations_visited} }
805 'external content rewritten for v5 -> v6';
807 lives_and { isa_ok $schema->resultset('Baz')->find(1)->custom_content_rel,
808 $res->{classes}{stations_visited} }
809 'custom content rewritten for v5 -> v6';
811 lives_and { isa_ok $schema->resultset('StationVisited')->find(1)->quuxrel,
812 $res->{classes}{quuxs} }
813 'external content rewritten for v5 -> v6 for upgraded Result class names';
816 # test creating static schema in v6 mode then upgrade to current with external
821 write_v6_schema_pm();
823 my $res = run_loader(static => 1);
825 like $res->{warnings}[0], qr/0.06001 static schema/, 'backcompat warning';
829 my $temp_dir = setup_load_external({
830 Routechange => 'Quux',
831 }, { result_namespace => 'Result' });
833 add_custom_content($res->{schema}, {
834 Routechange => 'Quux',
836 result_namespace => 'Result',
837 rel_name_map => { RoutechangeQuux => 'custom_content_rel' },
840 $res = run_loader(static => 1, naming => 'current');
841 my $schema = $res->{schema};
845 lives_and { is $schema->resultset('RouteChange')->find(1)->a_method, 'hlagh' }
846 'external custom content loaded for v6 -> v7';
848 lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->quuxrel,
849 $res->{classes}{quuxs} }
850 'external content rewritten for v6 -> v7';
852 lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->custom_content_rel,
853 $res->{classes}{quuxs} }
854 'custom content rewritten for v6 -> v7';
860 rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
869 my %loader_opts = @_;
871 $loader_opts{dump_directory} = $DUMP_DIR if delete $loader_opts{static};
873 clean_dumpdir() if delete $loader_opts{clean_dumpdir};
876 foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
877 Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
880 Class::Unload->unload($SCHEMA_CLASS);
884 my @connect_info = $make_dbictest_db_with_unique::dsn;
886 local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); };
888 package $SCHEMA_CLASS;
889 use base qw/DBIx::Class::Schema::Loader/;
891 __PACKAGE__->loader_options(\%loader_opts);
892 __PACKAGE__->connection(\@connect_info);
895 ok(!$@, "Loader initialization") or diag $@;
897 my $schema = $SCHEMA_CLASS->clone;
898 my (%monikers, %classes);
899 foreach my $source_name ($schema->sources) {
900 my $table_name = $schema->source($source_name)->from;
901 $monikers{$table_name} = $source_name;
902 $classes{$table_name} = $schema->source($source_name)->result_class;
907 warnings => \@loader_warnings,
908 monikers => \%monikers,
909 classes => \%classes,
913 sub write_v4_schema_pm {
916 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
918 make_path $schema_dir;
919 my $schema_pm = "$schema_dir/Schema.pm";
920 open my $fh, '>', $schema_pm or die $!;
921 if (not $opts{use_namespaces}) {
923 package DBIXCSL_Test::Schema;
928 use base 'DBIx::Class::Schema';
930 __PACKAGE__->load_classes;
933 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25
934 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog
937 # You can replace this text with custom content, and it will be preserved on regeneration
943 package DBIXCSL_Test::Schema;
948 use base 'DBIx::Class::Schema';
950 __PACKAGE__->load_namespaces;
953 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2010-01-12 16:04:12
954 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:d3wRVsHBNisyhxeaWJZcZQ
957 # You can replace this text with custom content, and it will be preserved on
964 sub write_v5_schema_pm {
967 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
969 make_path $schema_dir;
970 my $schema_pm = "$schema_dir/Schema.pm";
971 open my $fh, '>', $schema_pm or die $!;
972 if (exists $opts{use_namespaces} && $opts{use_namespaces} == 0) {
974 package DBIXCSL_Test::Schema;
976 # Created by DBIx::Class::Schema::Loader
977 # DO NOT MODIFY THE FIRST PART OF THIS FILE
982 use base 'DBIx::Class::Schema';
984 __PACKAGE__->load_classes;
987 # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-27 17:07:37
988 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:LIzC/LT5IYvWpgusfbqMrg
991 # You can replace this text with custom content, and it will be preserved on regeneration
997 package DBIXCSL_Test::Schema;
999 # Created by DBIx::Class::Schema::Loader
1000 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1005 use base 'DBIx::Class::Schema';
1007 __PACKAGE__->load_namespaces;
1010 # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-29 19:44:52
1011 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:D+MYxtGxz97Ghvido5DTEg
1014 # You can replace this text with custom content, and it will be preserved on regeneration
1020 sub write_v6_schema_pm {
1023 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
1025 make_path $schema_dir;
1026 my $schema_pm = "$schema_dir/Schema.pm";
1027 open my $fh, '>', $schema_pm or die $!;
1028 if (exists $opts{use_namespaces} && $opts{use_namespaces} == 0) {
1030 package DBIXCSL_Test::Schema;
1032 # Created by DBIx::Class::Schema::Loader
1033 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1038 use base 'DBIx::Class::Schema';
1040 __PACKAGE__->load_classes;
1043 # Created by DBIx::Class::Schema::Loader v0.06001 @ 2010-04-21 19:56:03
1044 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:/fqZCb95hsGIe1g5qyQQZg
1047 # You can replace this text with custom content, and it will be preserved on regeneration
1053 package DBIXCSL_Test::Schema;
1055 # Created by DBIx::Class::Schema::Loader
1056 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1061 use base 'DBIx::Class::Schema';
1063 __PACKAGE__->load_namespaces;
1066 # Created by DBIx::Class::Schema::Loader v0.06001 @ 2010-04-21 19:54:31
1067 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:nwO5Vi47kl0X9SpEoiVO5w
1070 # You can replace this text with custom content, and it will be preserved on regeneration
1078 my $schema = $res->{schema};
1080 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1081 [qw/Foos Bar Bazs Quuxs StationsVisited Routechange Email/],
1082 'correct monikers in 0.04006 mode';
1084 isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
1085 $res->{classes}{bar},
1088 isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
1089 'correct rel name in 0.04006 mode';
1091 ok my $baz = eval { $schema->resultset('Bazs')->find(1) };
1093 isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
1094 'correct rel type and name for UNIQUE FK in 0.04006 mode';
1096 ok my $foo = eval { $schema->resultset('Foos')->find(1) };
1098 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
1099 'correct rel name inflection in 0.04006 mode';
1104 my $schema = $res->{schema};
1106 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1107 [qw/Foo Bar Baz Quux StationsVisited Routechange Email/],
1108 'correct monikers in v5 mode';
1110 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1112 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1113 'correct rel name in v5 mode';
1115 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1117 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1118 'correct rel type and name for UNIQUE FK in v5 mode';
1120 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1122 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
1123 'correct rel name inflection in v5 mode';
1128 my $schema = $res->{schema};
1130 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1131 [qw/Foo Bar Baz Quux StationVisited Routechange Email/],
1132 'correct monikers in v6 mode';
1134 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1136 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1137 'correct rel name in v6 mode';
1139 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1141 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1142 'correct rel type and name for UNIQUE FK in v6 mode';
1144 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1146 isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet',
1147 'correct rel name inflection in v6 mode';
1152 my $schema = $res->{schema};
1154 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1155 [qw/Foo Bar Baz Quux StationVisited RouteChange Email/],
1156 'correct monikers in current mode';
1158 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1160 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1161 'correct rel name in current mode';
1163 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1165 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1166 'correct rel type and name for UNIQUE FK in current mode';
1168 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1170 isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet',
1171 'correct rel name inflection in current mode';
1175 package DBICSL::Test::TempExtDir;
1177 use overload '""' => sub { ${$_[0]} };
1181 File::Path::rmtree ${$_[0]};
1185 sub setup_load_external {
1186 my ($rels, $opts) = @_;
1188 my $temp_dir = tempdir(CLEANUP => 1);
1189 push @INC, $temp_dir;
1191 my $external_result_dir = join '/', $temp_dir, (split /::/, $SCHEMA_CLASS),
1192 ($opts->{result_namespace} || ());
1194 make_path $external_result_dir;
1196 while (my ($from, $to) = each %$rels) {
1197 write_ext_result($external_result_dir, $from, $to, $opts);
1200 my $guard = bless \$temp_dir, 'DBICSL::Test::TempExtDir';
1205 sub write_ext_result {
1206 my ($result_dir, $from, $to, $opts) = @_;
1208 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1209 my $from_class = _qualify_class($from, $opts->{result_namespace});
1210 my $to_class = _qualify_class($to, $opts->{result_namespace});
1211 my $condition = _rel_condition($from, $to);
1213 IO::File->new(">$result_dir/${from}.pm")->print(<<"EOF");
1214 package ${from_class};
1215 sub a_method { 'hlagh' }
1217 __PACKAGE__->has_one('$relname', '$to_class',
1229 return Lingua::EN::Inflect::Number::to_S(lc $to) . 'rel';
1232 sub _qualify_class {
1233 my ($class, $result_namespace) = @_;
1235 return $SCHEMA_CLASS . '::'
1236 . ($result_namespace ? $result_namespace . '::' : '')
1241 my ($from, $to) = @_;
1243 return join '', map ucfirst(Lingua::EN::Inflect::Number::to_S(lc($_))), $from, $to;
1246 sub _rel_condition {
1247 my ($from, $to) = @_;
1250 QuuxBaz => q{'foreign.baz_num' => 'self.baz_id'},
1251 BarFoo => q{'foreign.fooid' => 'self.foo_id'},
1252 BazStationsvisited => q{'foreign.id' => 'self.stations_visited_id'},
1253 StationsvisitedQuux => q{'foreign.quuxid' => 'self.quuxs_id'},
1254 RoutechangeQuux => q{'foreign.quuxid' => 'self.quuxs_id'},
1255 }->{_rel_key($from, $to)};
1258 sub class_content_like {
1259 my ($schema, $class, $re, $test_name) = @_;
1261 my $file = $schema->_loader->_get_dump_filename($class);
1262 my $code = slurp $file;
1264 like $code, $re, $test_name;
1267 sub add_custom_content {
1268 my ($schema, $rels, $opts) = @_;
1270 while (my ($from, $to) = each %$rels) {
1271 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1272 my $from_class = _qualify_class($from, $opts->{result_namespace});
1273 my $to_class = _qualify_class($to, $opts->{result_namespace});
1274 my $condition = _rel_condition($from, $to);
1276 my $content = <<"EOF";
1277 package ${from_class};
1278 sub b_method { 'dongs' }
1280 __PACKAGE__->has_one('$relname', '$to_class',
1286 _write_custom_content($schema, $from_class, $content);
1290 sub _write_custom_content {
1291 my ($schema, $class, $content) = @_;
1293 my $pm = $schema->_loader->_get_dump_filename($class);
1295 local ($^I, @ARGV) = ('.bak', $pm);
1297 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
1306 unlink "${pm}.bak" or die $^E;
1311 my $path = shift || '';
1313 my $dir = result_dir($path);
1315 my $file_count =()= glob "$dir/*";
1321 my $path = shift || '';
1323 my $dir = result_dir($path);
1325 return glob "$dir/*";
1328 sub schema_files { result_files(@_) }
1331 my $path = shift || '';
1333 (my $dir = "$DUMP_DIR/$SCHEMA_CLASS/$path") =~ s{::}{/}g;
1339 sub schema_dir { result_dir(@_) }
1341 # vim:et sts=4 sw=4 tw=0: