X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F40overwrite_modifications.t;h=047f5c095d3e0aabc96bba981bfb5320782c6503;hb=462914a7047b5a165395c0f583f2d09ee317e3e2;hp=20af9206898c4fcf10216841c7d21fd067fbc17d;hpb=c38ec663ec7b40c65613e5ec26542672b15cdbde;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

diff --git a/t/40overwrite_modifications.t b/t/40overwrite_modifications.t
index 20af920..047f5c0 100644
--- a/t/40overwrite_modifications.t
+++ b/t/40overwrite_modifications.t
@@ -1,5 +1,6 @@
 use strict;
-use Test::More tests => 5;
+use warnings;
+use Test::More;
 use Test::Exception;
 use Test::Warn;
 use lib qw(t/lib);
@@ -10,6 +11,7 @@ use File::Spec;
 use File::Temp qw/ tempdir tempfile /;
 
 use DBIx::Class::Schema::Loader;
+use DBIx::Class::Schema::Loader::Utils qw/ slurp_file /;
 
 my $tempdir = tempdir( CLEANUP => 1 );
 my $foopm = File::Spec->catfile( $tempdir,
@@ -20,27 +22,50 @@ dump_schema();
 ok( -f $foopm, 'looks like it dumped' );
 
 # now modify one of the files
-{
-    open my $in, '<', $foopm or die "$! reading $foopm";
-    my ($tfh,$temp) = tempfile( UNLINK => 1);
-    while(<$in>) {
-        s/"bars"/"somethingelse"/;
-        print $tfh $_;
-    }
-    close $tfh;
-    copy( $temp, $foopm );
-}
+rewrite_file($foopm, qr{"bars"}, q{"somethingelse"});
+
+# and dump again without overwrites
+throws_ok {
+    dump_schema();
+} qr/mismatch/, 'throws error dumping without overwrite_modifications';
+
+# and then dump with overwrite
+lives_ok {
+    dump_schema( overwrite_modifications => 1 );
+} 'does not throw when dumping with overwrite_modifications';
+
+# Replace the md5 with a bad MD5 in Foo.pm
+my $foopm_content = slurp_file($foopm);
+my ($md5) = $foopm_content =~/md5sum:(.+)$/m;
+# This cannot be just any arbitrary value, it has to actually look like an MD5
+# value or DBICSL doesn't even see it as an MD5 at all (which makes sense).
+my $bad_md5 = reverse $md5;
+rewrite_file($foopm, qr{md5sum:.+$}, "md5sum:$bad_md5");
 
 # and dump again without overwrites
 throws_ok {
     dump_schema();
 } qr/mismatch/, 'throws error dumping without overwrite_modifications';
 
+$foopm_content = slurp_file($foopm);
+like(
+    $foopm_content,
+    qr/\Q$bad_md5/,
+    'bad MD5 is not rewritten when overwrite_modifications is false'
+);
+
 # and then dump with overwrite
 lives_ok {
     dump_schema( overwrite_modifications => 1 );
 } 'does not throw when dumping with overwrite_modifications';
 
+$foopm_content = slurp_file($foopm);
+unlike(
+    $foopm_content,
+    qr/\Q$bad_md5/,
+    'bad MD5 is rewritten when overwrite_modifications is true'
+);
+
 sub dump_schema {
 
     # need to poke _loader_invoked in order to be able to rerun the
@@ -51,9 +76,26 @@ sub dump_schema {
     my $args = \@_;
 
     warnings_exist {
-        DBIx::Class::Schema::Loader::make_schema_at( 'DBICTest::Schema::Overwrite_modifications',
+        DBIx::Class::Schema::Loader::make_schema_at(
+            'DBICTest::Schema::Overwrite_modifications',
             { dump_directory => $tempdir, @$args },
             [ $make_dbictest_db::dsn ],
         );
-    } [qr/^Dumping manual schema/, qr/^Schema dump completed/ ];
+    } [qr/^Dumping manual schema/, qr/^Schema dump completed/ ],
+    'schema was dumped with expected warnings';
 }
+
+sub rewrite_file {
+    my ($file, $match, $replace) = @_;
+
+    open my $in, '<', $file or die "$! reading $file";
+    my ($tfh, $temp) = tempfile( UNLINK => 1 );
+    while(<$in>) {
+        s/$match/$replace/;
+        print $tfh $_;
+    }
+    close $tfh;
+    copy( $temp, $file );
+}
+
+done_testing();