X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F23dumpmore.t;h=1242d78d269cceed34cdd03c2da0e003803ce78d;hb=f170d55b2829518155a9b8817639affab3559b03;hp=a50fffc92d5e8e87e157539a76ecadb527c92a9a;hpb=d27f2b7bd6387aaf303ff99c507ea08769e16644;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/t/23dumpmore.t b/t/23dumpmore.t index a50fffc..1242d78 100644 --- a/t/23dumpmore.t +++ b/t/23dumpmore.t @@ -4,12 +4,9 @@ use lib qw(t/lib); use File::Path; use IPC::Open3; use make_dbictest_db; +use Data::Dumper::Concise; require DBIx::Class::Schema::Loader; -$^O eq 'MSWin32' && plan(skip_all => -"ActiveState perl produces additional warnings, and this test uses unix paths" -); - my $DUMP_PATH = './t/_dump'; sub dump_directly { @@ -30,7 +27,7 @@ sub dump_directly { $schema_class->storage->disconnect if !$err && $schema_class->storage; undef *{$schema_class}; - is($err, $tdata{error}); + check_error($err, $tdata{error}); return @warns; } @@ -42,27 +39,53 @@ sub dump_dbicdump { my @cmd = ($^X, qw(./script/dbicdump)); while (my ($opt, $val) = each(%{ $tdata{options} })) { + $val = Dumper($val) if ref $val; push @cmd, '-o', "$opt=$val"; } push @cmd, $tdata{classname}, $make_dbictest_db::dsn; # make sure our current @INC gets used by dbicdump - local $ENV{PERL5LIB} = join ":", @INC, $ENV{PERL5LIB}; + use Config; + local $ENV{PERL5LIB} = join $Config{path_sep}, @INC, ($ENV{PERL5LIB} || ''); my ($in, $out, $err); my $pid = open3($in, $out, $err, @cmd); - my @warns = <$out>; + my @out = <$out>; waitpid($pid, 0); + my ($error, @warns); + + if ($? >> 8 != 0) { + $error = $out[0]; + check_error($error, $tdata{error}); + } + else { + @warns = @out; + } + return @warns; } +sub check_error { + my ($got, $expected) = @_; + + return unless $got && $expected; + + if (ref $expected eq 'Regexp') { + like $got, $expected, 'error matches expected pattern'; + return; + } + + is $got, $expected, 'error matches'; +} + sub do_dump_test { my %tdata = @_; $tdata{options}{dump_directory} = $DUMP_PATH; + $tdata{options}{use_namespaces} ||= 0; for my $dumper (\&dump_directly, \&dump_dbicdump) { test_dumps(\%tdata, $dumper->(%tdata)); @@ -77,6 +100,7 @@ sub test_dumps { my $schema_class = $tdata{classname}; my $check_warns = $tdata{warnings}; is(@warns, @$check_warns, "$schema_class warning count"); + for(my $i = 0; $i <= $#$check_warns; $i++) { like($warns[$i], $check_warns->[$i], "$schema_class warning $i"); } @@ -127,11 +151,52 @@ sub append_to_class { rmtree($DUMP_PATH, 1, 1); +# test loading external content do_dump_test( - classname => 'DBICTest::DumpMore::1', + classname => 'DBICTest::Schema::13', options => { }, error => '', warnings => [ + qr/Dumping manual schema for DBICTest::Schema::13 to directory /, + qr/Schema dump completed/, + ], + regexes => { + Foo => [ +qr/package DBICTest::Schema::13::Foo;\nour \$skip_me = "bad mojo";\n1;/ + ], + }, +); + +# test skipping external content +do_dump_test( + classname => 'DBICTest::Schema::14', + options => { skip_load_external => 1 }, + error => '', + warnings => [ + qr/Dumping manual schema for DBICTest::Schema::14 to directory /, + qr/Schema dump completed/, + ], + neg_regexes => { + Foo => [ +qr/package DBICTest::Schema::14::Foo;\nour \$skip_me = "bad mojo";\n1;/ + ], + }, +); + +rmtree($DUMP_PATH, 1, 1); + +# test out the POD + +do_dump_test( + classname => 'DBICTest::DumpMore::1', + options => { + custom_column_info => sub { + my ($table, $col, $info) = @_; + return +{ extra => { is_footext => 1 } } if $col eq 'footext'; + } + }, + error => '', + warnings => [ qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, qr/Schema dump completed/, ], @@ -141,18 +206,26 @@ do_dump_test( qr/->load_classes/, ], Foo => [ - qr/package DBICTest::DumpMore::1::Foo;/, - qr/=head1 NAME/, - qr/=head1 ACCESSORS/, - qr/->set_primary_key/, - qr/1;\n$/, +qr/package DBICTest::DumpMore::1::Foo;/, +qr/=head1 NAME\n\nDBICTest::DumpMore::1::Foo\n\n=cut\n\n/, +qr/=head1 ACCESSORS\n\n/, +qr/=head2 fooid\n\n data_type: 'INTEGER'\n default_value: undef\n is_nullable: 1\n size: undef\n\n/, +qr/=head2 footext\n\n data_type: 'TEXT'\n default_value: 'footext'\n extra: {is_footext => 1}\n is_nullable: 1\n size: undef\n\n/, +qr/->set_primary_key/, +qr/=head1 RELATIONS\n\n/, +qr/=head2 bars\n\nType: has_many\n\nRelated object: L\n\n=cut\n\n/, +qr/1;\n$/, ], Bar => [ - qr/package DBICTest::DumpMore::1::Bar;/, - qr/=head1 NAME/, - qr/=head1 ACCESSORS/, - qr/->set_primary_key/, - qr/1;\n$/, +qr/package DBICTest::DumpMore::1::Bar;/, +qr/=head1 NAME\n\nDBICTest::DumpMore::1::Bar\n\n=cut\n\n/, +qr/=head1 ACCESSORS\n\n/, +qr/=head2 barid\n\n data_type: 'INTEGER'\n default_value: undef\n is_nullable: 1\n size: undef\n\n/, +qr/=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/, +qr/->set_primary_key/, +qr/=head1 RELATIONS\n\n/, +qr/=head2 fooref\n\nType: belongs_to\n\nRelated object: L\n\n=cut\n\n/, +qr/1;\n$/, ], }, ); @@ -221,6 +294,21 @@ do_dump_test( do_dump_test( classname => 'DBICTest::DumpMore::1', + options => { use_namespaces => 1, generate_pod => 0 }, + error => '', + warnings => [ + qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, + qr/Schema dump completed/, + ], + neg_regexes => { + 'Result/Foo' => [ + qr/^=/m, + ], + }, +); + +do_dump_test( + classname => 'DBICTest::DumpMore::1', options => { use_namespaces => 1 }, error => '', warnings => [ @@ -316,6 +404,15 @@ do_dump_test( }, ); +do_dump_test( + classname => 'DBICTest::DumpMore::1', + options => { + use_namespaces => 1, + result_base_class => 'My::MissingResultBaseClass', + }, + error => qr/My::MissingResultBaseClass.*is not installed/, +); + done_testing; -END { rmtree($DUMP_PATH, 1, 1); } +END { rmtree($DUMP_PATH, 1, 1) unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP} }