t/storage/reconnect.t

   1 use strict;
   2 use warnings;
   3
   4 use FindBin;
   5 use B::Deparse;
   6 use File::Copy 'move';
   7 use Scalar::Util 'weaken';
   8 use Test::More;
   9 use Test::Exception;
  10 use lib qw(t/lib);
  11 use DBICTest;
  12
  13 my $db_orig = DBICTest->_sqlite_dbfilename;
  14 my $db_tmp  = "$db_orig.tmp";
  15
  16 # Set up the "usual" sqlite for DBICTest
  17 my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
  18
  19 # Make sure we're connected by doing something
  20 my @art = $schema->resultset("Artist")->search({ }, { order_by => { -desc => 'name' }});
  21 cmp_ok(@art, '==', 3, "Three artists returned");
  22
  23 # Disconnect the dbh, and be sneaky about it
  24 # Also test if DBD::SQLite finaly knows how to ->disconnect properly
  25 {
  26   my $w;
  27   local $SIG{__WARN__} = sub { $w = shift };
  28   $schema->storage->_dbh->disconnect;
  29   ok ($w !~ /active statement handles/, 'SQLite can disconnect properly');
  30 }
  31
  32 # Try the operation again - What should happen here is:
  33 #   1. S::DBI blindly attempts the SELECT, which throws an exception
  34 #   2. It catches the exception, checks ->{Active}/->ping, sees the disconnected state...
  35 #   3. Reconnects, and retries the operation
  36 #   4. Success!
  37 my @art_two = $schema->resultset("Artist")->search({ }, { order_by => { -desc => 'name' }});
  38 cmp_ok(@art_two, '==', 3, "Three artists returned");
  39
  40 ### Now, disconnect the dbh, and move the db file;
  41 # create a new one full of garbage, prevent SQLite from connecting.
  42 $schema->storage->_dbh->disconnect;
  43 move( $db_orig, $db_tmp )
  44   or die "failed to move $db_orig to $db_tmp: $!";
  45 open my $db_file, '>', $db_orig;
  46 print $db_file 'THIS IS NOT A REAL DATABASE';
  47 close $db_file;
  48
  49 ### Try the operation again... it should fail, since there's no valid db
  50 {
  51   # Catch the DBI connection error
  52   local $SIG{__WARN__} = sub {};
  53   throws_ok {
  54     $schema->resultset("Artist")->create({ name => 'not gonna happen' });
  55   }  qr/not a database/, 'The operation failed';
  56 }
  57
  58 ok (! $schema->storage->connected, 'We are not connected' );
  59
  60 ### Now, move the db file back to the correct name
  61 unlink($db_orig) or die "could not delete $db_orig: $!";
  62 move( $db_tmp, $db_orig )
  63   or die "could not move $db_tmp to $db_orig: $!";
  64
  65 ### Try the operation again... this time, it should succeed
  66 my @art_four;
  67 lives_ok {
  68     @art_four = $schema->resultset("Artist")->search( {}, { order_by => { -desc => 'name' } } );
  69 } 'The operation succeeded';
  70 cmp_ok( @art_four, '==', 3, "Three artists returned" );
  71
  72 # check that reconnection contexts are preserved in txn_do / dbh_do
  73
  74 my $args = [1, 2, 3];
  75
  76 my $ctx_map = {
  77   VOID => {
  78     invoke => sub { shift->(); 1 },
  79     wa => undef,
  80   },
  81   SCALAR => {
  82     invoke => sub { my $foo = shift->() },
  83     wa => '',
  84   },
  85   LIST => {
  86     invoke => sub { my @foo = shift->() },
  87     wa => 1,
  88   },
  89 };
  90
  91 for my $ctx (keys %$ctx_map) {
  92
  93   # start disconnected and then connected
  94   $schema->storage->disconnect;
  95   for (1, 2) {
  96     my $disarmed;
  97
  98     $ctx_map->{$ctx}{invoke}->(sub { $schema->txn_do(sub {
  99       is_deeply (\@_, $args, 'Args propagated correctly' );
 100
 101       is (wantarray(), $ctx_map->{$ctx}{wa}, "Correct $ctx context");
 102
 103       # this will cause a retry
 104       $schema->storage->_dbh->disconnect unless $disarmed++;
 105
 106       isa_ok ($schema->resultset('Artist')->next, 'DBICTest::Artist');
 107     }, @$args) });
 108   }
 109 };
 110
 111 # make sure RT#110429 does not recur on manual DBI-side disconnect
 112 for my $cref (
 113   sub {
 114     my $schema = shift;
 115
 116     my $g = $schema->txn_scope_guard;
 117
 118     is( $schema->storage->transaction_depth, 1, "Expected txn depth" );
 119
 120     $schema->storage->_dbh->disconnect;
 121
 122     $schema->storage->dbh_do(sub { $_[1]->do('SELECT 1') } );
 123   },
 124   sub {
 125     my $schema = shift;
 126     $schema->txn_do(sub {
 127       $schema->storage->_dbh->disconnect
 128     } );
 129   },
 130   sub {
 131     my $schema = shift;
 132     $schema->txn_do(sub {
 133       $schema->storage->disconnect;
 134       die "VIOLENCE";
 135     } );
 136   },
 137 ) {
 138
 139   note( "Testing with " . B::Deparse->new->coderef2text($cref) );
 140
 141   $schema->storage->disconnect;
 142
 143   ok( !$schema->storage->connected, 'Not connected' );
 144
 145   is( $schema->storage->transaction_depth, undef, "Start with unknown txn depth" );
 146
 147   # messages vary depending on version and whether txn or do, whatever
 148   dies_ok {
 149     $cref->($schema)
 150   } 'Threw *something*';
 151
 152   ok( !$schema->storage->connected, 'Not connected as a result of failed rollback' );
 153
 154   is( $schema->storage->transaction_depth, undef, "Depth expectedly unknown after failed rollbacks" );
 155 }
 156
 157 # check that things aren't crazy with a non-violent disconnect
 158 {
 159   my $schema = DBICTest->init_schema( sqlite_use_file => 0, no_deploy => 1 );
 160   weaken( my $ws = $schema );
 161
 162   $schema->is_executed_sql_bind( sub {
 163     $ws->txn_do(sub { $ws->storage->disconnect } );
 164   }, [ [ 'BEGIN' ] ], 'Only one BEGIN statement' );
 165
 166   $schema->is_executed_sql_bind( sub {
 167     my $g = $ws->txn_scope_guard;
 168     $ws->storage->disconnect;
 169   }, [ [ 'BEGIN' ] ], 'Only one BEGIN statement' );
 170 }
 171
 172 done_testing;