4 use File::Path qw/rmtree make_path/;
9 my $DUMP_DIR = './t/_common_dump';
11 my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema';
17 foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
18 Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
21 Class::Unload->unload($SCHEMA_CLASS);
25 my @connect_info = $make_dbictest_db2::dsn;
27 local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); };
29 package $SCHEMA_CLASS;
30 use base qw/DBIx::Class::Schema::Loader/;
32 __PACKAGE__->loader_options(\%loader_opts);
33 __PACKAGE__->connection(\@connect_info);
36 ok(!$@, "Loader initialization") or diag $@;
38 my $schema = $SCHEMA_CLASS->clone;
39 my (%monikers, %classes);
40 foreach my $source_name ($schema->sources) {
41 my $table_name = $schema->source($source_name)->from;
42 $monikers{$table_name} = $source_name;
43 $classes{$table_name} = "${SCHEMA_CLASS}::${source_name}";
48 warnings => \@loader_warnings,
49 monikers => \%monikers,
56 my $schema = $res->{schema};
58 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
59 [qw/Foos Bar Bazs Quuxs/],
60 'correct monikers in 0.04006 mode';
62 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
64 isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
65 'correct rel name in 0.04006 mode';
67 ok my $baz = eval { $schema->resultset('Bazs')->find(1) };
69 isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
70 'correct rel type and name for UNIQUE FK in 0.04006 mode';
75 my $schema = $res->{schema};
77 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
78 [qw/Foo Bar Baz Quux/],
79 'correct monikers in current mode';
81 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
83 isa_ok eval { $bar->foo }, $res->{classes}{foos},
84 'correct rel name in current mode';
86 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
88 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
89 'correct rel type and name for UNIQUE FK in current mode';
92 # test dynamic schema in 0.04006 mode
94 my $res = run_loader();
95 my $warning = $res->{warnings}[0];
97 like $warning, qr/dynamic schema/i,
98 'dynamic schema in backcompat mode detected';
99 like $warning, qr/run in 0\.04006 mode/i,
100 'dynamic schema in 0.04006 mode warning';
101 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
102 'warning refers to upgrading doc';
107 # setting naming accessor on dynamic schema should disable warning (even when
108 # we're setting it to 'v4' .)
110 my $res = run_loader(naming => 'v4');
112 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
117 # test upgraded dynamic schema
119 my $res = run_loader(naming => 'current');
121 # to dump a schema for debugging...
123 # mkdir '/tmp/HLAGH';
124 # $schema->_loader->{dump_directory} = '/tmp/HLAGH';
125 # $schema->_loader->_dump_to_dir(values %{ $res->{classes} });
128 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
133 # test running against v4 schema without upgrade
135 # write out the 0.04006 Schema.pm we have in __DATA__
136 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
137 make_path $schema_dir;
138 my $schema_pm = "$schema_dir/Schema.pm";
139 open my $fh, '>', $schema_pm or die $!;
146 my $res = run_loader(dump_directory => $DUMP_DIR);
147 my $warning = $res->{warnings}[0];
149 like $warning, qr/static schema/i,
150 'static schema in backcompat mode detected';
151 like $warning, qr/0.04006/,
152 'correct version detected';
153 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
154 'refers to upgrading doc';
158 # add some custom content to a Result that will be replaced
159 my $schema = $res->{schema};
160 my $quuxs_pm = $schema->_loader
161 ->_get_dump_filename($res->{classes}{quuxs});
163 local ($^I, @ARGV) = ('', $quuxs_pm);
165 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
167 print "sub a_method { 'mtfnpy' }\n";
175 # now upgrade the schema
176 $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
177 $schema = $res->{schema};
179 like $res->{warnings}[0], qr/Dumping manual schema/i,
180 'correct warnings on upgrading static schema (with "naming" set)';
182 like $res->{warnings}[1], qr/dump completed/i,
183 'correct warnings on upgrading static schema (with "naming" set)';
185 is scalar @{ $res->{warnings} }, 2,
186 'correct number of warnings on upgrading static schema (with "naming" set)'
187 or diag @{ $res->{warnings} };
191 (my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g;
192 my $result_count =()= glob "$result_dir/*";
195 'un-singularized results were replaced during upgrade';
197 # check that custom content was preserved
198 is eval { $schema->resultset('Quux')->find(1)->a_method }, 'mtfnpy',
199 'custom content was carried over from un-singularized Result';
204 END { rmtree $DUMP_DIR }
206 # a Schema.pm made with 0.04006
209 package DBIXCSL_Test::Schema;
214 use base 'DBIx::Class::Schema';
216 __PACKAGE__->load_classes;
219 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25
220 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog
223 # You can replace this text with custom content, and it will be preserved on regeneration