1use strict;
2use Test::More;
3use lib qw(t/lib);
4use File::Path;
5use IPC::Open3;
6use make_dbictest_db;
7require DBIx::Class::Schema::Loader;
8
9my $DUMP_PATH = './t/_dump';
10
11sub dump_directly {
12    my %tdata = @_;
13
14    my $schema_class = $tdata{classname};
15
16    no strict 'refs';
17    @{$schema_class . '::ISA'} = ('DBIx::Class::Schema::Loader');
18    $schema_class->loader_options(%{$tdata{options}});
19
20    my @warns;
21    eval {
22        local $SIG{__WARN__} = sub { push(@warns, @_) };
23        $schema_class->connect($make_dbictest_db::dsn);
24    };
25    my $err = $@;
26    $schema_class->storage->disconnect if !$err && $schema_class->storage;
27    undef *{$schema_class};
28
29    check_error($err, $tdata{error});
30
31    return @warns;
32}
33
34sub dump_dbicdump {
35    my %tdata = @_;
36
37    # use $^X so we execute ./script/dbicdump with the same perl binary that the tests were executed with
38    my @cmd = ($^X, qw(./script/dbicdump));
39
40    while (my ($opt, $val) = each(%{ $tdata{options} })) {
41        push @cmd, '-o', "$opt=$val";
42    }
43
44    push @cmd, $tdata{classname}, $make_dbictest_db::dsn;
45
46    # make sure our current @INC gets used by dbicdump
47    use Config;
48    local $ENV{PERL5LIB} = join $Config{path_sep}, @INC, ($ENV{PERL5LIB} || '');
49
50    my ($in, $out, $err);
51    my $pid = open3($in, $out, $err, @cmd);
52
53    my @out = <$out>;
54    waitpid($pid, 0);
55
56    my ($error, @warns);
57
58    if ($? >> 8 != 0) {
59        $error = $out[0];
60        check_error($error, $tdata{error});
61    }
62    else {
63        @warns = @out;
64    }
65
66    return @warns;
67}
68
69sub check_error {
70    my ($got, $expected) = @_;
71
72    return unless $got && $expected;
73
74    if (ref $expected eq 'Regexp') {
75        like $got, $expected, 'error matches expected pattern';
76        return;
77    }
78
79    is $got, $expected, 'error matches';
80}
81
82sub do_dump_test {
83    my %tdata = @_;
84    
85    $tdata{options}{dump_directory} = $DUMP_PATH;
86    $tdata{options}{use_namespaces} ||= 0;
87
88    for my $dumper (\&dump_directly, \&dump_dbicdump) {
89        test_dumps(\%tdata, $dumper->(%tdata));
90    }
91}
92
93sub test_dumps {
94    my ($tdata, @warns) = @_;
95
96    my %tdata = %{$tdata};
97
98    my $schema_class = $tdata{classname};
99    my $check_warns = $tdata{warnings};
100    is(@warns, @$check_warns, "$schema_class warning count");
101
102    for(my $i = 0; $i <= $#$check_warns; $i++) {
103        like($warns[$i], $check_warns->[$i], "$schema_class warning $i");
104    }
105
106    my $file_regexes = $tdata{regexes};
107    my $file_neg_regexes = $tdata{neg_regexes} || {};
108    my $schema_regexes = delete $file_regexes->{schema};
109    
110    my $schema_path = $DUMP_PATH . '/' . $schema_class;
111    $schema_path =~ s{::}{/}g;
112    dump_file_like($schema_path . '.pm', @$schema_regexes);
113    foreach my $src (keys %$file_regexes) {
114        my $src_file = $schema_path . '/' . $src . '.pm';
115        dump_file_like($src_file, @{$file_regexes->{$src}});
116    }
117    foreach my $src (keys %$file_neg_regexes) {
118        my $src_file = $schema_path . '/' . $src . '.pm';
119        dump_file_not_like($src_file, @{$file_neg_regexes->{$src}});
120    }
121}
122
123sub dump_file_like {
124    my $path = shift;
125    open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
126    my $contents = do { local $/; <$dumpfh>; };
127    close($dumpfh);
128    my $num = 1;
129    like($contents, $_, "like $path " . $num++) for @_;
130}
131
132sub dump_file_not_like {
133    my $path = shift;
134    open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
135    my $contents = do { local $/; <$dumpfh>; };
136    close($dumpfh);
137    my $num = 1;
138    unlike($contents, $_, "unlike $path ". $num++) for @_;
139}
140
141sub append_to_class {
142    my ($class, $string) = @_;
143    $class =~ s{::}{/}g;
144    $class = $DUMP_PATH . '/' . $class . '.pm';
145    open(my $appendfh, '>>', $class) or die "Failed to open '$class' for append: $!";
146    print $appendfh $string;
147    close($appendfh);
148}
149
150rmtree($DUMP_PATH, 1, 1);
151
152# test loading external content
153do_dump_test(
154    classname => 'DBICTest::Schema::13',
155    options => { },
156    error => '',
157    warnings => [
158        qr/Dumping manual schema for DBICTest::Schema::13 to directory /,
159        qr/Schema dump completed/,
160    ],
161    regexes => {
162        Foo => [
163qr/package DBICTest::Schema::13::Foo;\nour \$skip_me = "bad mojo";\n1;/
164        ],
165    },
166);
167
168# test skipping external content
169do_dump_test(
170    classname => 'DBICTest::Schema::14',
171    options => { skip_load_external => 1 },
172    error => '',
173    warnings => [
174        qr/Dumping manual schema for DBICTest::Schema::14 to directory /,
175        qr/Schema dump completed/,
176    ],
177    neg_regexes => {
178        Foo => [
179qr/package DBICTest::Schema::14::Foo;\nour \$skip_me = "bad mojo";\n1;/
180        ],
181    },
182);
183
184rmtree($DUMP_PATH, 1, 1);
185
186# test out the POD
187
188do_dump_test(
189    classname => 'DBICTest::DumpMore::1',
190    options => { },
191    error => '',
192    warnings => [
193        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
194        qr/Schema dump completed/,
195    ],
196    regexes => {
197        schema => [
198            qr/package DBICTest::DumpMore::1;/,
199            qr/->load_classes/,
200        ],
201        Foo => [
202qr/package DBICTest::DumpMore::1::Foo;/,
203qr/=head1 NAME\n\nDBICTest::DumpMore::1::Foo\n\n=cut\n\n/,
204qr/=head1 ACCESSORS\n\n/,
205qr/=head2 fooid\n\n  data_type: INTEGER\n  default_value: undef\n  is_nullable: 1\n  size: undef\n\n/,
206qr/=head2 footext\n\n  data_type: TEXT\n  default_value: undef\n  is_nullable: 1\n  size: undef\n\n/,
207qr/->set_primary_key/,
208qr/=head1 RELATIONS\n\n/,
209qr/=head2 bars\n\nType: has_many\n\nRelated object: L<DBICTest::DumpMore::1::Bar>\n\n=cut\n\n/,
210qr/1;\n$/,
211        ],
212        Bar => [
213qr/package DBICTest::DumpMore::1::Bar;/,
214qr/=head1 NAME\n\nDBICTest::DumpMore::1::Bar\n\n=cut\n\n/,
215qr/=head1 ACCESSORS\n\n/,
216qr/=head2 barid\n\n  data_type: INTEGER\n  default_value: undef\n  is_nullable: 1\n  size: undef\n\n/,
217qr/=head2 fooref\n\n  data_type: INTEGER\n  default_value: undef\n  is_foreign_key: 1\n  is_nullable: 1\n  size: undef\n\n/,
218qr/->set_primary_key/,
219qr/=head1 RELATIONS\n\n/,
220qr/=head2 fooref\n\nType: belongs_to\n\nRelated object: L<DBICTest::DumpMore::1::Foo>\n\n=cut\n\n/,
221qr/1;\n$/,
222        ],
223    },
224);
225
226append_to_class('DBICTest::DumpMore::1::Foo',q{# XXX This is my custom content XXX});
227
228do_dump_test(
229    classname => 'DBICTest::DumpMore::1',
230    options => { },
231    error => '',
232    warnings => [
233        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
234        qr/Schema dump completed/,
235    ],
236    regexes => {
237        schema => [
238            qr/package DBICTest::DumpMore::1;/,
239            qr/->load_classes/,
240        ],
241        Foo => [
242            qr/package DBICTest::DumpMore::1::Foo;/,
243            qr/->set_primary_key/,
244            qr/1;\n# XXX This is my custom content XXX/,
245        ],
246        Bar => [
247            qr/package DBICTest::DumpMore::1::Bar;/,
248            qr/->set_primary_key/,
249            qr/1;\n$/,
250        ],
251    },
252);
253
254do_dump_test(
255    classname => 'DBICTest::DumpMore::1',
256    options => { really_erase_my_files => 1 },
257    error => '',
258    warnings => [
259        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
260        qr/Deleting existing file /,
261        qr/Deleting existing file /,
262        qr/Deleting existing file /,
263        qr/Schema dump completed/,
264    ],
265    regexes => {
266        schema => [
267            qr/package DBICTest::DumpMore::1;/,
268            qr/->load_classes/,
269        ],
270        Foo => [
271            qr/package DBICTest::DumpMore::1::Foo;/,
272            qr/->set_primary_key/,
273            qr/1;\n$/,
274        ],
275        Bar => [
276            qr/package DBICTest::DumpMore::1::Bar;/,
277            qr/->set_primary_key/,
278            qr/1;\n$/,
279        ],
280    },
281    neg_regexes => {
282        Foo => [
283            qr/# XXX This is my custom content XXX/,
284        ],
285    },
286);
287
288do_dump_test(
289    classname => 'DBICTest::DumpMore::1',
290    options => { use_namespaces => 1, generate_pod => 0 },
291    error => '',
292    warnings => [
293        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
294        qr/Schema dump completed/,
295    ],
296    neg_regexes => {
297        'Result/Foo' => [
298            qr/^=/m,
299        ],
300    },
301);
302
303do_dump_test(
304    classname => 'DBICTest::DumpMore::1',
305    options => { use_namespaces => 1 },
306    error => '',
307    warnings => [
308        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
309        qr/Schema dump completed/,
310    ],
311    regexes => {
312        schema => [
313            qr/package DBICTest::DumpMore::1;/,
314            qr/->load_namespaces/,
315        ],
316        'Result/Foo' => [
317            qr/package DBICTest::DumpMore::1::Result::Foo;/,
318            qr/->set_primary_key/,
319            qr/1;\n$/,
320        ],
321        'Result/Bar' => [
322            qr/package DBICTest::DumpMore::1::Result::Bar;/,
323            qr/->set_primary_key/,
324            qr/1;\n$/,
325        ],
326    },
327);
328
329do_dump_test(
330    classname => 'DBICTest::DumpMore::1',
331    options => { use_namespaces => 1,
332                 result_namespace => 'Res',
333                 resultset_namespace => 'RSet',
334                 default_resultset_class => 'RSetBase',
335             },
336    error => '',
337    warnings => [
338        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
339        qr/Schema dump completed/,
340    ],
341    regexes => {
342        schema => [
343            qr/package DBICTest::DumpMore::1;/,
344            qr/->load_namespaces/,
345            qr/result_namespace => 'Res'/,
346            qr/resultset_namespace => 'RSet'/,
347            qr/default_resultset_class => 'RSetBase'/,
348        ],
349        'Res/Foo' => [
350            qr/package DBICTest::DumpMore::1::Res::Foo;/,
351            qr/->set_primary_key/,
352            qr/1;\n$/,
353        ],
354        'Res/Bar' => [
355            qr/package DBICTest::DumpMore::1::Res::Bar;/,
356            qr/->set_primary_key/,
357            qr/1;\n$/,
358        ],
359    },
360);
361
362do_dump_test(
363    classname => 'DBICTest::DumpMore::1',
364    options => { use_namespaces => 1,
365                 result_namespace => '+DBICTest::DumpMore::1::Res',
366                 resultset_namespace => 'RSet',
367                 default_resultset_class => 'RSetBase',
368                 result_base_class => 'My::ResultBaseClass',
369                 schema_base_class => 'My::SchemaBaseClass',
370             },
371    error => '',
372    warnings => [
373        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
374        qr/Schema dump completed/,
375    ],
376    regexes => {
377        schema => [
378            qr/package DBICTest::DumpMore::1;/,
379            qr/->load_namespaces/,
380            qr/result_namespace => '\+DBICTest::DumpMore::1::Res'/,
381            qr/resultset_namespace => 'RSet'/,
382            qr/default_resultset_class => 'RSetBase'/,
383            qr/use base 'My::SchemaBaseClass'/,
384        ],
385        'Res/Foo' => [
386            qr/package DBICTest::DumpMore::1::Res::Foo;/,
387            qr/use base 'My::ResultBaseClass'/,
388            qr/->set_primary_key/,
389            qr/1;\n$/,
390        ],
391        'Res/Bar' => [
392            qr/package DBICTest::DumpMore::1::Res::Bar;/,
393            qr/use base 'My::ResultBaseClass'/,
394            qr/->set_primary_key/,
395            qr/1;\n$/,
396        ],
397    },
398);
399
400do_dump_test(
401    classname => 'DBICTest::DumpMore::1',
402    options   => {
403        use_namespaces    => 1,
404        result_base_class => 'My::MissingResultBaseClass',
405    },
406    error => qr/My::MissingResultBaseClass.*is not installed/,
407);
408
409done_testing;
410
411END { rmtree($DUMP_PATH, 1, 1) unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP} }
412