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';
19 sub class_content_like;
21 # test dynamic schema in 0.04006 mode
23 my $res = run_loader();
24 my $warning = $res->{warnings}[0];
26 like $warning, qr/dynamic schema/i,
27 'dynamic schema in backcompat mode detected';
28 like $warning, qr/run in 0\.04006 mode/i,
29 'dynamic schema in 0.04006 mode warning';
30 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
31 'warning refers to upgrading doc';
36 # setting naming accessor on dynamic schema should disable warning (even when
37 # we're setting it to 'v4' .)
39 my $res = run_loader(naming => 'v4');
40 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
44 # test upgraded dynamic schema
46 my $res = run_loader(naming => 'current');
47 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
51 # test upgraded dynamic schema with external content loaded
53 my $temp_dir = setup_load_external({
58 my $res = run_loader(naming => 'current');
59 my $schema = $res->{schema};
61 is scalar @{ $res->{warnings} }, 1,
62 'correct nummber of warnings for upgraded dynamic schema with external ' .
63 'content for unsingularized Result.';
65 my $warning = $res->{warnings}[0];
66 like $warning, qr/Detected external content/i,
67 'detected external content warning';
69 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
70 'external custom content for unsingularized Result was loaded by upgraded ' .
73 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
74 $res->{classes}{bazs} }
75 'unsingularized class names in external content are translated';
77 lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'hlagh' }
78 'external content from unchanged Result class';
80 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
81 $res->{classes}{foos} }
82 'unsingularized class names in external content from unchanged Result class ' .
83 'names are translated';
88 # test upgraded dynamic schema with use_namespaces with external content loaded
90 my $temp_dir = setup_load_external({
95 my $res = run_loader(naming => 'current', use_namespaces => 1);
96 my $schema = $res->{schema};
98 is scalar @{ $res->{warnings} }, 2,
99 'correct nummber of warnings for upgraded dynamic schema with external ' .
100 'content for unsingularized Result with use_namespaces.';
102 my $warning = $res->{warnings}[0];
103 like $warning, qr/Detected external content/i,
104 'detected external content warning';
106 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
107 'external custom content for unsingularized Result was loaded by upgraded ' .
110 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
111 $res->{classes}{bazs} }
112 'unsingularized class names in external content are translated';
114 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
115 $res->{classes}{foos} }
116 'unsingularized class names in external content from unchanged Result class ' .
117 'names are translated';
122 # test upgraded static schema with external content loaded
126 my $temp_dir = setup_load_external({
131 write_v4_schema_pm();
133 my $res = run_loader(static => 1, naming => 'current');
134 my $schema = $res->{schema};
138 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
139 'external custom content for unsingularized Result was loaded by upgraded ' .
142 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
143 $res->{classes}{bazs} }
144 'unsingularized class names in external content are translated';
146 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
147 $res->{classes}{foos} }
148 'unsingularized class names in external content from unchanged Result class ' .
149 'names are translated in static schema';
151 class_content_like $schema, $res->{classes}{quuxs}, qr/package ${SCHEMA_CLASS}::Quux;/,
152 'package line translated correctly from external custom content in static dump';
154 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
155 'external custom content loaded into static dump correctly';
158 # test creating static schema in v5 mode then upgrade to current with external
160 # XXX needs real load_external tests
164 my $temp_dir = setup_load_external({
167 }, { result_namespace => 'Result' });
169 write_v5_schema_pm();
171 my $res = run_loader(static => 1);
175 $res = run_loader(static => 1, naming => 'current');
176 my $schema = $res->{schema};
181 # test running against v4 schema without upgrade, twice, then upgrade
184 write_v4_schema_pm();
185 my $res = run_loader(static => 1);
186 my $warning = $res->{warnings}[1];
188 like $warning, qr/static schema/i,
189 'static schema in backcompat mode detected';
190 like $warning, qr/0.04006/,
191 'correct version detected';
192 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
193 'refers to upgrading doc';
195 is scalar @{ $res->{warnings} }, 4,
196 'correct number of warnings for static schema in backcompat mode';
200 add_custom_content($res->{schema}, {
204 # Rerun the loader in backcompat mode to make sure it's still in backcompat
206 $res = run_loader(static => 1);
209 # now upgrade the schema
215 my $schema = $res->{schema};
217 like $res->{warnings}[0], qr/Dumping manual schema/i,
218 'correct warnings on upgrading static schema (with "naming" set)';
220 like $res->{warnings}[1], qr/dump completed/i,
221 'correct warnings on upgrading static schema (with "naming" set)';
223 is scalar @{ $res->{warnings} }, 2,
224 'correct number of warnings on upgrading static schema (with "naming" set)'
225 or diag @{ $res->{warnings} };
229 is result_count('Result'), 6,
230 'un-singularized results were replaced during upgrade';
232 # check that custom content was preserved
233 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
234 'custom content was carried over from un-singularized Result';
236 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
237 $res->{classes}{bazs} }
238 'unsingularized class names in custom content are translated';
240 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
241 'custom content from unsingularized Result loaded into static dump correctly';
244 # test running against v4 schema without upgrade, then upgrade with
245 # use_namespaces not explicitly set
248 write_v4_schema_pm();
249 my $res = run_loader(static => 1);
250 my $warning = $res->{warnings}[1];
252 like $warning, qr/static schema/i,
253 'static schema in backcompat mode detected';
254 like $warning, qr/0.04006/,
255 'correct version detected';
256 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
257 'refers to upgrading doc';
259 is scalar @{ $res->{warnings} }, 4,
260 'correct number of warnings for static schema in backcompat mode';
264 add_custom_content($res->{schema}, {
268 # now upgrade the schema
273 my $schema = $res->{schema};
275 like $res->{warnings}[0], qr/load_classes/i,
276 'correct warnings on upgrading static schema (with "naming" set and ' .
277 'use_namespaces not set)';
279 like $res->{warnings}[1], qr/Dumping manual schema/i,
280 'correct warnings on upgrading static schema (with "naming" set and ' .
281 'use_namespaces not set)';
283 like $res->{warnings}[2], qr/dump completed/i,
284 'correct warnings on upgrading static schema (with "naming" set and ' .
285 'use_namespaces not set)';
287 is scalar @{ $res->{warnings} }, 3,
288 'correct number of warnings on upgrading static schema (with "naming" set)'
289 or diag @{ $res->{warnings} };
293 is result_count(), 6,
294 'un-singularized results were replaced during upgrade';
296 # check that custom content was preserved
297 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
298 'custom content was carried over from un-singularized Result';
300 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
301 $res->{classes}{bazs} }
302 'unsingularized class names in custom content are translated';
304 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
305 'custom content from unsingularized Result loaded into static dump correctly';
308 # test running against v4 schema with load_namespaces, upgrade to current but
309 # downgrade to load_classes, with external content
313 my $temp_dir = setup_load_external({
316 }, { result_namespace => 'Result' });
318 write_v4_schema_pm(use_namespaces => 1);
320 my $res = run_loader(static => 1);
321 my $warning = $res->{warnings}[0];
323 like $warning, qr/static schema/i,
324 'static schema in backcompat mode detected';
325 like $warning, qr/0.04006/,
326 'correct version detected';
327 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
328 'refers to upgrading doc';
330 is scalar @{ $res->{warnings} }, 3,
331 'correct number of warnings for static schema in backcompat mode';
335 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quuxs',
336 'use_namespaces in backcompat mode';
338 add_custom_content($res->{schema}, {
341 result_namespace => 'Result',
342 rel_name_map => { QuuxBaz => 'bazrel2' },
345 # now upgrade the schema to current but downgrade to load_classes
351 my $schema = $res->{schema};
353 like $res->{warnings}[0], qr/Dumping manual schema/i,
354 'correct warnings on upgrading static schema (with "naming" set and ' .
355 'use_namespaces => 0)';
357 like $res->{warnings}[1], qr/dump completed/i,
358 'correct warnings on upgrading static schema (with "naming" set and ' .
359 'use_namespaces => 0)';
361 is scalar @{ $res->{warnings} }, 2,
362 'correct number of warnings on upgrading static schema (with "naming" set)'
363 or diag @{ $res->{warnings} };
367 is result_count(), 6,
368 'un-singularized results were replaced during upgrade and Result dir removed';
370 ok ((not -d result_dir('Result')),
371 'Result dir was removed for load_classes downgrade');
373 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
374 'load_classes in upgraded mode';
376 # check that custom and external content was preserved
377 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
378 'custom content was carried over from un-singularized Result';
380 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
381 'external content was carried over from un-singularized Result';
383 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
384 $res->{classes}{bazs} }
385 'unsingularized class names in custom content are translated';
387 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
388 $res->{classes}{bazs} }
389 'unsingularized class names in external content are translated';
391 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
392 $res->{classes}{foos} }
393 'unsingularized class names in external content from unchanged Result class ' .
394 'names are translated in static schema';
396 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
397 'external content from unsingularized Result loaded into static dump correctly';
399 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
400 'custom content from unsingularized Result loaded into static dump correctly';
403 # test a regular schema with use_namespaces => 0 upgraded to
404 # use_namespaces => 1
406 my $res = run_loader(
412 like $res->{warnings}[0], qr/Dumping manual schema/i,
413 'correct warnings on dumping static schema with use_namespaces => 0';
415 like $res->{warnings}[1], qr/dump completed/i,
416 'correct warnings on dumping static schema with use_namespaces => 0';
418 is scalar @{ $res->{warnings} }, 2,
419 'correct number of warnings on dumping static schema with use_namespaces => 0'
420 or diag @{ $res->{warnings} };
424 my $schema = $res->{schema};
425 add_custom_content($res->{schema}, {
429 # test that with no use_namespaces option, there is a warning and
430 # load_classes is preserved
431 $res = run_loader(static => 1);
433 like $res->{warnings}[0], qr/load_classes/i,
434 'correct warnings on re-dumping static schema with load_classes';
436 like $res->{warnings}[1], qr/Dumping manual schema/i,
437 'correct warnings on re-dumping static schema with load_classes';
439 like $res->{warnings}[2], qr/dump completed/i,
440 'correct warnings on re-dumping static schema with load_classes';
442 is scalar @{ $res->{warnings} }, 3,
443 'correct number of warnings on re-dumping static schema with load_classes'
444 or diag @{ $res->{warnings} };
446 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
447 'load_classes preserved on re-dump';
451 # now upgrade the schema to use_namespaces
456 $schema = $res->{schema};
458 like $res->{warnings}[0], qr/Dumping manual schema/i,
459 'correct warnings on upgrading to use_namespaces';
461 like $res->{warnings}[1], qr/dump completed/i,
462 'correct warnings on upgrading to use_namespaces';
464 is scalar @{ $res->{warnings} }, 2,
465 'correct number of warnings on upgrading to use_namespaces'
466 or diag @{ $res->{warnings} };
470 my @schema_files = schema_files();
472 is 1, (scalar @schema_files),
473 "schema dir contains only 1 entry";
475 like $schema_files[0], qr{/Result\z},
476 "schema dir contains only a Result/ directory";
478 # check that custom content was preserved
479 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
480 'custom content was carried over during use_namespaces upgrade';
482 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
483 $res->{classes}{bazs} }
484 'un-namespaced class names in custom content are translated';
486 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
487 'custom content from un-namespaced Result loaded into static dump correctly';
490 # test a regular schema with default use_namespaces => 1, redump, and downgrade
493 my $res = run_loader(clean_dumpdir => 1, static => 1);
495 like $res->{warnings}[0], qr/Dumping manual schema/i,
496 'correct warnings on dumping static schema';
498 like $res->{warnings}[1], qr/dump completed/i,
499 'correct warnings on dumping static schema';
501 is scalar @{ $res->{warnings} }, 2,
502 'correct number of warnings on dumping static schema'
503 or diag @{ $res->{warnings} };
507 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
508 'defaults to use_namespaces on regular dump';
510 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result' });
512 # test that with no use_namespaces option, use_namespaces is preserved
513 $res = run_loader(static => 1);
515 like $res->{warnings}[0], qr/Dumping manual schema/i,
516 'correct warnings on re-dumping static schema';
518 like $res->{warnings}[1], qr/dump completed/i,
519 'correct warnings on re-dumping static schema';
521 is scalar @{ $res->{warnings} }, 2,
522 'correct number of warnings on re-dumping static schema'
523 or diag @{ $res->{warnings} };
525 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
526 'use_namespaces preserved on re-dump';
530 # now downgrade the schema to load_classes
535 my $schema = $res->{schema};
537 like $res->{warnings}[0], qr/Dumping manual schema/i,
538 'correct warnings on downgrading to load_classes';
540 like $res->{warnings}[1], qr/dump completed/i,
541 'correct warnings on downgrading to load_classes';
543 is scalar @{ $res->{warnings} }, 2,
544 'correct number of warnings on downgrading to load_classes'
545 or diag @{ $res->{warnings} };
549 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
550 'load_classes downgrade correct';
552 is result_count(), 6,
553 'correct number of Results after upgrade and Result dir removed';
555 ok ((not -d result_dir('Result')),
556 'Result dir was removed for load_classes downgrade');
558 # check that custom content was preserved
559 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
560 'custom content was carried over during load_classes downgrade';
562 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
563 $res->{classes}{bazs} }
564 'namespaced class names in custom content are translated during load_classes '.
567 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
568 'custom content from namespaced Result loaded into static dump correctly '.
569 'during load_classes downgrade';
572 # test a regular schema with use_namespaces => 1 and a custom result_namespace
573 # downgraded to load_classes
575 my $res = run_loader(
578 result_namespace => 'MyResult',
581 like $res->{warnings}[0], qr/Dumping manual schema/i,
582 'correct warnings on dumping static schema';
584 like $res->{warnings}[1], qr/dump completed/i,
585 'correct warnings on dumping static schema';
587 is scalar @{ $res->{warnings} }, 2,
588 'correct number of warnings on dumping static schema'
589 or diag @{ $res->{warnings} };
593 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
594 'defaults to use_namespaces and uses custom result_namespace';
596 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'MyResult' });
598 # test that with no use_namespaces option, use_namespaces is preserved, and
599 # the custom result_namespace is preserved
600 $res = run_loader(static => 1);
602 like $res->{warnings}[0], qr/Dumping manual schema/i,
603 'correct warnings on re-dumping static schema';
605 like $res->{warnings}[1], qr/dump completed/i,
606 'correct warnings on re-dumping static schema';
608 is scalar @{ $res->{warnings} }, 2,
609 'correct number of warnings on re-dumping static schema'
610 or diag @{ $res->{warnings} };
612 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
613 'use_namespaces and custom result_namespace preserved on re-dump';
617 # now downgrade the schema to load_classes
622 my $schema = $res->{schema};
624 like $res->{warnings}[0], qr/Dumping manual schema/i,
625 'correct warnings on downgrading to load_classes';
627 like $res->{warnings}[1], qr/dump completed/i,
628 'correct warnings on downgrading to load_classes';
630 is scalar @{ $res->{warnings} }, 2,
631 'correct number of warnings on downgrading to load_classes'
632 or diag @{ $res->{warnings} };
636 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
637 'load_classes downgrade correct';
639 is result_count(), 6,
640 'correct number of Results after upgrade and Result dir removed';
642 ok ((not -d result_dir('MyResult')),
643 'Result dir was removed for load_classes downgrade');
645 # check that custom content was preserved
646 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
647 'custom content was carried over during load_classes downgrade';
649 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
650 $res->{classes}{bazs} }
651 'namespaced class names in custom content are translated during load_classes '.
654 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
655 'custom content from namespaced Result loaded into static dump correctly '.
656 'during load_classes downgrade';
659 # rewrite from one result_namespace to another, with external content
662 my $temp_dir = setup_load_external({ Quux => 'Baz', Bar => 'Foo' }, { result_namespace => 'Result' });
664 my $res = run_loader(static => 1);
666 # add some custom content to a Result that will be replaced
667 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result', rel_name_map => { QuuxBaz => 'bazrel2' } });
669 # Rewrite implicit 'Result' to 'MyResult'
672 result_namespace => 'MyResult',
674 my $schema = $res->{schema};
676 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
677 'using new result_namespace';
679 is result_count('MyResult'), 6,
680 'correct number of Results after rewritten result_namespace';
682 ok ((not -d schema_dir('Result')),
683 'original Result dir was removed when rewriting result_namespace');
685 # check that custom content was preserved
686 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
687 'custom content was carried over when rewriting result_namespace';
689 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
690 $res->{classes}{bazs} }
691 'class names in custom content are translated when rewriting result_namespace';
693 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
694 'custom content from namespaced Result loaded into static dump correctly '.
695 'when rewriting result_namespace';
697 # Now rewrite 'MyResult' to 'Mtfnpy'
700 result_namespace => 'Mtfnpy',
702 $schema = $res->{schema};
704 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Mtfnpy::Quux',
705 'using new result_namespace';
707 is result_count('Mtfnpy'), 6,
708 'correct number of Results after rewritten result_namespace';
710 ok ((not -d result_dir('MyResult')),
711 'original Result dir was removed when rewriting result_namespace');
713 # check that custom and external content was preserved
714 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
715 'external content was carried over when rewriting result_namespace';
717 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
718 'custom content was carried over when rewriting result_namespace';
720 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
721 $res->{classes}{bazs} }
722 'class names in custom content are translated when rewriting result_namespace';
724 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
725 $res->{classes}{bazs} }
726 'class names in external content are translated when rewriting '.
729 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
730 $res->{classes}{foos} }
731 'class names in external content are translated when rewriting '.
734 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
735 'custom content from namespaced Result loaded into static dump correctly '.
736 'when rewriting result_namespace';
738 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
739 'external content from unsingularized Result loaded into static dump correctly';
742 # test upgrading a v4 schema, then check that the version string is correct
745 write_v4_schema_pm();
746 run_loader(static => 1);
747 my $res = run_loader(static => 1, naming => 'current');
748 my $schema = $res->{schema};
750 my $file = $schema->_loader->_get_dump_filename($SCHEMA_CLASS);
751 my $code = slurp $file;
754 $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m;
756 is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION,
757 'correct version dumped after upgrade of v4 static schema';
760 # Test upgrading an already singular result with custom content that refers to
764 write_v4_schema_pm();
765 my $res = run_loader(static => 1);
766 my $schema = $res->{schema};
769 # add some custom content to a Result that will be replaced
770 add_custom_content($schema, { Bar => 'Foos' });
772 # now upgrade the schema
773 $res = run_loader(static => 1, naming => 'current');
774 $schema = $res->{schema};
777 # check that custom content was preserved
778 lives_and { is $schema->resultset('Bar')->find(1)->b_method, 'dongs' }
779 'custom content was preserved from Result pre-upgrade';
781 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
782 $res->{classes}{foos} }
783 'unsingularized class names in custom content from Result with unchanged ' .
784 'name are translated';
786 class_content_like $schema, $res->{classes}{bar}, qr/sub b_method { 'dongs' }/,
787 'custom content from Result with unchanged name loaded into static dump ' .
794 rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
803 my %loader_opts = @_;
805 $loader_opts{dump_directory} = $DUMP_DIR if delete $loader_opts{static};
807 clean_dumpdir() if delete $loader_opts{clean_dumpdir};
810 foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
811 Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
814 Class::Unload->unload($SCHEMA_CLASS);
818 my @connect_info = $make_dbictest_db_with_unique::dsn;
820 local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); };
822 package $SCHEMA_CLASS;
823 use base qw/DBIx::Class::Schema::Loader/;
825 __PACKAGE__->loader_options(\%loader_opts);
826 __PACKAGE__->connection(\@connect_info);
829 ok(!$@, "Loader initialization") or diag $@;
831 my $schema = $SCHEMA_CLASS->clone;
832 my (%monikers, %classes);
833 foreach my $source_name ($schema->sources) {
834 my $table_name = $schema->source($source_name)->from;
835 $monikers{$table_name} = $source_name;
836 $classes{$table_name} = $schema->source($source_name)->result_class;
841 warnings => \@loader_warnings,
842 monikers => \%monikers,
843 classes => \%classes,
847 sub write_v4_schema_pm {
850 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
852 make_path $schema_dir;
853 my $schema_pm = "$schema_dir/Schema.pm";
854 open my $fh, '>', $schema_pm or die $!;
855 if (not $opts{use_namespaces}) {
857 package DBIXCSL_Test::Schema;
862 use base 'DBIx::Class::Schema';
864 __PACKAGE__->load_classes;
867 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25
868 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog
871 # You can replace this text with custom content, and it will be preserved on regeneration
877 package DBIXCSL_Test::Schema;
882 use base 'DBIx::Class::Schema';
884 __PACKAGE__->load_namespaces;
887 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2010-01-12 16:04:12
888 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:d3wRVsHBNisyhxeaWJZcZQ
891 # You can replace this text with custom content, and it will be preserved on
898 sub write_v5_schema_pm {
901 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
903 make_path $schema_dir;
904 my $schema_pm = "$schema_dir/Schema.pm";
905 open my $fh, '>', $schema_pm or die $!;
906 if (exists $opts{use_namespaces} && $opts{use_namespaces} == 0) {
908 package DBIXCSL_Test::Schema;
910 # Created by DBIx::Class::Schema::Loader
911 # DO NOT MODIFY THE FIRST PART OF THIS FILE
916 use base 'DBIx::Class::Schema';
918 __PACKAGE__->load_classes;
921 # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-27 17:07:37
922 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:LIzC/LT5IYvWpgusfbqMrg
925 # You can replace this text with custom content, and it will be preserved on regeneration
931 package DBIXCSL_Test::Schema;
933 # Created by DBIx::Class::Schema::Loader
934 # DO NOT MODIFY THE FIRST PART OF THIS FILE
939 use base 'DBIx::Class::Schema';
941 __PACKAGE__->load_classes;
944 # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-27 17:07:37
945 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:LIzC/LT5IYvWpgusfbqMrg
948 # You can replace this text with custom content, and it will be preserved on regeneration
956 my $schema = $res->{schema};
958 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited email/} ],
959 [qw/Foos Bar Bazs Quuxs StationsVisited Email/],
960 'correct monikers in 0.04006 mode';
962 isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
963 $res->{classes}{bar},
966 isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
967 'correct rel name in 0.04006 mode';
969 ok my $baz = eval { $schema->resultset('Bazs')->find(1) };
971 isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
972 'correct rel type and name for UNIQUE FK in 0.04006 mode';
974 ok my $foo = eval { $schema->resultset('Foos')->find(1) };
976 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
977 'correct rel name inflection in 0.04006 mode';
982 my $schema = $res->{schema};
984 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited email/} ],
985 [qw/Foo Bar Baz Quux StationsVisited Email/],
986 'correct monikers in current mode';
988 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
990 isa_ok eval { $bar->foo }, $res->{classes}{foos},
991 'correct rel name in v5 mode';
993 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
995 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
996 'correct rel type and name for UNIQUE FK in v5 mode';
998 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1000 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
1001 'correct rel name inflection in v5 mode';
1006 my $schema = $res->{schema};
1008 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited email/} ],
1009 [qw/Foo Bar Baz Quux StationVisited Email/],
1010 'correct monikers in current mode';
1012 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1014 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1015 'correct rel name in current mode';
1017 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1019 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1020 'correct rel type and name for UNIQUE FK in current mode';
1022 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1024 isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet',
1025 'correct rel name inflection in current mode';
1029 package DBICSL::Test::TempExtDir;
1031 use overload '""' => sub { ${$_[0]} };
1035 File::Path::rmtree ${$_[0]};
1039 sub setup_load_external {
1040 my ($rels, $opts) = @_;
1042 my $temp_dir = tempdir(CLEANUP => 1);
1043 push @INC, $temp_dir;
1045 my $external_result_dir = join '/', $temp_dir, (split /::/, $SCHEMA_CLASS),
1046 ($opts->{result_namespace} || ());
1048 make_path $external_result_dir;
1050 while (my ($from, $to) = each %$rels) {
1051 write_ext_result($external_result_dir, $from, $to, $opts);
1054 my $guard = bless \$temp_dir, 'DBICSL::Test::TempExtDir';
1059 sub write_ext_result {
1060 my ($result_dir, $from, $to, $opts) = @_;
1062 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1063 my $from_class = _qualify_class($from, $opts->{result_namespace});
1064 my $to_class = _qualify_class($to, $opts->{result_namespace});
1065 my $condition = _rel_condition($from, $to);
1067 IO::File->new(">$result_dir/${from}.pm")->print(<<"EOF");
1068 package ${from_class};
1069 sub a_method { 'hlagh' }
1071 __PACKAGE__->has_one('$relname', '$to_class',
1083 return Lingua::EN::Inflect::Number::to_S(lc $to) . 'rel';
1086 sub _qualify_class {
1087 my ($class, $result_namespace) = @_;
1089 return $SCHEMA_CLASS . '::'
1090 . ($result_namespace ? $result_namespace . '::' : '')
1095 my ($from, $to) = @_;
1097 return join '', map ucfirst(Lingua::EN::Inflect::Number::to_S(lc($_))), $from, $to;
1100 sub _rel_condition {
1101 my ($from, $to) = @_;
1104 QuuxBaz => q{'foreign.baz_num' => 'self.baz_id'},
1105 BarFoo => q{'foreign.fooid' => 'self.foo_id'},
1106 }->{_rel_key($from, $to)};
1109 sub class_content_like {
1110 my ($schema, $class, $re, $test_name) = @_;
1112 my $file = $schema->_loader->_get_dump_filename($class);
1113 my $code = slurp $file;
1115 like $code, $re, $test_name;
1118 sub add_custom_content {
1119 my ($schema, $rels, $opts) = @_;
1121 while (my ($from, $to) = each %$rels) {
1122 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1123 my $from_class = _qualify_class($from, $opts->{result_namespace});
1124 my $to_class = _qualify_class($to, $opts->{result_namespace});
1125 my $condition = _rel_condition($from, $to);
1127 my $content = <<"EOF";
1128 package ${from_class};
1129 sub b_method { 'dongs' }
1131 __PACKAGE__->has_one('$relname', '$to_class',
1137 _write_custom_content($schema, $from_class, $content);
1141 sub _write_custom_content {
1142 my ($schema, $class, $content) = @_;
1144 my $pm = $schema->_loader->_get_dump_filename($class);
1146 local ($^I, @ARGV) = ('.bak', $pm);
1148 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
1157 unlink "${pm}.bak" or die $^E;
1162 my $path = shift || '';
1164 my $dir = result_dir($path);
1166 my $file_count =()= glob "$dir/*";
1172 my $path = shift || '';
1174 my $dir = result_dir($path);
1176 return glob "$dir/*";
1179 sub schema_files { result_files(@_) }
1182 my $path = shift || '';
1184 (my $dir = "$DUMP_DIR/$SCHEMA_CLASS/$path") =~ s{::}{/}g;
1190 sub schema_dir { result_dir(@_) }
1192 # vim:et sts=4 sw=4 tw=0: