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 require DBIx::Class::Schema::Loader;
   8
   9 my $DUMP_PATH = './t/_dump';
  10
  11 sub 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     is($err, $tdata{error});
  30
  31     return @warns;
  32 }
  33
  34 sub 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     foreach my $inc ($ENV{PERL5LIB}, reverse @INC) {
  48         splice @cmd, 1, 0, '-I', $inc;
  49     }
  50
  51     my ($in, $out, $err);
  52     my $pid = open3($in, $out, $err, @cmd);
  53
  54     my @warns = <$out>;
  55     waitpid($pid, 0);
  56
  57     return @warns;
  58 }
  59
  60 sub do_dump_test {
  61     my %tdata = @_;
  62
  63     $tdata{options}{dump_directory} = $DUMP_PATH;
  64     $tdata{options}{use_namespaces} ||= 0;
  65
  66     for my $dumper (\&dump_directly, \&dump_dbicdump) {
  67         test_dumps(\%tdata, $dumper->(%tdata));
  68     }
  69 }
  70
  71 sub test_dumps {
  72     my ($tdata, @warns) = @_;
  73
  74     my %tdata = %{$tdata};
  75
  76     my $schema_class = $tdata{classname};
  77     my $check_warns = $tdata{warnings};
  78     is(@warns, @$check_warns, "$schema_class warning count");
  79     for(my $i = 0; $i <= $#$check_warns; $i++) {
  80         like($warns[$i], $check_warns->[$i], "$schema_class warning $i");
  81     }
  82
  83     my $file_regexes = $tdata{regexes};
  84     my $file_neg_regexes = $tdata{neg_regexes} || {};
  85     my $schema_regexes = delete $file_regexes->{schema};
  86
  87     my $schema_path = $DUMP_PATH . '/' . $schema_class;
  88     $schema_path =~ s{::}{/}g;
  89     dump_file_like($schema_path . '.pm', @$schema_regexes);
  90     foreach my $src (keys %$file_regexes) {
  91         my $src_file = $schema_path . '/' . $src . '.pm';
  92         dump_file_like($src_file, @{$file_regexes->{$src}});
  93     }
  94     foreach my $src (keys %$file_neg_regexes) {
  95         my $src_file = $schema_path . '/' . $src . '.pm';
  96         dump_file_not_like($src_file, @{$file_neg_regexes->{$src}});
  97     }
  98 }
  99
 100 sub dump_file_like {
 101     my $path = shift;
 102     open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
 103     my $contents = do { local $/; <$dumpfh>; };
 104     close($dumpfh);
 105     my $num = 1;
 106     like($contents, $_, "like $path " . $num++) for @_;
 107 }
 108
 109 sub dump_file_not_like {
 110     my $path = shift;
 111     open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
 112     my $contents = do { local $/; <$dumpfh>; };
 113     close($dumpfh);
 114     my $num = 1;
 115     unlike($contents, $_, "unlike $path ". $num++) for @_;
 116 }
 117
 118 sub append_to_class {
 119     my ($class, $string) = @_;
 120     $class =~ s{::}{/}g;
 121     $class = $DUMP_PATH . '/' . $class . '.pm';
 122     open(my $appendfh, '>>', $class) or die "Failed to open '$class' for append: $!";
 123     print $appendfh $string;
 124     close($appendfh);
 125 }
 126
 127 rmtree($DUMP_PATH, 1, 1);
 128
 129 do_dump_test(
 130     classname => 'DBICTest::DumpMore::1',
 131     options => { },
 132     error => '',
 133     warnings => [
 134         qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
 135         qr/Schema dump completed/,
 136     ],
 137     regexes => {
 138         schema => [
 139             qr/package DBICTest::DumpMore::1;/,
 140             qr/->load_classes/,
 141         ],
 142         Foo => [
 143             qr/package DBICTest::DumpMore::1::Foo;/,
 144             qr/=head1 NAME/,
 145             qr/=head1 ACCESSORS/,
 146             qr/->set_primary_key/,
 147             qr/1;\n$/,
 148         ],
 149         Bar => [
 150             qr/package DBICTest::DumpMore::1::Bar;/,
 151             qr/=head1 NAME/,
 152             qr/=head1 ACCESSORS/,
 153             qr/->set_primary_key/,
 154             qr/1;\n$/,
 155         ],
 156     },
 157 );
 158
 159 append_to_class('DBICTest::DumpMore::1::Foo',q{# XXX This is my custom content XXX});
 160
 161 do_dump_test(
 162     classname => 'DBICTest::DumpMore::1',
 163     options => { },
 164     error => '',
 165     warnings => [
 166         qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
 167         qr/Schema dump completed/,
 168     ],
 169     regexes => {
 170         schema => [
 171             qr/package DBICTest::DumpMore::1;/,
 172             qr/->load_classes/,
 173         ],
 174         Foo => [
 175             qr/package DBICTest::DumpMore::1::Foo;/,
 176             qr/->set_primary_key/,
 177             qr/1;\n# XXX This is my custom content XXX/,
 178         ],
 179         Bar => [
 180             qr/package DBICTest::DumpMore::1::Bar;/,
 181             qr/->set_primary_key/,
 182             qr/1;\n$/,
 183         ],
 184     },
 185 );
 186
 187 do_dump_test(
 188     classname => 'DBICTest::DumpMore::1',
 189     options => { really_erase_my_files => 1 },
 190     error => '',
 191     warnings => [
 192         qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
 193         qr/Deleting existing file /,
 194         qr/Deleting existing file /,
 195         qr/Deleting existing file /,
 196         qr/Schema dump completed/,
 197     ],
 198     regexes => {
 199         schema => [
 200             qr/package DBICTest::DumpMore::1;/,
 201             qr/->load_classes/,
 202         ],
 203         Foo => [
 204             qr/package DBICTest::DumpMore::1::Foo;/,
 205             qr/->set_primary_key/,
 206             qr/1;\n$/,
 207         ],
 208         Bar => [
 209             qr/package DBICTest::DumpMore::1::Bar;/,
 210             qr/->set_primary_key/,
 211             qr/1;\n$/,
 212         ],
 213     },
 214     neg_regexes => {
 215         Foo => [
 216             qr/# XXX This is my custom content XXX/,
 217         ],
 218     },
 219 );
 220
 221 do_dump_test(
 222     classname => 'DBICTest::DumpMore::1',
 223     options => { use_namespaces => 1, generate_pod => 0 },
 224     error => '',
 225     warnings => [
 226         qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
 227         qr/Schema dump completed/,
 228     ],
 229     neg_regexes => {
 230         'Result/Foo' => [
 231             qr/^=/m,
 232         ],
 233     },
 234 );
 235
 236 do_dump_test(
 237     classname => 'DBICTest::DumpMore::1',
 238     options => { use_namespaces => 1 },
 239     error => '',
 240     warnings => [
 241         qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
 242         qr/Schema dump completed/,
 243     ],
 244     regexes => {
 245         schema => [
 246             qr/package DBICTest::DumpMore::1;/,
 247             qr/->load_namespaces/,
 248         ],
 249         'Result/Foo' => [
 250             qr/package DBICTest::DumpMore::1::Result::Foo;/,
 251             qr/->set_primary_key/,
 252             qr/1;\n$/,
 253         ],
 254         'Result/Bar' => [
 255             qr/package DBICTest::DumpMore::1::Result::Bar;/,
 256             qr/->set_primary_key/,
 257             qr/1;\n$/,
 258         ],
 259     },
 260 );
 261
 262 do_dump_test(
 263     classname => 'DBICTest::DumpMore::1',
 264     options => { use_namespaces => 1,
 265                  result_namespace => 'Res',
 266                  resultset_namespace => 'RSet',
 267                  default_resultset_class => 'RSetBase',
 268              },
 269     error => '',
 270     warnings => [
 271         qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
 272         qr/Schema dump completed/,
 273     ],
 274     regexes => {
 275         schema => [
 276             qr/package DBICTest::DumpMore::1;/,
 277             qr/->load_namespaces/,
 278             qr/result_namespace => 'Res'/,
 279             qr/resultset_namespace => 'RSet'/,
 280             qr/default_resultset_class => 'RSetBase'/,
 281         ],
 282         'Res/Foo' => [
 283             qr/package DBICTest::DumpMore::1::Res::Foo;/,
 284             qr/->set_primary_key/,
 285             qr/1;\n$/,
 286         ],
 287         'Res/Bar' => [
 288             qr/package DBICTest::DumpMore::1::Res::Bar;/,
 289             qr/->set_primary_key/,
 290             qr/1;\n$/,
 291         ],
 292     },
 293 );
 294
 295 do_dump_test(
 296     classname => 'DBICTest::DumpMore::1',
 297     options => { use_namespaces => 1,
 298                  result_namespace => '+DBICTest::DumpMore::1::Res',
 299                  resultset_namespace => 'RSet',
 300                  default_resultset_class => 'RSetBase',
 301                  result_base_class => 'My::ResultBaseClass',
 302                  schema_base_class => 'My::SchemaBaseClass',
 303              },
 304     error => '',
 305     warnings => [
 306         qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
 307         qr/Schema dump completed/,
 308     ],
 309     regexes => {
 310         schema => [
 311             qr/package DBICTest::DumpMore::1;/,
 312             qr/->load_namespaces/,
 313             qr/result_namespace => '\+DBICTest::DumpMore::1::Res'/,
 314             qr/resultset_namespace => 'RSet'/,
 315             qr/default_resultset_class => 'RSetBase'/,
 316             qr/use base 'My::SchemaBaseClass'/,
 317         ],
 318         'Res/Foo' => [
 319             qr/package DBICTest::DumpMore::1::Res::Foo;/,
 320             qr/use base 'My::ResultBaseClass'/,
 321             qr/->set_primary_key/,
 322             qr/1;\n$/,
 323         ],
 324         'Res/Bar' => [
 325             qr/package DBICTest::DumpMore::1::Res::Bar;/,
 326             qr/use base 'My::ResultBaseClass'/,
 327             qr/->set_primary_key/,
 328             qr/1;\n$/,
 329         ],
 330     },
 331 );
 332
 333 done_testing;
 334
 335 END { rmtree($DUMP_PATH, 1, 1); }