11 use File::Temp qw/ tempdir tempfile /;
13 use DBIx::Class::Schema::Loader;
14 use DBIx::Class::Schema::Loader::Utils qw/ slurp_file /;
16 my $tempdir = tempdir( CLEANUP => 1 );
17 my $foopm = File::Spec->catfile( $tempdir,
18 qw| DBICTest Schema Overwrite_modifications Result Foo.pm |);
21 # check that we dumped
22 ok( -f $foopm, 'looks like it dumped' );
24 # now modify one of the files
25 rewrite_file($foopm, qr{"bars"}, q{"somethingelse"});
27 # and dump again without overwrites
30 } qr/mismatch/, 'throws error dumping without overwrite_modifications';
32 # and then dump with overwrite
34 dump_schema( overwrite_modifications => 1 );
35 } 'does not throw when dumping with overwrite_modifications';
37 # Replace the md5 with a bad MD5 in Foo.pm
38 my $foopm_content = slurp_file($foopm);
39 my ($md5) = $foopm_content =~/md5sum:(.+)$/m;
40 # This cannot be just any arbitrary value, it has to actually look like an MD5
41 # value or DBICSL doesn't even see it as an MD5 at all (which makes sense).
42 my $bad_md5 = reverse $md5;
43 rewrite_file($foopm, qr{md5sum:.+$}, "md5sum:$bad_md5");
45 # and dump again without overwrites
48 } qr/mismatch/, 'throws error dumping without overwrite_modifications';
50 $foopm_content = slurp_file($foopm);
54 'bad MD5 is not rewritten when overwrite_modifications is false'
57 # and then dump with overwrite
59 dump_schema( overwrite_modifications => 1 );
60 } 'does not throw when dumping with overwrite_modifications';
62 $foopm_content = slurp_file($foopm);
66 'bad MD5 is rewritten when overwrite_modifications is true'
71 # need to poke _loader_invoked in order to be able to rerun the
72 # loader multiple times.
73 DBICTest::Schema::Overwrite_modifications->_loader_invoked(0)
74 if @DBICTest::Schema::Overwrite_modifications::ISA;
79 DBIx::Class::Schema::Loader::make_schema_at(
80 'DBICTest::Schema::Overwrite_modifications',
81 { dump_directory => $tempdir, @$args },
82 [ $make_dbictest_db::dsn ],
84 } [qr/^Dumping manual schema/, qr/^Schema dump completed/ ],
85 'schema was dumped with expected warnings';
89 my ($file, $match, $replace) = @_;
91 open my $in, '<', $file or die "$! reading $file";
92 my ($tfh, $temp) = tempfile( UNLINK => 1 );