Merge branch 'unlink_guard'

Changes

@@ -3,6 +3,12 @@ Revision history for DBIx::Class
     * Fixes
         - Make sure Oracle identifier shortener applies to auto-generated
           column names, so we stay within the 30-char limit
+        - Fix a Storage/$dbh leak introduced by th migration to
+          Try::Tiny (this is *not* a Try::Tiny bug)
+
+    * Misc
+        - Test suite default on-disk database now checks for Win32
+          fail-conditions even when running on other OSes
 
 0.08122 2010-05-03 17:41 (UTC)
     * New Features

lib/DBIx/Class/Storage/DBI.pm

@@ -1166,7 +1166,9 @@ sub _connect {
     $DBI::connect_via = 'connect';
   }
 
-  try {
+  # FIXME - this should have been Try::Tiny, but triggers a leak-bug in perl(!)
+  # related to coderef refcounting. A failing test has been submitted to T::T
+  my $connect_ok = eval {
     if(ref $info[0] eq 'CODE') {
        $dbh = $info[0]->();
     }
@@ -1195,14 +1197,17 @@ sub _connect {
       $dbh->{RaiseError} = 1;
       $dbh->{PrintError} = 0;
     }
-  }
-  catch {
-    $self->throw_exception("DBI Connection failed: $_")
-  }
-  finally {
-    $DBI::connect_via = $old_connect_via if $old_connect_via;
+
+    1;
   };
 
+  my $possible_err = $@;
+  $DBI::connect_via = $old_connect_via if $old_connect_via;
+
+  unless ($connect_ok) {
+    $self->throw_exception("DBI Connection failed: $possible_err")
+  }
+
   $self->_dbh_autocommit($dbh->{AutoCommit});
   $dbh;
 }

t/52cycle.t

@@ -21,8 +21,18 @@ my $weak;
 
 {
   my $s = $weak->{schema} = DBICTest->init_schema;
+  ok ($s->storage->connected, 'we are connected');
   memory_cycle_ok($s, 'No cycles in schema');
 
+  my $storage = $weak->{storage} = $s->storage;
+  memory_cycle_ok($storage, 'No cycles in storage');
+
+  my $dbh = $weak->{dbh} = $s->storage->_get_dbh;
+  memory_cycle_ok($dbh, 'No cycles in DBI handle');
+
+  my $sqla = $weak->{sqla} = $s->storage->sql_maker;
+  memory_cycle_ok($sqla, 'No cycles in SQL maker');
+
   my $rs = $weak->{resultset} = $s->resultset ('Artist');
   memory_cycle_ok($rs, 'No cycles in resultset');
 

t/lib/DBICTest.pm

@@ -5,6 +5,7 @@ use strict;
 use warnings;
 use DBICTest::AuthorCheck;
 use DBICTest::Schema;
+use Carp;
 
 =head1 NAME
 
@@ -65,19 +66,96 @@ sub _sqlite_dbname {
 sub _database {
     my $self = shift;
     my %args = @_;
-    my $db_file = $self->_sqlite_dbname(%args);
 
-    unlink($db_file) if -e $db_file;
-    unlink($db_file . "-journal") if -e $db_file . "-journal";
-    mkdir("t/var") unless -d "t/var";
+    if ($ENV{DBICTEST_DSN}) {
+      return (
+        (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
+        { AutoCommit => 1, %args },
+      );
+    }
+    my $db_file = $self->_sqlite_dbname(%args);
 
-    my $dsn = $ENV{"DBICTEST_DSN"} || "dbi:SQLite:${db_file}";
-    my $dbuser = $ENV{"DBICTEST_DBUSER"} || '';
-    my $dbpass = $ENV{"DBICTEST_DBPASS"} || '';
+    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"
+      );
+    }
 
-    my @connect_info = ($dsn, $dbuser, $dbpass, { AutoCommit => 1, %args });
+    mkdir("t/var") unless -d "t/var";
 
-    return @connect_info;
+    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 (-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
+          };
+          $dbh->{Callbacks} = {
+            connect => sub { $cb->('connect') },
+            disconnect => sub { $cb->('disconnect') },
+            DESTROY => sub { $cb->('DESTROY') },
+          };
+        }
+      },
+      %args,
+    });
 }
 
 sub init_schema {
@@ -93,14 +171,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 )