X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F750firebird.t;h=eb4122a5d9ca9ed1247c565ce05e15ec97301532;hb=HEAD;hp=981da1eb586e2242bfbb4113366eb59d184adc43;hpb=9633951d0f542434fc4f50b23248094d2ac35836;p=dbsrgits%2FDBIx-Class.git diff --git a/t/750firebird.t b/t/750firebird.t index 981da1e..eb4122a 100644 --- a/t/750firebird.t +++ b/t/750firebird.t @@ -1,42 +1,56 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + use strict; use warnings; use Test::More; use Test::Exception; -use lib qw(t/lib); +use DBIx::Class::Optional::Dependencies (); +use DBIx::Class::_Util 'scope_guard'; +use List::Util 'shuffle'; + use DBICTest; -use Scope::Guard (); -# tests stolen from 749sybase_asa.t +my $env2optdep = { + DBICTEST_FIREBIRD => 'test_rdbms_firebird', + DBICTEST_FIREBIRD_INTERBASE => 'test_rdbms_firebird_interbase', + DBICTEST_FIREBIRD_ODBC => 'test_rdbms_firebird_odbc', +}; -my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_FIREBIRD_${_}" } qw/DSN USER PASS/}; -my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_FIREBIRD_ODBC_${_}" } qw/DSN USER PASS/}; +plan skip_all => join (' ', + 'Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_INTERBASE_DSN}', + 'and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN},', + '_USER and _PASS to run these tests.', -plan skip_all => <<'EOF' unless $dsn || $dsn2; -Set $ENV{DBICTEST_FIREBIRD_DSN} and/or $ENV{DBICTEST_FIREBIRD_ODBC_DSN}, -_USER and _PASS to run these tests -EOF + 'WARNING: this test creates and drops the tables "artist", "bindtype_test" and', + '"sequence_test"; the generators "gen_artist_artistid", "pkid1_seq", "pkid2_seq"', + 'and "nonpkid_seq" and the trigger "artist_bi".', +) unless grep { $ENV{"${_}_DSN"} } keys %$env2optdep; -my @info = ( - [ $dsn, $user, $pass ], - [ $dsn2, $user2, $pass2 ], -); +# Example DSNs: +# dbi:Firebird:db=/var/lib/firebird/2.5/data/hlaghdb.fdb +# dbi:InterBase:db=/var/lib/firebird/2.5/data/hlaghdb.fdb + +# Example ODBC DSN: +# dbi:ODBC:Driver=Firebird;Dbname=/var/lib/firebird/2.5/data/hlaghdb.fdb my $schema; -foreach my $conn_idx (0..1) { - my ($dsn, $user, $pass) = @{ $info[$conn_idx] || [] }; +for my $prefix (shuffle keys %$env2optdep) { SKIP: { + + DBIx::Class::Optional::Dependencies->skip_without( $env2optdep->{$prefix} ); - next unless $dsn; + my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/; + note "Testing with ${prefix}_DSN"; $schema = DBICTest::Schema->connect($dsn, $user, $pass, { - auto_savepoint => 1, - quote_char => q["], - name_sep => q[.], + auto_savepoint => 1, + quote_names => 1, + ($dsn !~ /ODBC/ ? (on_connect_call => 'use_softcommit') : ()), }); my $dbh = $schema->storage->dbh; - my $sg = Scope::Guard->new(\&cleanup); + my $sg = scope_guard { cleanup($schema) }; eval { $dbh->do(q[DROP TABLE "artist"]) }; $dbh->do(<do('DROP TABLE "sequence_test"') }; + $dbh->do(<do('ALTER TABLE "sequence_test" ADD CONSTRAINT "sequence_test_constraint" PRIMARY KEY ("pkid1", "pkid2")'); + eval { $dbh->do('DROP GENERATOR "pkid1_seq"') }; + eval { $dbh->do('DROP GENERATOR pkid2_seq') }; + eval { $dbh->do('DROP GENERATOR "nonpkid_seq"') }; + $dbh->do('CREATE GENERATOR "pkid1_seq"'); + $dbh->do('CREATE GENERATOR pkid2_seq'); + $dbh->do('SET GENERATOR pkid2_seq TO 9'); + $dbh->do('CREATE GENERATOR "nonpkid_seq"'); + $dbh->do('SET GENERATOR "nonpkid_seq" TO 19'); my $ars = $schema->resultset('Artist'); is ( $ars->count, 0, 'No rows at first' ); @@ -67,23 +99,50 @@ EOF my $new = $ars->create({ name => 'foo' }); ok($new->artistid, "Auto-PK worked"); +# test auto increment using generators WITHOUT triggers + for (1..5) { + my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' }); + is($st->pkid1, $_, "Firebird Auto-PK without trigger: First primary key"); + is($st->pkid2, $_ + 9, "Firebird Auto-PK without trigger: Second primary key"); + is($st->nonpkid, $_ + 19, "Firebird Auto-PK without trigger: Non-primary key"); + } + my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 }); + is($st->pkid1, 55, "Firebird Auto-PK without trigger: First primary key set manually"); + +# test transaction commit + $schema->txn_do(sub { + $ars->create({ name => 'in_transaction' }); + }); + ok (($ars->search({ name => 'in_transaction' })->first), + 'transaction committed'); + is $schema->storage->_dbh->{AutoCommit}, 1, + '$dbh->{AutoCommit} is correct after transaction commit'; + + $ars->search({ name => 'in_transaction' })->delete; + # test savepoints -# eval { -# $schema->txn_do(sub { -# eval { -# $schema->txn_do(sub { -# $ars->create({ name => 'in_savepoint' }); -# die "rolling back savepoint"; -# }); -# }; -# ok ((not $ars->search({ name => 'in_savepoint' })->first), -# 'savepoint rolled back'); -# $ars->create({ name => 'in_outer_txn' }); -# die "rolling back outer txn"; -# }); -# }; -# ok ((not $ars->search({ name => 'in_outer_txn' })->first), -# 'outer txn rolled back'); + throws_ok { + $schema->txn_do(sub { + my ($schema, $ars) = @_; + eval { + $schema->txn_do(sub { + $ars->create({ name => 'in_savepoint' }); + die "rolling back savepoint"; + }); + }; + ok ((not $ars->search({ name => 'in_savepoint' })->first), + 'savepoint rolled back'); + $ars->create({ name => 'in_outer_txn' }); + die "rolling back outer txn"; + }, $schema, $ars); + } qr/rolling back outer txn/, + 'correct exception for rollback'; + + is $schema->storage->_dbh->{AutoCommit}, 1, + '$dbh->{AutoCommit} is correct after transaction rollback'; + + ok ((not $ars->search({ name => 'in_outer_txn' })->first), + 'outer txn rolled back'); # test explicit key spec $new = $ars->create ({ name => 'bar', artistid => 66 }); @@ -91,6 +150,7 @@ EOF $new->discard_changes; is($new->artistid, 66, 'Explicit PK assigned'); +# row update lives_ok { $new->update({ name => 'baz' }) } 'update survived'; @@ -112,23 +172,21 @@ EOF for (1..2) { push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ }; } - # XXX why does insert_bulk not work here? - my @foo = $ars->populate (\@pop); + $ars->populate (\@pop); }); # count what we did so far is ($ars->count, 6, 'Simple count works'); -# test UPDATE - lives_ok { - $schema->resultset('Artist') - ->search({name => 'foo'}) - ->update({rank => 4 }); +# test ResultSet UPDATE + lives_and { + $ars->search({ name => 'foo' })->update({ rank => 4 }); + + is eval { $ars->search({ name => 'foo' })->first->rank }, 4; } 'Can update a column'; my ($updated) = $schema->resultset('Artist')->search({name => 'foo'}); - is $updated->rank, 4, 'and the update made it to the database'; - + is eval { $updated->rank }, 4, 'and the update made it to the database'; # test LIMIT support my $lim = $ars->search( {}, @@ -143,61 +201,123 @@ EOF # test iterator $lim->reset; - is( $lim->next->artistid, 101, "iterator->next ok" ); - is( $lim->next->artistid, 102, "iterator->next ok" ); + is( eval { $lim->next->artistid }, 101, "iterator->next ok" ); + is( eval { $lim->next->artistid }, 102, "iterator->next ok" ); is( $lim->next, undef, "next past end of resultset ok" ); +# test bug in paging + my $paged = $ars->search({ name => { -like => 'Artist%' } }, { + page => 1, + rows => 2, + order_by => 'artistid', + }); + + my $row; + lives_ok { + $row = $paged->next; + } 'paged query survived'; + + is( + eval { $row->artistid }, + 5, + 'correct row from paged query' + ); + + # DBD bug - if any unfinished statements are present during + # DDL manipulation (test blobs below)- a segfault will occur + $paged->reset; + +# test nested cursors + { + my $rs1 = $ars->search({}, { order_by => { -asc => 'artistid' }}); + + my $rs2 = $ars->search({ artistid => $rs1->next->artistid }, { + order_by => { -desc => 'artistid' } + }); + + is $rs2->next->artistid, 1, 'nested cursors'; + } + # test empty insert + lives_and { + my $row = $ars->create({}); + ok $row->artistid; + } 'empty insert works'; + +# test inferring the generator from the trigger source and using it with +# auto_nextval { - local $ars->result_source->column_info('artistid')->{is_auto_increment} = 0; + local $ars->result_source->column_info('artistid')->{auto_nextval} = 1; + + lives_and { + my $row = $ars->create({ name => 'introspecting generator' }); + ok $row->artistid; + } 'inferring generator from trigger source works'; + } - lives_ok { $ars->create({}) } - 'empty insert works'; + # at this point there should be no active statements + # (finish() was called everywhere, either explicitly via + # reset() or on DESTROY) + for (keys %{$schema->storage->dbh->{CachedKids}}) { + fail("Unreachable cached statement still active: $_") + if $schema->storage->dbh->{CachedKids}{$_}->FETCH('Active'); } # test blobs (stolen from 73oracle.t) - SKIP: { - eval { $dbh->do('DROP TABLE "bindtype_test2"') }; - $dbh->do(q[ - CREATE TABLE "bindtype_test2" - ( - "id" INT PRIMARY KEY, - "bytea" INT, - "a_blob" BLOB, - "a_clob" BLOB SUB_TYPE TEXT - ) - ]); - - my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); - $binstr{'large'} = $binstr{'small'} x 1024; - - my $maxloblen = length $binstr{'large'}; - local $dbh->{'LongReadLen'} = $maxloblen; - - my $rs = $schema->resultset('BindType2'); - my $id = 0; - - foreach my $type (qw( a_blob a_clob )) { - foreach my $size (qw( small large )) { - $id++; + eval { $dbh->do('DROP TABLE "bindtype_test"') }; + $dbh->do(q[ + CREATE TABLE "bindtype_test" + ( + "id" INT PRIMARY KEY, + "bytea" INT, + "blob" BLOB, + "clob" BLOB SUB_TYPE TEXT, + "a_memo" INT + ) + ]); + + my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); + $binstr{'large'} = $binstr{'small'} x 1024; + + my $maxloblen = length $binstr{'large'}; + local $dbh->{'LongReadLen'} = $maxloblen; + + my $rs = $schema->resultset('BindType'); + my $id = 0; + + foreach my $type (qw( blob clob )) { + foreach my $size (qw( small large )) { + $id++; # turn off horrendous binary DBIC_TRACE output - local $schema->storage->{debug} = 0; + local $schema->storage->{debug} = 0; - lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) } - "inserted $size $type without dying"; + lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) } + "inserted $size $type without dying"; - ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" ); - } + my $got = $rs->find($id)->$type; + + my $hexdump = sub { join '', map sprintf('%02X', ord), split //, shift }; + + ok($got eq $binstr{$size}, "verified inserted $size $type" ) + or do { + diag "For " . (ref $schema->storage) . "\n"; + diag "Got blob:\n"; + diag $hexdump->(substr($got,0,50)); + diag "Expecting blob:\n"; + diag $hexdump->(substr($binstr{$size},0,50)); + }; } } -} +}} done_testing; # clean up our mess sub cleanup { + my $schema = shift; + my $dbh; eval { $schema->storage->disconnect; # to avoid object FOO is in use errors @@ -208,11 +328,21 @@ sub cleanup { eval { $dbh->do('DROP TRIGGER "artist_bi"') }; diag $@ if $@; - eval { $dbh->do('DROP GENERATOR "gen_artist_artistid"') }; - diag $@ if $@; + foreach my $generator (qw/ + "gen_artist_artistid" + "pkid1_seq" + pkid2_seq + "nonpkid_seq" + /) { + eval { $dbh->do(qq{DROP GENERATOR $generator}) }; + diag $@ if $@; + } - foreach my $table (qw/artist bindtype_test/) { + foreach my $table (qw/artist sequence_test/) { eval { $dbh->do(qq[DROP TABLE "$table"]) }; - #diag $@ if $@; + diag $@ if $@; } + + eval { $dbh->do(q{DROP TABLE "bindtype_test"}) }; + diag $@ if $@; }