Commit | Line | Data |
66afce69 |
1 | use strict; |
2 | use warnings; |
3 | use Test::More; |
a0e0a56a |
4 | use File::Path qw/rmtree make_path/; |
66afce69 |
5 | use Class::Unload; |
6 | use lib qw(t/lib); |
7 | use make_dbictest_db2; |
8 | |
9 | my $DUMP_DIR = './t/_common_dump'; |
10 | rmtree $DUMP_DIR; |
a0e0a56a |
11 | my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema'; |
66afce69 |
12 | |
13 | sub run_loader { |
14 | my %loader_opts = @_; |
15 | |
f53dcdf0 |
16 | eval { |
17 | foreach my $source_name ($SCHEMA_CLASS->clone->sources) { |
18 | Class::Unload->unload("${SCHEMA_CLASS}::${source_name}"); |
19 | } |
20 | |
21 | Class::Unload->unload($SCHEMA_CLASS); |
22 | }; |
23 | undef $@; |
66afce69 |
24 | |
25 | my @connect_info = $make_dbictest_db2::dsn; |
26 | my @loader_warnings; |
27 | local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); }; |
28 | eval qq{ |
a0e0a56a |
29 | package $SCHEMA_CLASS; |
66afce69 |
30 | use base qw/DBIx::Class::Schema::Loader/; |
31 | |
32 | __PACKAGE__->loader_options(\%loader_opts); |
33 | __PACKAGE__->connection(\@connect_info); |
34 | }; |
35 | |
36 | ok(!$@, "Loader initialization") or diag $@; |
37 | |
a0e0a56a |
38 | my $schema = $SCHEMA_CLASS->clone; |
66afce69 |
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; |
a0e0a56a |
43 | $classes{$table_name} = "${SCHEMA_CLASS}::${source_name}"; |
66afce69 |
44 | } |
45 | |
46 | return { |
47 | schema => $schema, |
48 | warnings => \@loader_warnings, |
49 | monikers => \%monikers, |
50 | classes => \%classes, |
51 | }; |
52 | } |
53 | |
a0e0a56a |
54 | sub run_v4_tests { |
55 | my $res = shift; |
56 | my $schema = $res->{schema}; |
57 | |
58 | is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ], |
59 | [qw/Foos Bar Bazs Quuxs/], |
60 | 'correct monikers in 0.04006 mode'; |
61 | |
62 | ok my $bar = eval { $schema->resultset('Bar')->find(1) }; |
63 | |
64 | isa_ok eval { $bar->foo_id }, $res->{classes}{foos}, |
65 | 'correct rel name in 0.04006 mode'; |
66 | |
67 | ok my $baz = eval { $schema->resultset('Bazs')->find(1) }; |
68 | |
69 | isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet', |
70 | 'correct rel type and name for UNIQUE FK in 0.04006 mode'; |
71 | } |
72 | |
73 | sub run_v5_tests { |
74 | my $res = shift; |
75 | my $schema = $res->{schema}; |
76 | |
77 | is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ], |
78 | [qw/Foo Bar Baz Quux/], |
79 | 'correct monikers in current mode'; |
80 | |
81 | ok my $bar = eval { $schema->resultset('Bar')->find(1) }; |
82 | |
83 | isa_ok eval { $bar->foo }, $res->{classes}{foos}, |
84 | 'correct rel name in current mode'; |
85 | |
86 | ok my $baz = eval { $schema->resultset('Baz')->find(1) }; |
87 | |
88 | isa_ok eval { $baz->quux }, $res->{classes}{quuxs}, |
89 | 'correct rel type and name for UNIQUE FK in current mode'; |
90 | } |
91 | |
66afce69 |
92 | # test dynamic schema in 0.04006 mode |
93 | { |
94 | my $res = run_loader(); |
a0e0a56a |
95 | my $warning = $res->{warnings}[0]; |
66afce69 |
96 | |
a0e0a56a |
97 | like $warning, qr/dynamic schema/i, |
66afce69 |
98 | 'dynamic schema in backcompat mode detected'; |
a0e0a56a |
99 | like $warning, qr/run in 0\.04006 mode/i, |
66afce69 |
100 | 'dynamic schema in 0.04006 mode warning'; |
a0e0a56a |
101 | like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, |
102 | 'warning refers to upgrading doc'; |
103 | |
104 | run_v4_tests($res); |
105 | } |
66afce69 |
106 | |
a0e0a56a |
107 | # setting naming accessor on dynamic schema should disable warning (even when |
108 | # we're setting it to 'v4' .) |
109 | { |
110 | my $res = run_loader(naming => 'v4'); |
66afce69 |
111 | |
a0e0a56a |
112 | is_deeply $res->{warnings}, [], 'no warnings with naming attribute set'; |
f53dcdf0 |
113 | |
114 | run_v4_tests($res); |
a0e0a56a |
115 | } |
116 | |
117 | # test upgraded dynamic schema |
118 | { |
119 | my $res = run_loader(naming => 'current'); |
66afce69 |
120 | |
a0e0a56a |
121 | # to dump a schema for debugging... |
122 | # { |
123 | # mkdir '/tmp/HLAGH'; |
124 | # $schema->_loader->{dump_directory} = '/tmp/HLAGH'; |
125 | # $schema->_loader->_dump_to_dir(values %{ $res->{classes} }); |
126 | # } |
66afce69 |
127 | |
a0e0a56a |
128 | is_deeply $res->{warnings}, [], 'no warnings with naming attribute set'; |
66afce69 |
129 | |
a0e0a56a |
130 | run_v5_tests($res); |
131 | } |
132 | |
a0e0a56a |
133 | # test running against v4 schema without upgrade |
134 | { |
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 $!; |
140 | while (<DATA>) { |
141 | print $fh $_; |
142 | } |
143 | close $fh; |
144 | |
145 | # now run the loader |
146 | my $res = run_loader(dump_directory => $DUMP_DIR); |
147 | my $warning = $res->{warnings}[0]; |
148 | |
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'; |
155 | |
156 | run_v4_tests($res); |
157 | |
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}); |
162 | { |
163 | local ($^I, @ARGV) = ('', $quuxs_pm); |
164 | while (<>) { |
165 | if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { |
166 | print; |
167 | print "sub a_method { 'mtfnpy' }\n"; |
168 | } |
169 | else { |
170 | print; |
171 | } |
172 | } |
173 | } |
174 | |
175 | # now upgrade the schema |
176 | $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current'); |
177 | $schema = $res->{schema}; |
178 | |
179 | like $res->{warnings}[0], qr/Dumping manual schema/i, |
180 | 'correct warnings on upgrading static schema (with "naming" set)'; |
181 | |
182 | like $res->{warnings}[1], qr/dump completed/i, |
183 | 'correct warnings on upgrading static schema (with "naming" set)'; |
184 | |
185 | is scalar @{ $res->{warnings} }, 2, |
f53dcdf0 |
186 | 'correct number of warnings on upgrading static schema (with "naming" set)' |
187 | or diag @{ $res->{warnings} }; |
a0e0a56a |
188 | |
189 | run_v5_tests($res); |
190 | |
191 | (my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g; |
192 | my $result_count =()= glob "$result_dir/*"; |
193 | |
194 | is $result_count, 4, |
195 | 'un-singularized results were replaced during upgrade'; |
196 | |
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'; |
66afce69 |
200 | } |
201 | |
202 | done_testing; |
203 | |
204 | END { rmtree $DUMP_DIR } |
a0e0a56a |
205 | |
206 | # a Schema.pm made with 0.04006 |
207 | |
208 | __DATA__ |
209 | package DBIXCSL_Test::Schema; |
210 | |
211 | use strict; |
212 | use warnings; |
213 | |
214 | use base 'DBIx::Class::Schema'; |
215 | |
216 | __PACKAGE__->load_classes; |
217 | |
218 | |
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 |
221 | |
222 | |
223 | # You can replace this text with custom content, and it will be preserved on regeneration |
224 | 1; |
225 | |