4 use File::Path qw/rmtree make_path/;
6 use File::Temp qw/tempfile tempdir/;
11 my $DUMP_DIR = './t/_common_dump';
13 my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema';
15 # test dynamic schema in 0.04006 mode
17 my $res = run_loader();
18 my $warning = $res->{warnings}[0];
20 like $warning, qr/dynamic schema/i,
21 'dynamic schema in backcompat mode detected';
22 like $warning, qr/run in 0\.04006 mode/i,
23 'dynamic schema in 0.04006 mode warning';
24 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
25 'warning refers to upgrading doc';
30 # setting naming accessor on dynamic schema should disable warning (even when
31 # we're setting it to 'v4' .)
33 my $res = run_loader(naming => 'v4');
35 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
40 # test upgraded dynamic schema
42 my $res = run_loader(naming => 'current');
44 # to dump a schema for debugging...
47 # $schema->_loader->{dump_directory} = '/tmp/HLAGH';
48 # $schema->_loader->_dump_to_dir(values %{ $res->{classes} });
51 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
56 # test upgraded dynamic schema with external content loaded
58 my $temp_dir = tempdir;
61 my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
62 make_path $external_result_dir;
64 IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
65 package ${SCHEMA_CLASS}::Quuxs;
66 sub a_method { 'hlagh' }
70 my $res = run_loader(naming => 'current');
71 my $schema = $res->{schema};
73 is scalar @{ $res->{warnings} }, 1,
74 'correct nummber of warnings for upgraded dynamic schema with external ' .
75 'content for unsingularized Result.';
77 my $warning = $res->{warnings}[0];
78 like $warning, qr/Detected external content/i,
79 'detected external content warning';
81 is eval { $schema->resultset('Quux')->find(1)->a_method }, 'hlagh',
82 'external custom content for unsingularized Result was loaded by upgraded ' .
91 # test upgraded static schema with external content loaded
93 my $temp_dir = tempdir;
96 my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
97 make_path $external_result_dir;
99 IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
100 package ${SCHEMA_CLASS}::Quuxs;
101 sub a_method { 'dongs' }
105 write_v4_schema_pm();
107 my $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
108 my $schema = $res->{schema};
112 is eval { $schema->resultset('Quux')->find(1)->a_method }, 'dongs',
113 'external custom content for unsingularized Result was loaded by upgraded ' .
116 my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs});
117 my $code = do { local ($/, @ARGV) = (undef, $file); <> };
119 like $code, qr/package ${SCHEMA_CLASS}::Quux;/,
120 'package line translated correctly from external custom content in static dump';
122 like $code, qr/sub a_method { 'dongs' }/,
123 'external custom content loaded into static dump correctly';
129 # test running against v4 schema without upgrade
131 write_v4_schema_pm();
134 my $res = run_loader(dump_directory => $DUMP_DIR);
135 my $warning = $res->{warnings}[0];
137 like $warning, qr/static schema/i,
138 'static schema in backcompat mode detected';
139 like $warning, qr/0.04006/,
140 'correct version detected';
141 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
142 'refers to upgrading doc';
144 is scalar @{ $res->{warnings} }, 3,
145 'correct number of warnings for static schema in backcompat mode';
149 # add some custom content to a Result that will be replaced
150 my $schema = $res->{schema};
151 my $quuxs_pm = $schema->_loader
152 ->_get_dump_filename($res->{classes}{quuxs});
154 local ($^I, @ARGV) = ('', $quuxs_pm);
156 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
158 print "sub a_method { 'mtfnpy' }\n";
166 # now upgrade the schema
167 $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
168 $schema = $res->{schema};
170 like $res->{warnings}[0], qr/Dumping manual schema/i,
171 'correct warnings on upgrading static schema (with "naming" set)';
173 like $res->{warnings}[1], qr/dump completed/i,
174 'correct warnings on upgrading static schema (with "naming" set)';
176 is scalar @{ $res->{warnings} }, 2,
177 'correct number of warnings on upgrading static schema (with "naming" set)'
178 or diag @{ $res->{warnings} };
182 (my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g;
183 my $result_count =()= glob "$result_dir/*";
186 'un-singularized results were replaced during upgrade';
188 # check that custom content was preserved
189 is eval { $schema->resultset('Quux')->find(1)->a_method }, 'mtfnpy',
190 'custom content was carried over from un-singularized Result';
196 rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
200 my %loader_opts = @_;
203 foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
204 Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
207 Class::Unload->unload($SCHEMA_CLASS);
211 my @connect_info = $make_dbictest_db2::dsn;
213 local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); };
215 package $SCHEMA_CLASS;
216 use base qw/DBIx::Class::Schema::Loader/;
218 __PACKAGE__->loader_options(\%loader_opts);
219 __PACKAGE__->connection(\@connect_info);
222 ok(!$@, "Loader initialization") or diag $@;
224 my $schema = $SCHEMA_CLASS->clone;
225 my (%monikers, %classes);
226 foreach my $source_name ($schema->sources) {
227 my $table_name = $schema->source($source_name)->from;
228 $monikers{$table_name} = $source_name;
229 $classes{$table_name} = "${SCHEMA_CLASS}::${source_name}";
234 warnings => \@loader_warnings,
235 monikers => \%monikers,
236 classes => \%classes,
240 sub write_v4_schema_pm {
241 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
243 make_path $schema_dir;
244 my $schema_pm = "$schema_dir/Schema.pm";
245 open my $fh, '>', $schema_pm or die $!;
247 package DBIXCSL_Test::Schema;
252 use base 'DBIx::Class::Schema';
254 __PACKAGE__->load_classes;
257 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25
258 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog
261 # You can replace this text with custom content, and it will be preserved on regeneration
268 my $schema = $res->{schema};
270 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
271 [qw/Foos Bar Bazs Quuxs/],
272 'correct monikers in 0.04006 mode';
274 isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
275 $res->{classes}{bar},
278 isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
279 'correct rel name in 0.04006 mode';
281 ok my $baz = eval { $schema->resultset('Bazs')->find(1) };
283 isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
284 'correct rel type and name for UNIQUE FK in 0.04006 mode';
289 my $schema = $res->{schema};
291 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
292 [qw/Foo Bar Baz Quux/],
293 'correct monikers in current mode';
295 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
297 isa_ok eval { $bar->foo }, $res->{classes}{foos},
298 'correct rel name in current mode';
300 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
302 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
303 'correct rel type and name for UNIQUE FK in current mode';