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