From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sat, 18 Sep 2010 01:08:06 +0000 (+0200)
Subject: Make test suite pass under DBICTEST_SQLITE_USE_FILE=1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d9c17594ab3be0b866c555750cdbd1ad6a1b34e6;p=dbsrgits%2FDBIx-Class-Historic.git

Make test suite pass under DBICTEST_SQLITE_USE_FILE=1
---

diff --git a/t/93single_accessor_object.t b/t/93single_accessor_object.t
index 41ac5da..e250183 100644
--- a/t/93single_accessor_object.t
+++ b/t/93single_accessor_object.t
@@ -6,13 +6,10 @@ use Test::Exception;
 use lib qw(t/lib);
 use DBICTest;
 
-my $schema = DBICTest->init_schema();
-
-plan tests => 10;
-
 # Test various uses of passing an object to find, create, and update on a single
 # rel accessor
 {
+  my $schema = DBICTest->init_schema();
   my $artist = $schema->resultset("Artist")->find(1);
 
   my $cd = $schema->resultset("CD")->find_or_create({
@@ -42,9 +39,9 @@ plan tests => 10;
   is($track->get_column('cd'), $another_cd->cdid, 'track matches another CD after update');
 }
 
-$schema = DBICTest->init_schema();
 
 {
+  my $schema = DBICTest->init_schema();
   my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' });
   my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982, genreid => undef });
 
@@ -52,9 +49,8 @@ $schema = DBICTest->init_schema();
   ok(!defined($cd->genre), 'genre accessor returns undef');
 }
 
-$schema = DBICTest->init_schema();
-
 {
+  my $schema = DBICTest->init_schema();
   my $artist = $schema->resultset('Artist')->create({ artistid => 666, name => 'bad religion' });
   my $genre = $schema->resultset('Genre')->create({ genreid => 88, name => 'disco' });
   my $cd = $schema->resultset('CD')->create({ cdid => 187, artist => 1, title => 'how could hell be any worse?', year => 1982 });
@@ -62,3 +58,4 @@ $schema = DBICTest->init_schema();
   dies_ok { $cd->genre } 'genre accessor throws without column';
 }
 
+done_testing;
diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm
index 50bd663..7ce9410 100644
--- a/t/lib/DBICTest.pm
+++ b/t/lib/DBICTest.pm
@@ -99,58 +99,11 @@ sub _database {
         # 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 (-e $db_file and my $orig_inode = (stat($db_file))[1] ) {
-
-          my $failed_once;
-          my $connected = 1;
-          my $cb = 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];
-
-              $fail_reason ||= sprintf 'was recreated (inode %s vs %s)', ($orig_inode, $cur_inode)
-                if $orig_inode != $cur_inode;
-            }
-
-            if ($fail_reason) {
-              $failed_once++;
-
-              require Test::Builder;
-              my $t = Test::Builder->new;
-              local $Test::Builder::Level = $Test::Builder::Level + 1;
-
-              $t->ok (0,
-                  "$db_file $fail_reason before $event of DBI handle - a strong indicator that "
-                . 'the SQLite file was tampered with while still being open. This action would '
-                . 'fail massively if running under Win32, hence DBICTest makes sure it fails '
-                . 'on any OS :)'
-              );
-            }
-
-            return; # this empty return is a DBI requirement
-          };
+        if (my $guard_cb = __mk_disconnect_guard($db_file)) {
           $dbh->{Callbacks} = {
-            connect => sub { $cb->('connect') },
-            disconnect => sub { $cb->('disconnect') },
-            DESTROY => sub { $cb->('DESTROY') },
+            connect => sub { $guard_cb->('connect') },
+            disconnect => sub { $guard_cb->('disconnect') },
+            DESTROY => sub { $guard_cb->('DESTROY') },
           };
         }
       },
@@ -158,6 +111,73 @@ sub _database {
     });
 }
 
+sub __mk_disconnect_guard {
+  my $db_file = shift;
+  return unless -f $db_file;
+
+  my $orig_inode = (stat($db_file))[1]
+    or return;
+
+  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";
+  }
+
+  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 {
     my $self = shift;
     my %args = @_;
diff --git a/t/row/inflate_result.t b/t/row/inflate_result.t
index 7606a54..ab35f86 100644
--- a/t/row/inflate_result.t
+++ b/t/row/inflate_result.t
@@ -76,7 +76,7 @@ my $admin_data = {
     admin    => 1
 };
 
-ok( my $schema = My::Schema->connection('dbi:SQLite:dbname=:memory:') );
+ok( my $schema = My::Schema->connection(DBICTest->_database) );
 
 ok(
     $schema->storage->dbh->do(
diff --git a/t/sqlmaker/limit_dialects/custom.t b/t/sqlmaker/limit_dialects/custom.t
index 4a78951..650cd99 100644
--- a/t/sqlmaker/limit_dialects/custom.t
+++ b/t/sqlmaker/limit_dialects/custom.t
@@ -4,6 +4,7 @@ use warnings;
 use Test::More;
 
 use lib qw(t/lib);
+use DBICTest;
 use DBICTest::Schema;
 use DBIC::SqlMakerTest;
 
@@ -22,8 +23,7 @@ use DBIC::SqlMakerTest;
     );
   }
 }
-
-my $s = DBICTest::Schema->connect ('dbi:SQLite::memory:');
+my $s = DBICTest::Schema->connect (DBICTest->_database);
 $s->storage->sql_maker_class ('DBICTest::SQLMaker::CustomDialect');
 
 my $rs = $s->resultset ('CD');
diff --git a/t/storage/txn.t b/t/storage/txn.t
index f4c5699..87d1b45 100644
--- a/t/storage/txn.t
+++ b/t/storage/txn.t
@@ -184,13 +184,16 @@ my $fail_code = sub {
   })->first;
   ok(!defined($cd), q{deleted the failed txn's cd});
   $schema->storage->_dbh->rollback;
+
 }
 
 # reset schema object (the txn_rollback meddling screws it up)
-$schema = DBICTest->init_schema();
+undef $schema;
 
 # Test nested failed txn_do()
 {
+  my $schema = DBICTest->init_schema();
+
   is( $schema->storage->{transaction_depth}, 0, 'txn depth starts at 0');
 
   my $nested_fail_code = sub {
@@ -221,18 +224,16 @@ $schema = DBICTest->init_schema();
 
 # Grab a new schema to test txn before connect
 {
-    my $schema2 = DBICTest->init_schema(no_deploy => 1);
-    lives_ok (sub {
-        $schema2->txn_begin();
-        $schema2->txn_begin();
-    }, 'Pre-connection nested transactions.');
-
-    # although not connected DBI would still warn about rolling back at disconnect
-    $schema2->txn_rollback;
-    $schema2->txn_rollback;
-    $schema2->storage->disconnect;
+  my $schema = DBICTest->init_schema(no_deploy => 1);
+  lives_ok (sub {
+    $schema->txn_begin();
+    $schema->txn_begin();
+  }, 'Pre-connection nested transactions.');
+
+  # although not connected DBI would still warn about rolling back at disconnect
+  $schema->txn_rollback;
+  $schema->txn_rollback;
 }
-$schema->storage->disconnect;
 
 # Test txn_scope_guard
 {
@@ -240,11 +241,11 @@ $schema->storage->disconnect;
 
   is($schema->storage->transaction_depth, 0, "Correct transaction depth");
   my $artist_rs = $schema->resultset('Artist');
+
   my $fn = __FILE__;
   throws_ok {
    my $guard = $schema->txn_scope_guard;
 
-
     $artist_rs->create({
       name => 'Death Cab for Cutie',
       made_up_column => 1,
@@ -263,22 +264,28 @@ $schema->storage->disconnect;
   ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
 
   lives_ok (sub {
+
+    # this weird assignment is to stop perl <= 5.8.9 leaking $schema on nested sub{}s
+    my $s = $schema;
+
     warnings_exist ( sub {
       # The 0 arg says don't die, just let the scope guard go out of scope
       # forcing a txn_rollback to happen
-      outer($schema, 0);
+      outer($s, 0);
     }, qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./, 'Out of scope warning detected');
+
     ok(!$artist_rs->find({name => 'Death Cab for Cutie'}), "Artist not created");
+
   }, 'rollback successful withot exception');
 
   sub outer {
-    my ($schema) = @_;
+    my ($schema, $fatal) = @_;
 
     my $guard = $schema->txn_scope_guard;
     $schema->resultset('Artist')->create({
       name => 'Death Cab for Cutie',
     });
-    inner(@_);
+    inner($schema, $fatal);
   }
 
   sub inner {
@@ -287,7 +294,7 @@ $schema->storage->disconnect;
     my $inner_guard = $schema->txn_scope_guard;
     is($schema->storage->transaction_depth, 2, "Correct transaction depth");
 
-    my $artist = $artist_rs->find({ name => 'Death Cab for Cutie' });
+    my $artist = $schema->resultset('Artist')->find({ name => 'Death Cab for Cutie' });
 
     eval {
       $artist->cds->create({