t/752sqlite.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use Test::Exception;
   6 use Test::Warn;
   7 use Time::HiRes 'time';
   8
   9 use lib qw(t/lib);
  10 use DBICTest;
  11 use DBIx::Class::_Util qw(sigwarn_silencer modver_gt_or_eq);
  12
  13 # savepoints test
  14 {
  15   my $schema = DBICTest->init_schema(auto_savepoint => 1);
  16
  17   my $ars = $schema->resultset('Artist');
  18
  19   # test two-phase commit and inner transaction rollback from nested transactions
  20   $schema->txn_do(sub {
  21     $ars->create({ name => 'in_outer_transaction' });
  22     $schema->txn_do(sub {
  23       $ars->create({ name => 'in_inner_transaction' });
  24     });
  25     ok($ars->search({ name => 'in_inner_transaction' })->first,
  26       'commit from inner transaction visible in outer transaction');
  27     throws_ok {
  28       $schema->txn_do(sub {
  29         $ars->create({ name => 'in_inner_transaction_rolling_back' });
  30         die 'rolling back inner transaction';
  31       });
  32     } qr/rolling back inner transaction/, 'inner transaction rollback executed';
  33     $ars->create({ name => 'in_outer_transaction2' });
  34   });
  35
  36   ok($ars->search({ name => 'in_outer_transaction' })->first,
  37     'commit from outer transaction');
  38   ok($ars->search({ name => 'in_outer_transaction2' })->first,
  39     'second commit from outer transaction');
  40   ok($ars->search({ name => 'in_inner_transaction' })->first,
  41     'commit from inner transaction');
  42   is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first,
  43     undef,
  44     'rollback from inner transaction';
  45 }
  46
  47 # check that we work somewhat OK with braindead SQLite transaction handling
  48 #
  49 # As per https://metacpan.org/source/ADAMK/DBD-SQLite-1.37/lib/DBD/SQLite.pm#L921
  50 # SQLite does *not* try to synchronize
  51 #
  52 # However DBD::SQLite 1.38_02 seems to fix this, with an accompanying test:
  53 # https://metacpan.org/source/ADAMK/DBD-SQLite-1.38_02/t/54_literal_txn.t
  54
  55 my $lit_txn_todo = modver_gt_or_eq('DBD::SQLite', '1.38_02')
  56   ? undef
  57   : "DBD::SQLite before 1.38_02 is retarded wrt detecting literal BEGIN/COMMIT statements"
  58 ;
  59
  60 for my $prefix_comment (qw/Begin_only Commit_only Begin_and_Commit/) {
  61   note "Testing with comment prefixes on $prefix_comment";
  62
  63   # FIXME warning won't help us for the time being
  64   # perhaps when (if ever) DBD::SQLite gets fixed,
  65   # we can do something extra here
  66   local $SIG{__WARN__} = sigwarn_silencer( qr/Internal transaction state .+? does not seem to match/ )
  67     if ( $lit_txn_todo && !$ENV{TEST_VERBOSE} );
  68
  69   my ($c_begin, $c_commit) = map { $prefix_comment =~ $_ ? 1 : 0 } (qr/Begin/, qr/Commit/);
  70
  71   my $schema = DBICTest->init_schema( no_deploy => 1 );
  72   my $ars = $schema->resultset('Artist');
  73
  74   ok (! $schema->storage->connected, 'No connection yet');
  75
  76   $schema->storage->dbh->do(<<'DDL');
  77 CREATE TABLE artist (
  78   artistid INTEGER PRIMARY KEY NOT NULL,
  79   name varchar(100),
  80   rank integer DEFAULT 13,
  81   charfield char(10) NULL
  82 );
  83 DDL
  84
  85   my $artist = $ars->create({ name => 'Artist_' . time() });
  86   is ($ars->count, 1, 'Inserted artist ' . $artist->name);
  87
  88   ok ($schema->storage->connected, 'Connected');
  89   ok ($schema->storage->_dbh->{AutoCommit}, 'DBD not in txn yet');
  90
  91   $schema->storage->dbh->do(join "\n",
  92     $c_begin ? '-- comment' : (),
  93     'BEGIN TRANSACTION'
  94   );
  95   ok ($schema->storage->connected, 'Still connected');
  96   {
  97     local $TODO = $lit_txn_todo if $c_begin;
  98     ok (! $schema->storage->_dbh->{AutoCommit}, "DBD aware of txn begin with comments on $prefix_comment");
  99   }
 100
 101   $schema->storage->dbh->do(join "\n",
 102     $c_commit ? '-- comment' : (),
 103     'COMMIT'
 104   );
 105   ok ($schema->storage->connected, 'Still connected');
 106   {
 107     local $TODO = $lit_txn_todo if $c_commit and ! $c_begin;
 108     ok ($schema->storage->_dbh->{AutoCommit}, "DBD aware txn ended with comments on $prefix_comment");
 109   }
 110
 111   is ($ars->count, 1, 'Inserted artists still there');
 112
 113   {
 114     # this never worked in the 1st place
 115     local $TODO = $lit_txn_todo if ! $c_begin and $c_commit;
 116
 117     # odd argument passing, because such nested crefs leak on 5.8
 118     lives_ok {
 119       $schema->storage->txn_do (sub {
 120         ok ($_[0]->find({ name => $_[1] }), "Artist still where we left it after cycle with comments on $prefix_comment");
 121       }, $ars, $artist->name );
 122     } "Succesfull transaction with comments on $prefix_comment";
 123   }
 124 }
 125
 126
 127 my $schema = DBICTest->init_schema();
 128
 129 # make sure the side-effects of RT#67581 do not result in data loss
 130 my $row;
 131 warnings_exist { $row = $schema->resultset('Artist')->create ({ name => 'alpha rank', rank => 'abc' }) }
 132   [qr/Non-integer value supplied for column 'rank' despite the integer datatype/],
 133   'proper warning on string insertion into an numeric column'
 134 ;
 135 $row->discard_changes;
 136 is ($row->rank, 'abc', 'proper rank inserted into database');
 137
 138 # and make sure we do not lose actual bigints
 139 {
 140   package DBICTest::BigIntArtist;
 141   use base 'DBICTest::Schema::Artist';
 142   __PACKAGE__->table('artist');
 143   __PACKAGE__->add_column(bigint => { data_type => 'bigint' });
 144 }
 145 $schema->register_class(BigIntArtist => 'DBICTest::BigIntArtist');
 146 $schema->storage->dbh_do(sub {
 147   $_[1]->do('ALTER TABLE artist ADD COLUMN bigint BIGINT');
 148 });
 149
 150 # test upper/lower boundaries for sqlite and some values inbetween
 151 # range is -(2**63) .. 2**63 - 1
 152 for my $bi ( qw(
 153   -9223372036854775808
 154   -9223372036854775807
 155   -8694837494948124658
 156   -6848440844435891639
 157   -5664812265578554454
 158   -5380388020020483213
 159   -2564279463598428141
 160   2442753333597784273
 161   4790993557925631491
 162   6773854980030157393
 163   7627910776496326154
 164   8297530189347439311
 165   9223372036854775806
 166   9223372036854775807
 167
 168   4294967295
 169   4294967296
 170
 171   -4294967296
 172   -4294967295
 173   -4294967294
 174
 175   -2147483649
 176   -2147483648
 177   -2147483647
 178   -2147483646
 179
 180   2147483646
 181   2147483647
 182 ),
 183   # these values cause exceptions even with all workarounds in place on these
 184   # fucked DBD::SQLite versions *regardless* of ivsize >.<
 185   ( modver_gt_or_eq('DBD::SQLite', '1.34') and ! modver_gt_or_eq('DBD::SQLite', '1.37') )
 186     ? ()
 187     : ( '2147483648', '2147483649' )
 188 ) {
 189   # unsigned 32 bit ints have a range of −2,147,483,648 to 2,147,483,647
 190   # alternatively expressed as the hexadecimal numbers below
 191   # the comparison math will come out right regardless of ivsize, since
 192   # we are operating within 31 bits
 193   # P.S. 31 because one bit is lost for the sign
 194   my $v_bits = ($bi > 0x7fff_ffff || $bi < -0x8000_0000) ? 64 : 32;
 195
 196   my $v_desc = sprintf '%s (%d bit signed int)', $bi, $v_bits;
 197
 198   my $w;
 199   lives_ok {
 200     local $SIG{__WARN__} = sigwarn_silencer( qr/datatype mismatch/ );
 201     $row = $schema->resultset('BigIntArtist')->create({ bigint => $bi });
 202   } "Insering value $bi ($v_desc)" or next;
 203
 204   is ($w, undef, 'No mismatch warning on bigints' );
 205
 206   # explicitly using eq, to make sure we did not nummify the argument
 207   # which can be an issue on 32 bit ivsize
 208   cmp_ok ($row->bigint, 'eq', $bi, "value in object correct ($v_desc)");
 209
 210   $row->discard_changes;
 211
 212   cmp_ok (
 213     $row->bigint,
 214
 215     # the test will not pass an == if we are running under 32 bit ivsize
 216     # use 'eq' on the numified (and possibly "scientificied") returned value
 217     DBIx::Class::_ENV_::IV_SIZE < 8 ? 'eq' : '==',
 218
 219     # in 1.37 DBD::SQLite switched to proper losless representation of bigints
 220     # regardless of ivize
 221     # before this use 'eq' (from above) on the numified (and possibly
 222     # "scientificied") returned value
 223     (DBIx::Class::_ENV_::IV_SIZE < 8 and ! modver_gt_or_eq('DBD::SQLite', '1.37')) ? $bi+0 : $bi,
 224
 225     "value in database correct ($v_desc)"
 226   );
 227 }
 228
 229 done_testing;
 230
 231 # vim:sts=2 sw=2: