X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest.pm;h=85e5ee468f440bbd79b881e4d621090b03238af5;hb=d12d82729445072356504a0bfe4169991c4ea92a;hp=80069617d230eaf90ee4fad4c926a0be17aad326;hpb=a705b1758c359438b683daa2c2b1e8cb5a3377da;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm
index 8006961..85e5ee4 100644
--- a/t/lib/DBICTest.pm
+++ b/t/lib/DBICTest.pm
@@ -3,8 +3,9 @@ package # hide from PAUSE
 
 use strict;
 use warnings;
-use DBICTest::AuthorCheck;
+use DBICTest::RunMode;
 use DBICTest::Schema;
+use Carp;
 
 =head1 NAME
 
@@ -65,19 +66,118 @@ sub _sqlite_dbname {
 sub _database {
     my $self = shift;
     my %args = @_;
+
+    if ($ENV{DBICTEST_DSN}) {
+      return (
+        (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
+        { AutoCommit => 1, %args },
+      );
+    }
     my $db_file = $self->_sqlite_dbname(%args);
 
-    unlink($db_file) if -e $db_file;
-    unlink($db_file . "-journal") if -e $db_file . "-journal";
+    for ($db_file, "${db_file}-journal") {
+      next unless -e $_;
+      unlink ($_) or carp (
+        "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!\n"
+      );
+    }
+
     mkdir("t/var") unless -d "t/var";
 
-    my $dsn = $ENV{"DBICTEST_DSN"} || "dbi:SQLite:${db_file}";
-    my $dbuser = $ENV{"DBICTEST_DBUSER"} || '';
-    my $dbpass = $ENV{"DBICTEST_DBPASS"} || '';
+    return ("dbi:SQLite:${db_file}", '', '', {
+      AutoCommit => 1,
+
+      # this is executed on every connect, and thus installs a disconnect/DESTROY
+      # guard for every new $dbh
+      on_connect_do => sub {
+        my $storage = shift;
+        my $dbh = $storage->_get_dbh;
+
+        # no fsync on commit
+        $dbh->do ('PRAGMA synchronous = OFF');
+
+        # set a *DBI* disconnect callback, to make sure the physical SQLite
+        # file is still there (i.e. the test does not attempt to delete
+        # an open database, which fails on Win32)
+        if (my $guard_cb = __mk_disconnect_guard($db_file)) {
+          $dbh->{Callbacks} = {
+            connect => sub { $guard_cb->('connect') },
+            disconnect => sub { $guard_cb->('disconnect') },
+            DESTROY => sub { $guard_cb->('DESTROY') },
+          };
+        }
+      },
+      %args,
+    });
+}
+
+sub __mk_disconnect_guard {
+  return if $] == '5.013006'; # leaks handles, delaying DESTROY, can't work right
+
+  my $db_file = shift;
+  return unless -f $db_file;
+
+  my $orig_inode = (stat($db_file))[1]
+    or return;
 
-    my @connect_info = ($dsn, $dbuser, $dbpass, { AutoCommit => 1, %args });
+  my $clan_connect_caller = '*UNKNOWN*';
+  my $i;
+  while ( my ($pack, $file, $line) = caller(++$i) ) {
+    next if $file eq __FILE__;
+    next if $pack =~ /^DBIx::Class|^Try::Tiny/;
+    $clan_connect_caller = "$file line $line";
+  }
 
-    return @connect_info;
+  my $failed_once = 0;
+  my $connected = 1;
+
+  return sub {
+    return if $failed_once;
+
+    my $event = shift;
+    if ($event eq 'connect') {
+      # this is necessary in case we are disconnected and connected again, all within the same $dbh object
+      $connected = 1;
+      return;
+    }
+    elsif ($event eq 'disconnect') {
+      $connected = 0;
+    }
+    elsif ($event eq 'DESTROY' and ! $connected ) {
+      return;
+    }
+
+    my $fail_reason;
+    if (! -e $db_file) {
+      $fail_reason = 'is missing';
+    }
+    else {
+      my $cur_inode = (stat($db_file))[1];
+
+      if ($orig_inode != $cur_inode) {
+        # pack/unpack to match the unsigned longs returned by `stat`
+        $fail_reason = sprintf 'was recreated (initially inode %s, now %s)', (
+          map { unpack ('L', pack ('l', $_) ) } ($orig_inode, $cur_inode )
+        );
+      }
+    }
+
+    if ($fail_reason) {
+      $failed_once++;
+
+      require Test::Builder;
+      my $t = Test::Builder->new;
+      local $Test::Builder::Level = $Test::Builder::Level + 3;
+      $t->ok (0,
+        "$db_file originally created at $clan_connect_caller $fail_reason before $event "
+      . 'of DBI handle - a strong indicator that the database file was tampered with while '
+      . 'still being open. This action would fail massively if running under Win32, hence '
+      . 'we make sure it fails on any OS :)'
+      );
+    }
+
+    return; # this empty return is a DBI requirement
+  };
 }
 
 sub init_schema {
@@ -93,14 +193,15 @@ sub init_schema {
     } else {
       $schema = DBICTest::Schema->compose_namespace('DBICTest');
     }
+
     if( $args{storage_type}) {
       $schema->storage_type($args{storage_type});
     }
+
     if ( !$args{no_connect} ) {
       $schema = $schema->connect($self->_database(%args));
-      $schema->storage->on_connect_do(['PRAGMA synchronous = OFF'])
-       unless $self->has_custom_dsn;
     }
+
     if ( !$args{no_deploy} ) {
         __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
         __PACKAGE__->populate_schema( $schema )