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     check_error($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     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
  69 sub 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
  82 sub 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
  93 sub 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
 123 sub 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
 132 sub 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
 141 sub 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
 150 rmtree($DUMP_PATH, 1, 1);
 151
 152 # test loading external content
 153 do_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 => [
 163 qr/package DBICTest::Schema::13::Foo;\nour \$skip_me = "bad mojo";\n1;/
 164         ],
 165     },
 166 );
 167
 168 # test skipping external content
 169 do_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 => [
 179 qr/package DBICTest::Schema::14::Foo;\nour \$skip_me = "bad mojo";\n1;/
 180         ],
 181     },
 182 );
 183
 184 rmtree($DUMP_PATH, 1, 1);
 185
 186 # test out the POD
 187
 188 do_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 => [
 202 qr/package DBICTest::DumpMore::1::Foo;/,
 203 qr/=head1 NAME\n\nDBICTest::DumpMore::1::Foo\n\n=cut\n\n/,
 204 qr/=head1 ACCESSORS\n\n/,
 205 qr/=head2 fooid\n\n  data_type: INTEGER\n  default_value: undef\n  is_nullable: 1\n  size: undef\n\n/,
 206 qr/=head2 footext\n\n  data_type: TEXT\n  default_value: undef\n  is_nullable: 1\n  size: undef\n\n/,
 207 qr/->set_primary_key/,
 208 qr/=head1 RELATIONS\n\n/,
 209 qr/=head2 bars\n\nType: has_many\n\nRelated object: L<DBICTest::DumpMore::1::Bar>\n\n=cut\n\n/,
 210 qr/1;\n$/,
 211         ],
 212         Bar => [
 213 qr/package DBICTest::DumpMore::1::Bar;/,
 214 qr/=head1 NAME\n\nDBICTest::DumpMore::1::Bar\n\n=cut\n\n/,
 215 qr/=head1 ACCESSORS\n\n/,
 216 qr/=head2 barid\n\n  data_type: INTEGER\n  default_value: undef\n  is_nullable: 1\n  size: undef\n\n/,
 217 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/,
 218 qr/->set_primary_key/,
 219 qr/=head1 RELATIONS\n\n/,
 220 qr/=head2 fooref\n\nType: belongs_to\n\nRelated object: L<DBICTest::DumpMore::1::Foo>\n\n=cut\n\n/,
 221 qr/1;\n$/,
 222         ],
 223     },
 224 );
 225
 226 append_to_class('DBICTest::DumpMore::1::Foo',q{# XXX This is my custom content XXX});
 227
 228 do_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
 254 do_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
 288 do_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
 303 do_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
 329 do_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
 362 do_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
 400 do_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
 409 done_testing;
 410
 411 END { rmtree($DUMP_PATH, 1, 1) unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP} }