t/23dumpmore.t

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