t/750firebird.t

   1 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Exception;
   8 use DBIx::Class::Optional::Dependencies ();
   9 use DBIx::Class::_Util 'scope_guard';
  10 use List::Util 'shuffle';
  11 use Try::Tiny;
  12
  13 use DBICTest;
  14
  15 my $env2optdep = {
  16   DBICTEST_FIREBIRD => 'test_rdbms_firebird',
  17   DBICTEST_FIREBIRD_INTERBASE => 'test_rdbms_firebird_interbase',
  18   DBICTEST_FIREBIRD_ODBC => 'test_rdbms_firebird_odbc',
  19 };
  20
  21 plan skip_all => join (' ',
  22   'Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN}',
  23   'and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN},',
  24   '_USER and _PASS to run these tests.',
  25
  26   'WARNING: this test creates and drops the tables "artist", "bindtype_test" and',
  27   '"sequence_test"; the generators "gen_artist_artistid", "pkid1_seq", "pkid2_seq"',
  28   'and "nonpkid_seq" and the trigger "artist_bi".',
  29 ) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep;
  30
  31 # tests stolen from 749sybase_asa.t
  32
  33 # Example DSNs:
  34 # dbi:Firebird:db=/var/lib/firebird/2.5/data/hlaghdb.fdb
  35 # dbi:InterBase:db=/var/lib/firebird/2.5/data/hlaghdb.fdb
  36
  37 # Example ODBC DSN:
  38 # dbi:ODBC:Driver=Firebird;Dbname=/var/lib/firebird/2.5/data/hlaghdb.fdb
  39
  40 my $schema;
  41
  42 for my $prefix (shuffle keys %$env2optdep) { SKIP: {
  43
  44   skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1)
  45     unless  DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix});
  46
  47   my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/;
  48
  49   note "Testing with ${prefix}_DSN";
  50
  51   $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
  52     auto_savepoint  => 1,
  53     quote_names     => 1,
  54     ($dsn !~ /ODBC/ ? (on_connect_call => 'use_softcommit') : ()),
  55   });
  56   my $dbh = $schema->storage->dbh;
  57
  58   my $sg = scope_guard { cleanup($schema) };
  59
  60   eval { $dbh->do(q[DROP TABLE "artist"]) };
  61   $dbh->do(<<EOF);
  62   CREATE TABLE "artist" (
  63     "artistid" INT PRIMARY KEY,
  64     "name" VARCHAR(255),
  65     "charfield" CHAR(10),
  66     "rank" INT DEFAULT 13
  67   )
  68 EOF
  69   eval { $dbh->do(q[DROP GENERATOR "gen_artist_artistid"]) };
  70   $dbh->do('CREATE GENERATOR "gen_artist_artistid"');
  71   eval { $dbh->do('DROP TRIGGER "artist_bi"') };
  72   $dbh->do(<<EOF);
  73   CREATE TRIGGER "artist_bi" FOR "artist"
  74   ACTIVE BEFORE INSERT POSITION 0
  75   AS
  76   BEGIN
  77    IF (NEW."artistid" IS NULL) THEN
  78     NEW."artistid" = GEN_ID("gen_artist_artistid",1);
  79   END
  80 EOF
  81   eval { $dbh->do('DROP TABLE "sequence_test"') };
  82   $dbh->do(<<EOF);
  83   CREATE TABLE "sequence_test" (
  84     "pkid1" INT NOT NULL,
  85     "pkid2" INT NOT NULL,
  86     "nonpkid" INT,
  87     "name" VARCHAR(255)
  88   )
  89 EOF
  90   $dbh->do('ALTER TABLE "sequence_test" ADD CONSTRAINT "sequence_test_constraint" PRIMARY KEY ("pkid1", "pkid2")');
  91   eval { $dbh->do('DROP GENERATOR "pkid1_seq"') };
  92   eval { $dbh->do('DROP GENERATOR pkid2_seq') };
  93   eval { $dbh->do('DROP GENERATOR "nonpkid_seq"') };
  94   $dbh->do('CREATE GENERATOR "pkid1_seq"');
  95   $dbh->do('CREATE GENERATOR pkid2_seq');
  96   $dbh->do('SET GENERATOR pkid2_seq TO 9');
  97   $dbh->do('CREATE GENERATOR "nonpkid_seq"');
  98   $dbh->do('SET GENERATOR "nonpkid_seq" TO 19');
  99
 100   my $ars = $schema->resultset('Artist');
 101   is ( $ars->count, 0, 'No rows at first' );
 102
 103 # test primary key handling
 104   my $new = $ars->create({ name => 'foo' });
 105   ok($new->artistid, "Auto-PK worked");
 106
 107 # test auto increment using generators WITHOUT triggers
 108   for (1..5) {
 109       my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
 110       is($st->pkid1, $_, "Firebird Auto-PK without trigger: First primary key");
 111       is($st->pkid2, $_ + 9, "Firebird Auto-PK without trigger: Second primary key");
 112       is($st->nonpkid, $_ + 19, "Firebird Auto-PK without trigger: Non-primary key");
 113   }
 114   my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
 115   is($st->pkid1, 55, "Firebird Auto-PK without trigger: First primary key set manually");
 116
 117 # test transaction commit
 118   $schema->txn_do(sub {
 119     $ars->create({ name => 'in_transaction' });
 120   });
 121   ok (($ars->search({ name => 'in_transaction' })->first),
 122     'transaction committed');
 123   is $schema->storage->_dbh->{AutoCommit}, 1,
 124     '$dbh->{AutoCommit} is correct after transaction commit';
 125
 126   $ars->search({ name => 'in_transaction' })->delete;
 127
 128 # test savepoints
 129   throws_ok {
 130     $schema->txn_do(sub {
 131       my ($schema, $ars) = @_;
 132       eval {
 133         $schema->txn_do(sub {
 134           $ars->create({ name => 'in_savepoint' });
 135           die "rolling back savepoint";
 136         });
 137       };
 138       ok ((not $ars->search({ name => 'in_savepoint' })->first),
 139         'savepoint rolled back');
 140       $ars->create({ name => 'in_outer_txn' });
 141       die "rolling back outer txn";
 142     }, $schema, $ars);
 143   } qr/rolling back outer txn/,
 144     'correct exception for rollback';
 145
 146   is $schema->storage->_dbh->{AutoCommit}, 1,
 147     '$dbh->{AutoCommit} is correct after transaction rollback';
 148
 149   ok ((not $ars->search({ name => 'in_outer_txn' })->first),
 150     'outer txn rolled back');
 151
 152 # test explicit key spec
 153   $new = $ars->create ({ name => 'bar', artistid => 66 });
 154   is($new->artistid, 66, 'Explicit PK worked');
 155   $new->discard_changes;
 156   is($new->artistid, 66, 'Explicit PK assigned');
 157
 158 # row update
 159   lives_ok {
 160     $new->update({ name => 'baz' })
 161   } 'update survived';
 162   $new->discard_changes;
 163   is $new->name, 'baz', 'row updated';
 164
 165 # test populate
 166   lives_ok (sub {
 167     my @pop;
 168     for (1..2) {
 169       push @pop, { name => "Artist_$_" };
 170     }
 171     $ars->populate (\@pop);
 172   });
 173
 174 # test populate with explicit key
 175   lives_ok (sub {
 176     my @pop;
 177     for (1..2) {
 178       push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
 179     }
 180     $ars->populate (\@pop);
 181   });
 182
 183 # count what we did so far
 184   is ($ars->count, 6, 'Simple count works');
 185
 186 # test ResultSet UPDATE
 187   lives_and {
 188     $ars->search({ name => 'foo' })->update({ rank => 4 });
 189
 190     is eval { $ars->search({ name => 'foo' })->first->rank }, 4;
 191   } 'Can update a column';
 192
 193   my ($updated) = $schema->resultset('Artist')->search({name => 'foo'});
 194   is eval { $updated->rank }, 4, 'and the update made it to the database';
 195
 196 # test LIMIT support
 197   my $lim = $ars->search( {},
 198     {
 199       rows => 3,
 200       offset => 4,
 201       order_by => 'artistid'
 202     }
 203   );
 204   is( $lim->count, 2, 'ROWS+OFFSET count ok' );
 205   is( $lim->all, 2, 'Number of ->all objects matches count' );
 206
 207 # test iterator
 208   $lim->reset;
 209   is( eval { $lim->next->artistid }, 101, "iterator->next ok" );
 210   is( eval { $lim->next->artistid }, 102, "iterator->next ok" );
 211   is( $lim->next, undef, "next past end of resultset ok" );
 212
 213 # test bug in paging
 214   my $paged = $ars->search({ name => { -like => 'Artist%' } }, {
 215     page => 1,
 216     rows => 2,
 217     order_by => 'artistid',
 218   });
 219
 220   my $row;
 221   lives_ok {
 222     $row = $paged->next;
 223   } 'paged query survived';
 224
 225   is try { $row->artistid }, 5, 'correct row from paged query';
 226
 227   # DBD bug - if any unfinished statements are present during
 228   # DDL manipulation (test blobs below)- a segfault will occur
 229   $paged->reset;
 230
 231 # test nested cursors
 232   {
 233     my $rs1 = $ars->search({}, { order_by => { -asc  => 'artistid' }});
 234
 235     my $rs2 = $ars->search({ artistid => $rs1->next->artistid }, {
 236       order_by => { -desc => 'artistid' }
 237     });
 238
 239     is $rs2->next->artistid, 1, 'nested cursors';
 240   }
 241
 242 # test empty insert
 243   lives_and {
 244     my $row = $ars->create({});
 245     ok $row->artistid;
 246   } 'empty insert works';
 247
 248 # test inferring the generator from the trigger source and using it with
 249 # auto_nextval
 250   {
 251     local $ars->result_source->column_info('artistid')->{auto_nextval} = 1;
 252
 253     lives_and {
 254       my $row = $ars->create({ name => 'introspecting generator' });
 255       ok $row->artistid;
 256     } 'inferring generator from trigger source works';
 257   }
 258
 259   # at this point there should be no active statements
 260   # (finish() was called everywhere, either explicitly via
 261   # reset() or on DESTROY)
 262   for (keys %{$schema->storage->dbh->{CachedKids}}) {
 263     fail("Unreachable cached statement still active: $_")
 264       if $schema->storage->dbh->{CachedKids}{$_}->FETCH('Active');
 265   }
 266
 267 # test blobs (stolen from 73oracle.t)
 268   eval { $dbh->do('DROP TABLE "bindtype_test"') };
 269   $dbh->do(q[
 270   CREATE TABLE "bindtype_test"
 271   (
 272     "id"     INT PRIMARY KEY,
 273     "bytea"  INT,
 274     "blob"   BLOB,
 275     "clob"   BLOB SUB_TYPE TEXT,
 276     "a_memo" INT
 277   )
 278   ]);
 279
 280   my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
 281   $binstr{'large'} = $binstr{'small'} x 1024;
 282
 283   my $maxloblen = length $binstr{'large'};
 284   local $dbh->{'LongReadLen'} = $maxloblen;
 285
 286   my $rs = $schema->resultset('BindType');
 287   my $id = 0;
 288
 289   foreach my $type (qw( blob clob )) {
 290     foreach my $size (qw( small large )) {
 291       $id++;
 292
 293 # turn off horrendous binary DBIC_TRACE output
 294       local $schema->storage->{debug} = 0;
 295
 296       lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
 297       "inserted $size $type without dying";
 298
 299       my $got = $rs->find($id)->$type;
 300
 301       my $hexdump = sub { join '', map sprintf('%02X', ord), split //, shift };
 302
 303       ok($got eq $binstr{$size}, "verified inserted $size $type" )
 304         or do {
 305             diag "For " . (ref $schema->storage) . "\n";
 306             diag "Got blob:\n";
 307             diag $hexdump->(substr($got,0,50));
 308             diag "Expecting blob:\n";
 309             diag $hexdump->(substr($binstr{$size},0,50));
 310         };
 311     }
 312   }
 313 }}
 314
 315 done_testing;
 316
 317 # clean up our mess
 318
 319 sub cleanup {
 320   my $schema = shift;
 321
 322   my $dbh;
 323   eval {
 324     $schema->storage->disconnect; # to avoid object FOO is in use errors
 325     $dbh = $schema->storage->dbh;
 326   };
 327   return unless $dbh;
 328
 329   eval { $dbh->do('DROP TRIGGER "artist_bi"') };
 330   diag $@ if $@;
 331
 332   foreach my $generator (qw/
 333     "gen_artist_artistid"
 334     "pkid1_seq"
 335     pkid2_seq
 336     "nonpkid_seq"
 337   /) {
 338     eval { $dbh->do(qq{DROP GENERATOR $generator}) };
 339     diag $@ if $@;
 340   }
 341
 342   foreach my $table (qw/artist sequence_test/) {
 343     eval { $dbh->do(qq[DROP TABLE "$table"]) };
 344     diag $@ if $@;
 345   }
 346
 347   eval { $dbh->do(q{DROP TABLE "bindtype_test"}) };
 348   diag $@ if $@;
 349 }