1use strict; 2use Test::More; 3use lib qw(t/backcompat/0.04006/lib); 4use File::Path; 5use make_dbictest_db; 6require DBIx::Class::Schema::Loader; 7 8plan skip_all => 'set SCHEMA_LOADER_TESTS_BACKCOMPAT to enable these tests' 9 unless $ENV{SCHEMA_LOADER_TESTS_BACKCOMPAT}; 10 11my $DUMP_PATH = './t/_dump'; 12 13sub do_dump_test { 14 my %tdata = @_; 15 16 my $schema_class = $tdata{classname}; 17 18 no strict 'refs'; 19 @{$schema_class . '::ISA'} = ('DBIx::Class::Schema::Loader'); 20 21 $tdata{options}{use_namespaces} ||= 0; 22 23 $schema_class->loader_options(dump_directory => $DUMP_PATH, %{$tdata{options}}); 24 25 my @warns; 26 eval { 27 local $SIG{__WARN__} = sub { push(@warns, @_) }; 28 $schema_class->connect($make_dbictest_db::dsn); 29 }; 30 my $err = $@; 31 $schema_class->storage->disconnect if !$err && $schema_class->storage; 32 undef *{$schema_class}; 33 34 is($err, $tdata{error}); 35 36 my $check_warns = $tdata{warnings}; 37 is(@warns, @$check_warns); 38 for(my $i = 0; $i <= $#$check_warns; $i++) { 39 like($warns[$i], $check_warns->[$i]); 40 } 41 42 my $file_regexes = $tdata{regexes}; 43 my $file_neg_regexes = $tdata{neg_regexes} || {}; 44 my $schema_regexes = delete $file_regexes->{schema}; 45 46 my $schema_path = $DUMP_PATH . '/' . $schema_class; 47 $schema_path =~ s{::}{/}g; 48 dump_file_like($schema_path . '.pm', @$schema_regexes); 49 foreach my $src (keys %$file_regexes) { 50 my $src_file = $schema_path . '/' . $src . '.pm'; 51 dump_file_like($src_file, @{$file_regexes->{$src}}); 52 } 53 foreach my $src (keys %$file_neg_regexes) { 54 my $src_file = $schema_path . '/' . $src . '.pm'; 55 dump_file_not_like($src_file, @{$file_neg_regexes->{$src}}); 56 } 57} 58 59sub dump_file_like { 60 my $path = shift; 61 open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!"; 62 my $contents = do { local $/; <$dumpfh>; }; 63 close($dumpfh); 64 like($contents, $_) for @_; 65} 66 67sub dump_file_not_like { 68 my $path = shift; 69 open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!"; 70 my $contents = do { local $/; <$dumpfh>; }; 71 close($dumpfh); 72 unlike($contents, $_) for @_; 73} 74 75sub append_to_class { 76 my ($class, $string) = @_; 77 $class =~ s{::}{/}g; 78 $class = $DUMP_PATH . '/' . $class . '.pm'; 79 open(my $appendfh, '>>', $class) or die "Failed to open '$class' for append: $!"; 80 print $appendfh $string; 81 close($appendfh); 82} 83 84rmtree($DUMP_PATH, 1, 1); 85 86do_dump_test( 87 classname => 'DBICTest::DumpMore::1', 88 options => { }, 89 error => '', 90 warnings => [ 91 qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, 92 qr/Schema dump completed/, 93 ], 94 regexes => { 95 schema => [ 96 qr/package DBICTest::DumpMore::1;/, 97 qr/->load_classes/, 98 ], 99 Foo => [ 100 qr/package DBICTest::DumpMore::1::Foo;/, 101 qr/->set_primary_key/, 102 qr/1;\n$/, 103 ], 104 Bar => [ 105 qr/package DBICTest::DumpMore::1::Bar;/, 106 qr/->set_primary_key/, 107 qr/1;\n$/, 108 ], 109 }, 110); 111 112append_to_class('DBICTest::DumpMore::1::Foo',q{# XXX This is my custom content XXX}); 113 114do_dump_test( 115 classname => 'DBICTest::DumpMore::1', 116 options => { }, 117 error => '', 118 warnings => [ 119 qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, 120 qr/Schema dump completed/, 121 ], 122 regexes => { 123 schema => [ 124 qr/package DBICTest::DumpMore::1;/, 125 qr/->load_classes/, 126 ], 127 Foo => [ 128 qr/package DBICTest::DumpMore::1::Foo;/, 129 qr/->set_primary_key/, 130 qr/1;\n# XXX This is my custom content XXX/, 131 ], 132 Bar => [ 133 qr/package DBICTest::DumpMore::1::Bar;/, 134 qr/->set_primary_key/, 135 qr/1;\n$/, 136 ], 137 }, 138); 139 140do_dump_test( 141 classname => 'DBICTest::DumpMore::1', 142 options => { really_erase_my_files => 1 }, 143 error => '', 144 warnings => [ 145 qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, 146 qr/Deleting existing file /, 147 qr/Deleting existing file /, 148 qr/Deleting existing file /, 149 qr/Schema dump completed/, 150 ], 151 regexes => { 152 schema => [ 153 qr/package DBICTest::DumpMore::1;/, 154 qr/->load_classes/, 155 ], 156 Foo => [ 157 qr/package DBICTest::DumpMore::1::Foo;/, 158 qr/->set_primary_key/, 159 qr/1;\n$/, 160 ], 161 Bar => [ 162 qr/package DBICTest::DumpMore::1::Bar;/, 163 qr/->set_primary_key/, 164 qr/1;\n$/, 165 ], 166 }, 167 neg_regexes => { 168 Foo => [ 169 qr/# XXX This is my custom content XXX/, 170 ], 171 }, 172); 173 174do_dump_test( 175 classname => 'DBICTest::DumpMore::1', 176 options => { use_namespaces => 1 }, 177 error => '', 178 warnings => [ 179 qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, 180 qr/Schema dump completed/, 181 ], 182 regexes => { 183 schema => [ 184 qr/package DBICTest::DumpMore::1;/, 185 qr/->load_namespaces/, 186 ], 187 'Result/Foo' => [ 188 qr/package DBICTest::DumpMore::1::Result::Foo;/, 189 qr/->set_primary_key/, 190 qr/1;\n$/, 191 ], 192 'Result/Bar' => [ 193 qr/package DBICTest::DumpMore::1::Result::Bar;/, 194 qr/->set_primary_key/, 195 qr/1;\n$/, 196 ], 197 }, 198); 199 200do_dump_test( 201 classname => 'DBICTest::DumpMore::1', 202 options => { use_namespaces => 1, 203 result_namespace => 'Res', 204 resultset_namespace => 'RSet', 205 default_resultset_class => 'RSetBase', 206 }, 207 error => '', 208 warnings => [ 209 qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, 210 qr/Schema dump completed/, 211 ], 212 regexes => { 213 schema => [ 214 qr/package DBICTest::DumpMore::1;/, 215 qr/->load_namespaces/, 216 qr/result_namespace => 'Res'/, 217 qr/resultset_namespace => 'RSet'/, 218 qr/default_resultset_class => 'RSetBase'/, 219 ], 220 'Res/Foo' => [ 221 qr/package DBICTest::DumpMore::1::Res::Foo;/, 222 qr/->set_primary_key/, 223 qr/1;\n$/, 224 ], 225 'Res/Bar' => [ 226 qr/package DBICTest::DumpMore::1::Res::Bar;/, 227 qr/->set_primary_key/, 228 qr/1;\n$/, 229 ], 230 }, 231); 232 233do_dump_test( 234 classname => 'DBICTest::DumpMore::1', 235 options => { use_namespaces => 1, 236 result_namespace => '+DBICTest::DumpMore::1::Res', 237 resultset_namespace => 'RSet', 238 default_resultset_class => 'RSetBase', 239 result_base_class => 'My::ResultBaseClass', 240 schema_base_class => 'My::SchemaBaseClass', 241 }, 242 error => '', 243 warnings => [ 244 qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /, 245 qr/Schema dump completed/, 246 ], 247 regexes => { 248 schema => [ 249 qr/package DBICTest::DumpMore::1;/, 250 qr/->load_namespaces/, 251 qr/result_namespace => '\+DBICTest::DumpMore::1::Res'/, 252 qr/resultset_namespace => 'RSet'/, 253 qr/default_resultset_class => 'RSetBase'/, 254 qr/use base 'My::SchemaBaseClass'/, 255 ], 256 'Res/Foo' => [ 257 qr/package DBICTest::DumpMore::1::Res::Foo;/, 258 qr/use base 'My::ResultBaseClass'/, 259 qr/->set_primary_key/, 260 qr/1;\n$/, 261 ], 262 'Res/Bar' => [ 263 qr/package DBICTest::DumpMore::1::Res::Bar;/, 264 qr/use base 'My::ResultBaseClass'/, 265 qr/->set_primary_key/, 266 qr/1;\n$/, 267 ], 268 }, 269); 270 271done_testing; 272 273END { rmtree($DUMP_PATH, 1, 1) if $ENV{SCHEMA_LOADER_TESTS_BACKCOMPAT}; } 274