1use strict;
2use Test::More;
3use lib qw(t/backcompat/0.04006/lib);
4use File::Path;
5use make_dbictest_db;
6require DBIx::Class::Schema::Loader;
7
8plan skip_all => 'set SCHEMA_LOADER_TESTS_BACKCOMPAT to enable these tests'
9    unless $ENV{SCHEMA_LOADER_TESTS_BACKCOMPAT};
10
11my $DUMP_PATH = './t/_dump';
12
13sub do_dump_test {
14    my %tdata = @_;
15
16    my $schema_class = $tdata{classname};
17
18    no strict 'refs';
19    @{$schema_class . '::ISA'} = ('DBIx::Class::Schema::Loader');
20
21    $tdata{options}{use_namespaces} ||= 0;
22
23    $schema_class->loader_options(dump_directory => $DUMP_PATH, %{$tdata{options}});
24
25    my @warns;
26    eval {
27        local $SIG{__WARN__} = sub { push(@warns, @_) };
28        $schema_class->connect($make_dbictest_db::dsn);
29    };
30    my $err = $@;
31    $schema_class->storage->disconnect if !$err && $schema_class->storage;
32    undef *{$schema_class};
33
34    is($err, $tdata{error});
35
36    my $check_warns = $tdata{warnings};
37    is(@warns, @$check_warns);
38    for(my $i = 0; $i <= $#$check_warns; $i++) {
39        like($warns[$i], $check_warns->[$i]);
40    }
41
42    my $file_regexes = $tdata{regexes};
43    my $file_neg_regexes = $tdata{neg_regexes} || {};
44    my $schema_regexes = delete $file_regexes->{schema};
45    
46    my $schema_path = $DUMP_PATH . '/' . $schema_class;
47    $schema_path =~ s{::}{/}g;
48    dump_file_like($schema_path . '.pm', @$schema_regexes);
49    foreach my $src (keys %$file_regexes) {
50        my $src_file = $schema_path . '/' . $src . '.pm';
51        dump_file_like($src_file, @{$file_regexes->{$src}});
52    }
53    foreach my $src (keys %$file_neg_regexes) {
54        my $src_file = $schema_path . '/' . $src . '.pm';
55        dump_file_not_like($src_file, @{$file_neg_regexes->{$src}});
56    }
57}
58
59sub dump_file_like {
60    my $path = shift;
61    open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
62    my $contents = do { local $/; <$dumpfh>; };
63    close($dumpfh);
64    like($contents, $_) for @_;
65}
66
67sub dump_file_not_like {
68    my $path = shift;
69    open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
70    my $contents = do { local $/; <$dumpfh>; };
71    close($dumpfh);
72    unlike($contents, $_) for @_;
73}
74
75sub append_to_class {
76    my ($class, $string) = @_;
77    $class =~ s{::}{/}g;
78    $class = $DUMP_PATH . '/' . $class . '.pm';
79    open(my $appendfh, '>>', $class) or die "Failed to open '$class' for append: $!";
80    print $appendfh $string;
81    close($appendfh);
82}
83
84rmtree($DUMP_PATH, 1, 1);
85
86do_dump_test(
87    classname => 'DBICTest::DumpMore::1',
88    options => { },
89    error => '',
90    warnings => [
91        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
92        qr/Schema dump completed/,
93    ],
94    regexes => {
95        schema => [
96            qr/package DBICTest::DumpMore::1;/,
97            qr/->load_classes/,
98        ],
99        Foo => [
100            qr/package DBICTest::DumpMore::1::Foo;/,
101            qr/->set_primary_key/,
102            qr/1;\n$/,
103        ],
104        Bar => [
105            qr/package DBICTest::DumpMore::1::Bar;/,
106            qr/->set_primary_key/,
107            qr/1;\n$/,
108        ],
109    },
110);
111
112append_to_class('DBICTest::DumpMore::1::Foo',q{# XXX This is my custom content XXX});
113
114do_dump_test(
115    classname => 'DBICTest::DumpMore::1',
116    options => { },
117    error => '',
118    warnings => [
119        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
120        qr/Schema dump completed/,
121    ],
122    regexes => {
123        schema => [
124            qr/package DBICTest::DumpMore::1;/,
125            qr/->load_classes/,
126        ],
127        Foo => [
128            qr/package DBICTest::DumpMore::1::Foo;/,
129            qr/->set_primary_key/,
130            qr/1;\n# XXX This is my custom content XXX/,
131        ],
132        Bar => [
133            qr/package DBICTest::DumpMore::1::Bar;/,
134            qr/->set_primary_key/,
135            qr/1;\n$/,
136        ],
137    },
138);
139
140do_dump_test(
141    classname => 'DBICTest::DumpMore::1',
142    options => { really_erase_my_files => 1 },
143    error => '',
144    warnings => [
145        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
146        qr/Deleting existing file /,
147        qr/Deleting existing file /,
148        qr/Deleting existing file /,
149        qr/Schema dump completed/,
150    ],
151    regexes => {
152        schema => [
153            qr/package DBICTest::DumpMore::1;/,
154            qr/->load_classes/,
155        ],
156        Foo => [
157            qr/package DBICTest::DumpMore::1::Foo;/,
158            qr/->set_primary_key/,
159            qr/1;\n$/,
160        ],
161        Bar => [
162            qr/package DBICTest::DumpMore::1::Bar;/,
163            qr/->set_primary_key/,
164            qr/1;\n$/,
165        ],
166    },
167    neg_regexes => {
168        Foo => [
169            qr/# XXX This is my custom content XXX/,
170        ],
171    },
172);
173
174do_dump_test(
175    classname => 'DBICTest::DumpMore::1',
176    options => { use_namespaces => 1 },
177    error => '',
178    warnings => [
179        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
180        qr/Schema dump completed/,
181    ],
182    regexes => {
183        schema => [
184            qr/package DBICTest::DumpMore::1;/,
185            qr/->load_namespaces/,
186        ],
187        'Result/Foo' => [
188            qr/package DBICTest::DumpMore::1::Result::Foo;/,
189            qr/->set_primary_key/,
190            qr/1;\n$/,
191        ],
192        'Result/Bar' => [
193            qr/package DBICTest::DumpMore::1::Result::Bar;/,
194            qr/->set_primary_key/,
195            qr/1;\n$/,
196        ],
197    },
198);
199
200do_dump_test(
201    classname => 'DBICTest::DumpMore::1',
202    options => { use_namespaces => 1,
203                 result_namespace => 'Res',
204                 resultset_namespace => 'RSet',
205                 default_resultset_class => 'RSetBase',
206             },
207    error => '',
208    warnings => [
209        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
210        qr/Schema dump completed/,
211    ],
212    regexes => {
213        schema => [
214            qr/package DBICTest::DumpMore::1;/,
215            qr/->load_namespaces/,
216            qr/result_namespace => 'Res'/,
217            qr/resultset_namespace => 'RSet'/,
218            qr/default_resultset_class => 'RSetBase'/,
219        ],
220        'Res/Foo' => [
221            qr/package DBICTest::DumpMore::1::Res::Foo;/,
222            qr/->set_primary_key/,
223            qr/1;\n$/,
224        ],
225        'Res/Bar' => [
226            qr/package DBICTest::DumpMore::1::Res::Bar;/,
227            qr/->set_primary_key/,
228            qr/1;\n$/,
229        ],
230    },
231);
232
233do_dump_test(
234    classname => 'DBICTest::DumpMore::1',
235    options => { use_namespaces => 1,
236                 result_namespace => '+DBICTest::DumpMore::1::Res',
237                 resultset_namespace => 'RSet',
238                 default_resultset_class => 'RSetBase',
239                 result_base_class => 'My::ResultBaseClass',
240                 schema_base_class => 'My::SchemaBaseClass',
241             },
242    error => '',
243    warnings => [
244        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
245        qr/Schema dump completed/,
246    ],
247    regexes => {
248        schema => [
249            qr/package DBICTest::DumpMore::1;/,
250            qr/->load_namespaces/,
251            qr/result_namespace => '\+DBICTest::DumpMore::1::Res'/,
252            qr/resultset_namespace => 'RSet'/,
253            qr/default_resultset_class => 'RSetBase'/,
254            qr/use base 'My::SchemaBaseClass'/,
255        ],
256        'Res/Foo' => [
257            qr/package DBICTest::DumpMore::1::Res::Foo;/,
258            qr/use base 'My::ResultBaseClass'/,
259            qr/->set_primary_key/,
260            qr/1;\n$/,
261        ],
262        'Res/Bar' => [
263            qr/package DBICTest::DumpMore::1::Res::Bar;/,
264            qr/use base 'My::ResultBaseClass'/,
265            qr/->set_primary_key/,
266            qr/1;\n$/,
267        ],
268    },
269);
270
271done_testing;
272
273END { rmtree($DUMP_PATH, 1, 1) if $ENV{SCHEMA_LOADER_TESTS_BACKCOMPAT}; }
274