+BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_pg';
+
use strict;
use warnings;
use Test::More;
use Test::Exception;
-use lib qw(t/lib);
+use Test::Warn;
+use Config;
use DBICTest;
-
+use SQL::Abstract 'is_literal_value';
+use DBIx::Class::_Util qw( is_exception set_subname );
my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
-plan skip_all => <<EOM unless $dsn && $user;
-Set \$ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test
-( NOTE: This test drops and creates tables called 'artist', 'casecheck',
- 'array_test' and 'sequence_test' as well as following sequences:
- 'pkid1_seq', 'pkid2_seq' and 'nonpkid_seq''. as well as following
- schemas: 'dbic_t_schema', 'dbic_t_schema_2', 'dbic_t_schema_3',
- 'dbic_t_schema_4', and 'dbic_t_schema_5'
-)
-EOM
-
### load any test classes that are defined further down in the file via BEGIN blocks
-
our @test_classes; #< array that will be pushed into by test classes defined in this file
DBICTest::Schema->load_classes( map {s/.+:://;$_} @test_classes ) if @test_classes;
-
### pre-connect tests (keep each test separate as to make sure rebless() runs)
-{
- my $s = DBICTest::Schema->connect($dsn, $user, $pass);
+ {
+ my $s = DBICTest::Schema->connect($dsn, $user, $pass);
+ # make sure sqlt_type overrides work (::Storage::DBI::Pg does this)
+ ok (!$s->storage->_dbh, 'definitely not connected');
+ is ($s->storage->sqlt_type, 'PostgreSQL', 'sqlt_type correct pre-connection');
+ ok (!$s->storage->_dbh, 'still not connected');
+ }
- ok (!$s->storage->_dbh, 'definitely not connected');
+# test LIMIT support
+{
+ my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ drop_test_schema($schema);
+ create_test_schema($schema);
+ for (1..6) {
+ $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
+ }
+ my $it = $schema->resultset('Artist')->search( {},
+ { rows => 3,
+ offset => 2,
+ order_by => 'artistid' }
+ );
+ is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 6 artists
+ is( $it->next->name, "Artist 3", "iterator->next ok" );
+ $it->next;
+ $it->next;
+ $it->next;
+ is( $it->next, undef, "next past end of resultset ok" );
+
+ # Limit with select-lock
+ lives_ok {
+ $schema->txn_do (sub {
+ isa_ok (
+ $schema->resultset('Artist')->find({artistid => 1}, {for => 'update', rows => 1}),
+ 'DBICTest::Schema::Artist',
+ );
+ });
+ } 'Limited FOR UPDATE select works';
+}
- # Check that datetime_parser returns correctly before we explicitly connect.
- SKIP: {
- eval { require DateTime::Format::Pg };
- skip "DateTime::Format::Pg required", 2 if $@;
+# check if we indeed do support stuff
+my $test_server_supports_insert_returning = do {
- my $store = ref $s->storage;
- is($store, 'DBIx::Class::Storage::DBI', 'Started with generic storage');
+ my $si = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info;
+ die "Unparseable Pg server version: $si->{dbms_version}\n"
+ unless $si->{normalized_dbms_version};
- my $parser = $s->storage->datetime_parser;
- is( $parser, 'DateTime::Format::Pg', 'datetime_parser is as expected');
+ $si->{normalized_dbms_version} < 8.002 ? 0 : 1;
+};
+is (
+ DBICTest::Schema->connect($dsn, $user, $pass)->storage->_use_insert_returning,
+ $test_server_supports_insert_returning,
+ 'insert returning capability guessed correctly'
+);
+
+my $schema;
+for my $use_insert_returning ($test_server_supports_insert_returning
+ ? (0,1)
+ : (0)
+) {
+
+ # doing it here instead of the actual class to keep the main thing under dfs
+ # and thus keep catching false positives (so far none, but one never knows)
+ mro::set_mro("DBICTest::Schema", "c3");
+
+ my $old_connection = DBICTest::Schema->can('connection');
+
+ no warnings qw/once redefine/;
+ local *DBICTest::Schema::connection = set_subname 'DBICTest::Schema::connection' => sub {
+ my $s = shift->$old_connection(@_);
+ $s->storage->_use_insert_returning ($use_insert_returning);
+ $s;
+ };
+
+### test capability override
+ {
+ my $s = DBICTest::Schema->connect($dsn, $user, $pass);
+
+ ok (!$s->storage->_dbh, 'definitely not connected');
+
+ ok (
+ ! ($s->storage->_use_insert_returning xor $use_insert_returning),
+ 'insert returning capability set correctly',
+ );
+ ok (!$s->storage->_dbh, 'still not connected (capability override works)');
}
- ok (!$s->storage->_dbh, 'still not connected');
-}
-{
- my $s = DBICTest::Schema->connect($dsn, $user, $pass);
- # make sure sqlt_type overrides work (::Storage::DBI::Pg does this)
- ok (!$s->storage->_dbh, 'definitely not connected');
- is ($s->storage->sqlt_type, 'PostgreSQL', 'sqlt_type correct pre-connection');
- ok (!$s->storage->_dbh, 'still not connected');
-}
-
### connect, create postgres-specific test schema
-my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+ $schema->storage->ensure_connected;
-drop_test_schema($schema);
-create_test_schema($schema);
+ drop_test_schema($schema);
+ create_test_schema($schema);
### begin main tests
-
# run a BIG bunch of tests for last-insert-id / Auto-PK / sequence
# discovery
-run_apk_tests($schema); #< older set of auto-pk tests
-run_extended_apk_tests($schema); #< new extended set of auto-pk tests
-
-
+ run_apk_tests($schema); #< older set of auto-pk tests
+ run_extended_apk_tests($schema); #< new extended set of auto-pk tests
+######## test the pg-specific syntax from https://rt.cpan.org/Ticket/Display.html?id=99503
+ lives_ok {
+ is(
+ $schema->resultset('Artist')->search({ artistid => { -in => \ '(select 4) union (select 5)' } })->count,
+ 2,
+ 'Two expected artists found on subselect union within IN',
+ );
+ };
### type_info tests
-my $test_type_info = {
- 'artistid' => {
- 'data_type' => 'integer',
- 'is_nullable' => 0,
- 'size' => 4,
- },
- 'name' => {
- 'data_type' => 'character varying',
- 'is_nullable' => 1,
- 'size' => 100,
- 'default_value' => undef,
- },
- 'rank' => {
- 'data_type' => 'integer',
- 'is_nullable' => 0,
- 'size' => 4,
- 'default_value' => 13,
-
- },
- 'charfield' => {
- 'data_type' => 'character',
- 'is_nullable' => 1,
- 'size' => 10,
- 'default_value' => undef,
- },
- 'arrayfield' => {
- 'data_type' => 'integer[]',
- 'is_nullable' => 1,
- 'size' => undef,
- 'default_value' => undef,
- },
-};
+ my $test_type_info = {
+ 'artistid' => {
+ 'data_type' => 'integer',
+ 'is_nullable' => 0,
+ 'size' => 4,
+ },
+ 'name' => {
+ 'data_type' => 'character varying',
+ 'is_nullable' => 1,
+ 'size' => 100,
+ 'default_value' => undef,
+ },
+ 'rank' => {
+ 'data_type' => 'integer',
+ 'is_nullable' => 0,
+ 'size' => 4,
+ 'default_value' => 13,
-my $type_info = $schema->storage->columns_info_for('dbic_t_schema.artist');
-my $artistid_defval = delete $type_info->{artistid}->{default_value};
-like($artistid_defval,
- qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/,
- 'columns_info_for - sequence matches Pg get_autoinc_seq expectations');
-is_deeply($type_info, $test_type_info,
- 'columns_info_for - column data types');
+ },
+ 'charfield' => {
+ 'data_type' => 'character',
+ 'is_nullable' => 1,
+ 'size' => 10,
+ 'default_value' => undef,
+ },
+ 'arrayfield' => {
+ 'data_type' => 'integer[]',
+ 'is_nullable' => 1,
+ 'size' => undef,
+ 'default_value' => undef,
+ },
+ };
+
+ my $type_info = $schema->storage->columns_info_for('dbic_t_schema.artist');
+ my $artistid_defval = delete $type_info->{artistid}->{default_value};
+
+ # The curor info is too radically different from what is in the column_info
+ # call - just punt it (DBD::SQLite tests the codepath plenty enough)
+ unless (DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE) {
+ like(
+ $artistid_defval,
+ qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/,
+ 'columns_info_for - sequence matches Pg get_autoinc_seq expectations'
+ );
+
+ is_deeply($type_info, $test_type_info,
+ 'columns_info_for - column data types');
+ }
+####### Array tests
+ BEGIN {
+ package DBICTest::Schema::ArrayTest;
+ push @main::test_classes, __PACKAGE__;
+ use strict;
+ use warnings;
+ use base 'DBICTest::BaseResult';
-####### Array tests
+ __PACKAGE__->table('dbic_t_schema.array_test');
+ __PACKAGE__->add_columns(qw/id arrayfield/);
+ __PACKAGE__->column_info_from_storage(1);
+ __PACKAGE__->set_primary_key('id');
-BEGIN {
- package DBICTest::Schema::ArrayTest;
- push @main::test_classes, __PACKAGE__;
+ }
+ SKIP: {
+ skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002;
- use strict;
- use warnings;
- use base 'DBIx::Class';
+ my $arr_rs = $schema->resultset('ArrayTest');
- __PACKAGE__->load_components(qw/Core/);
- __PACKAGE__->table('dbic_t_schema.array_test');
- __PACKAGE__->add_columns(qw/id arrayfield/);
- __PACKAGE__->column_info_from_storage(1);
- __PACKAGE__->set_primary_key('id');
+ lives_ok {
+ $arr_rs->create({
+ arrayfield => [1, 2],
+ });
+ } 'inserting arrayref as pg array data';
-}
-SKIP: {
- skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002;
+ lives_ok {
+ $arr_rs->update({
+ arrayfield => [3, 4],
+ });
+ } 'updating arrayref as pg array data';
- lives_ok {
- $schema->resultset('ArrayTest')->create({
- arrayfield => [1, 2],
+ $arr_rs->create({
+ arrayfield => [5, 6],
});
- } 'inserting arrayref as pg array data';
- lives_ok {
- $schema->resultset('ArrayTest')->update({
- arrayfield => [3, 4],
- });
- } 'updating arrayref as pg array data';
+ lives_ok {
+ $schema->populate('ArrayTest', [
+ [ qw/arrayfield/ ],
+ [ [0,0] ],
+ ]);
+ } 'inserting arrayref using void ctx populate';
- $schema->resultset('ArrayTest')->create({
- arrayfield => [5, 6],
- });
+ # Search using arrays
+ lives_ok {
+ is_deeply (
+ $arr_rs->search({ arrayfield => { -value => [3,4] } })->first->arrayfield,
+ [3,4],
+ 'Array value matches'
+ );
+ } 'searching by arrayref';
- my $count;
- lives_ok {
- $count = $schema->resultset('ArrayTest')->search({
- arrayfield => \[ '= ?' => [arrayfield => [3, 4]] ], #Todo anything less ugly than this?
- })->count;
- } 'comparing arrayref to pg array data does not blow up';
- is($count, 1, 'comparing arrayref to pg array data gives correct result');
-}
+ lives_ok {
+ is_deeply (
+ $arr_rs->search({ arrayfield => { '=' => { -value => [3,4] }} })->first->arrayfield,
+ [3,4],
+ 'Array value matches explicit equal'
+ );
+ } 'searching by arrayref (explicit equal sign)';
+ lives_ok {
+ is_deeply (
+ $arr_rs->search({ arrayfield => { '>' => { -value => [3,1] }} })->first->arrayfield,
+ [3,4],
+ 'Array value matches greater than'
+ );
+ } 'searching by arrayref (greater than)';
+ lives_ok {
+ is (
+ $arr_rs->search({ arrayfield => { '>' => { -value => [3,7] }} })->count,
+ 1,
+ 'Greater than search found [5,6]',
+ );
+ } 'searching by arrayref (greater than)';
+
+ # Find using arrays
+ lives_ok {
+ is_deeply (
+ $arr_rs->find({ arrayfield => { -value => [3,4] } })->arrayfield,
+ [3,4],
+ 'Array value matches implicit equal'
+ );
+ } 'find by arrayref';
-########## Case check
+ lives_ok {
+ is_deeply (
+ $arr_rs->find({ arrayfield => { '=' => { -value => [3,4] }} })->arrayfield,
+ [3,4],
+ 'Array value matches explicit equal'
+ );
+ } 'find by arrayref (equal)';
+
+ # test inferred condition for creation
+ for my $cond (
+ { -value => [3,4] },
+ \[ '= ?' => [3, 4] ],
+ ) {
+ local $TODO = 'No introspection of complex literal conditions :('
+ if is_literal_value $cond;
-BEGIN {
- package DBICTest::Schema::Casecheck;
- push @main::test_classes, __PACKAGE__;
- use strict;
- use warnings;
- use base 'DBIx::Class';
+ my $arr_rs_cond = $arr_rs->search({ arrayfield => $cond });
- __PACKAGE__->load_components(qw/Core/);
- __PACKAGE__->table('dbic_t_schema.casecheck');
- __PACKAGE__->add_columns(qw/id name NAME uc_name/);
- __PACKAGE__->column_info_from_storage(1);
- __PACKAGE__->set_primary_key('id');
-}
+ my $row = $arr_rs_cond->create({});
+ is_deeply ($row->arrayfield, [3,4], 'Array value taken from $rs condition');
+ $row->discard_changes;
+ is_deeply ($row->arrayfield, [3,4], 'Array value made it to storage');
+ }
+
+ my $arr = [ 1..10 ];
+ # exercise the creation-logic even more (akin to t/100populate.t)
+ for my $insert_value (
+ $arr,
+ { -value => $arr },
+ \[ '?', $arr ],
+ ) {
+ $arr_rs->delete;
+
+ my @objs = (
+ $arr_rs->create({ arrayfield => $insert_value }),
+ $arr_rs->populate([ { arrayfield => $insert_value } ]),
+ $arr_rs->populate([ ['arrayfield'], [ $insert_value ] ]),
+ );
+
+ my $loose_obj = $arr_rs->new({ arrayfield => $insert_value });
-my $name_info = $schema->source('Casecheck')->column_info( 'name' );
-is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
+ unless (is_literal_value $insert_value) {
+ is_deeply( $_->arrayfield, $arr, 'array value preserved during set_columns' )
+ for ($loose_obj, @objs)
+ }
-my $NAME_info = $schema->source('Casecheck')->column_info( 'NAME' );
-is( $NAME_info->{size}, 2, "Case sensitive matching info for 'NAME'" );
+ push @objs, $loose_obj->insert;
+
+ $_->discard_changes for @objs;
+ is_deeply( $_->arrayfield, $arr, 'array value correct after discard_changes' )
+ for (@objs);
+
+ # insert couple more in void ctx
+ $arr_rs->populate([ { arrayfield => $insert_value } ]);
+ $arr_rs->populate([ ['arrayfield'], [ $insert_value ] ]);
+
+ # should have a total of 6 now, all pristine
+ my @retrieved_objs = $arr_rs->search({
+ arrayfield => ref $insert_value eq 'ARRAY'
+ ? { -value => $insert_value }
+ : { '=' => $insert_value }
+ })->all;
+ is scalar @retrieved_objs, 6, 'Correct count of inserted rows';
+ is_deeply( $_->arrayfield, $arr, 'array value correct after storage retrieval' )
+ for (@retrieved_objs);
+ }
+ }
-my $uc_name_info = $schema->source('Casecheck')->column_info( 'uc_name' );
-is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );
+########## Case check
+ BEGIN {
+ package DBICTest::Schema::Casecheck;
+ push @main::test_classes, __PACKAGE__;
+ use strict;
+ use warnings;
+ use base 'DBIx::Class::Core';
+ __PACKAGE__->table('dbic_t_schema.casecheck');
+ __PACKAGE__->add_columns(qw/id name NAME uc_name/);
+ __PACKAGE__->column_info_from_storage(1);
+ __PACKAGE__->set_primary_key('id');
+ }
-## Test SELECT ... FOR UPDATE
+ my $name_info = $schema->source('Casecheck')->column_info( 'name' );
+ is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
-SKIP: {
- if(eval "require Sys::SigAction" && !$@) {
- Sys::SigAction->import( 'set_sig_handler' );
- }
- else {
- skip "Sys::SigAction is not available", 6;
- }
+ my $NAME_info = $schema->source('Casecheck')->column_info( 'NAME' );
+ is( $NAME_info->{size}, 2, "Case sensitive matching info for 'NAME'" );
- my ($timed_out, $artist2);
+ my $uc_name_info = $schema->source('Casecheck')->column_info( 'uc_name' );
+ is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );
- for my $t (
- {
- # Make sure that an error was raised, and that the update failed
- update_lock => 1,
- test_sub => sub {
- ok($timed_out, "update from second schema times out");
- ok($artist2->is_column_changed('name'), "'name' column is still dirty from second schema");
+
+## Test ResultSet->update
+my $artist = $schema->resultset('Artist')->first;
+my $cds = $artist->cds_unordered->search({
+ year => { '!=' => 2010 }
+}, { prefetch => 'liner_notes' });
+lives_ok { $cds->update({ year => '2010' }) } 'Update on prefetched rs';
+
+## Test SELECT ... FOR UPDATE
+ SKIP: {
+ skip "Your system does not support unsafe signals (d_sigaction) - unable to run deadlock test", 1
+ unless eval { $Config{d_sigaction} and require POSIX };
+
+ my ($timed_out, $artist2);
+
+ for my $t (
+ {
+ # Make sure that an error was raised, and that the update failed
+ update_lock => 1,
+ test_sub => sub {
+ ok($timed_out, "update from second schema times out");
+ ok($artist2->is_column_changed('name'), "'name' column is still dirty from second schema");
+ },
},
- },
- {
- # Make sure that an error was NOT raised, and that the update succeeded
- update_lock => 0,
- test_sub => sub {
- ok(! $timed_out, "update from second schema DOES NOT timeout");
- ok(! $artist2->is_column_changed('name'), "'name' column is NOT dirty from second schema");
+ {
+ # Make sure that an error was NOT raised, and that the update succeeded
+ update_lock => 0,
+ test_sub => sub {
+ ok(! $timed_out, "update from second schema DOES NOT timeout");
+ ok(! $artist2->is_column_changed('name'), "'name' column is NOT dirty from second schema");
+ },
},
- },
- ) {
- # create a new schema
- my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
- $schema2->source("Artist")->name("dbic_t_schema.artist");
-
- $schema->txn_do( sub {
- my $artist = $schema->resultset('Artist')->search(
- {
- artistid => 1
- },
- $t->{update_lock} ? { for => 'update' } : {}
- )->first;
- is($artist->artistid, 1, "select returns artistid = 1");
-
- $timed_out = 0;
- eval {
- my $h = set_sig_handler( 'ALRM', sub { die "DBICTestTimeout" } );
- alarm(2);
- $artist2 = $schema2->resultset('Artist')->find(1);
- $artist2->name('fooey');
- $artist2->update;
- alarm(0);
- };
- $timed_out = $@ =~ /DBICTestTimeout/;
- });
+ ) {
+ # create a new schema
+ my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
+ $schema2->source("Artist")->name("dbic_t_schema.artist");
+
+ $schema->txn_do( sub {
+ my $rs = $schema->resultset('Artist')->search(
+ {
+ artistid => 1
+ },
+ $t->{update_lock} ? { for => 'update' } : {}
+ );
+ ok ($rs->count, 'Count works');
+
+ my $artist = $rs->next;
+ is($artist->artistid, 1, "select returns artistid = 1");
+
+ $timed_out = 0;
+
+ eval {
+ # can not use %SIG assignment directly - we need sigaction below
+ # localization to a block still works however
+ local $SIG{ALRM};
+
+ POSIX::sigaction( POSIX::SIGALRM() => POSIX::SigAction->new(
+ sub { die "DBICTestTimeout" },
+ ));
+
+ $artist2 = $schema2->resultset('Artist')->find(1);
+ $artist2->name('fooey');
+
+ # FIXME - this needs to go away in lieu of a non-retrying runner
+ # ( i.e. after solving RT#47005 )
+ local *DBIx::Class::Storage::DBI::_ping = sub { 1 }, DBIx::Class::_ENV_::OLD_MRO && Class::C3->reinitialize()
+ if DBIx::Class::_Util::modver_gt_or_eq( 'DBD::Pg' => '3.5.0' );
+
+ alarm(1);
+ $artist2->update;
+ };
+
+ alarm(0);
+
+ if (is_exception($@)) {
+ $timed_out = $@ =~ /DBICTestTimeout/
+ or die $@;
+ }
+ });
- $t->{test_sub}->();
- }
-}
+ $t->{test_sub}->();
+ }
+ }
######## other older Auto-pk tests
-$schema->source("SequenceTest")->name("dbic_t_schema.sequence_test");
-for (1..5) {
- my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
- is($st->pkid1, $_, "Oracle Auto-PK without trigger: First primary key");
- is($st->pkid2, $_ + 9, "Oracle Auto-PK without trigger: Second primary key");
- is($st->nonpkid, $_ + 19, "Oracle Auto-PK without trigger: Non-primary key");
+ $schema->source("SequenceTest")->name("dbic_t_schema.sequence_test");
+ for (1..5) {
+ my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
+ is($st->pkid1, $_, "Auto-PK for sequence without default: First primary key");
+ is($st->pkid2, $_ + 9, "Auto-PK for sequence without default: Second primary key");
+ is($st->nonpkid, $_ + 19, "Auto-PK for sequence without default: Non-primary key");
+ }
+ my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
+ is($st->pkid1, 55, "Auto-PK for sequence without default: First primary key set manually");
+
+
+######## test non-serial auto-pk
+
+ if ($schema->storage->_use_insert_returning) {
+ $schema->source('TimestampPrimaryKey')->name('dbic_t_schema.timestamp_primary_key_test');
+ my $row = $schema->resultset('TimestampPrimaryKey')->create({});
+ ok $row->id;
+ }
+
+######## test with_deferred_fk_checks
+
+ $schema->source('CD')->name('dbic_t_schema.cd');
+ $schema->source('Track')->name('dbic_t_schema.track');
+ lives_ok {
+ $schema->storage->with_deferred_fk_checks(sub {
+ $schema->resultset('Track')->create({
+ trackid => 999, cd => 999, position => 1, title => 'deferred FK track'
+ });
+ $schema->resultset('CD')->create({
+ artist => 1, cdid => 999, year => '2003', title => 'deferred FK cd'
+ });
+ });
+ } 'with_deferred_fk_checks code survived';
+
+ is eval { $schema->resultset('Track')->find(999)->title }, 'deferred FK track',
+ 'code in with_deferred_fk_checks worked';
+
+ throws_ok {
+ $schema->resultset('Track')->create({
+ trackid => 1, cd => 9999, position => 1, title => 'Track1'
+ });
+ } qr/violates foreign key constraint/i, 'with_deferred_fk_checks is off outside of TXN';
+
+ # rerun the same under with_deferred_fk_checks
+ # it is expected to fail, hence the eval
+ # but it also should not warn
+ warnings_like {
+ eval {
+ $schema->storage->with_deferred_fk_checks(sub {
+ $schema->resultset('Track')->create({
+ trackid => 1, cd => 9999, position => 1, title => 'Track1'
+ });
+ } )
+ };
+
+ like $@, qr/violates foreign key constraint/i,
+ "Still expected exception on deferred failure at commit time";
+
+ } [], 'No warnings on deferred rollback';
}
-my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
-is($st->pkid1, 55, "Oracle Auto-PK without trigger: First primary key set manually");
done_testing;
-exit;
-
END {
return unless $schema;
drop_test_schema($schema);
- eapk_drop_all( $schema)
+ eapk_drop_all($schema);
+ undef $schema;
};
$dbh->do("CREATE SCHEMA dbic_t_schema");
$dbh->do("CREATE TABLE dbic_t_schema.artist $std_artist_table");
+
+ $dbh->do(<<EOS);
+CREATE TABLE dbic_t_schema.timestamp_primary_key_test (
+ id timestamp default current_timestamp
+)
+EOS
+ $dbh->do(<<EOS);
+CREATE TABLE dbic_t_schema.cd (
+ cdid int PRIMARY KEY,
+ artist int,
+ title varchar(255),
+ year varchar(4),
+ genreid int,
+ single_track int
+)
+EOS
+ $dbh->do(<<EOS);
+CREATE TABLE dbic_t_schema.track (
+ trackid int,
+ cd int REFERENCES dbic_t_schema.cd(cdid) DEFERRABLE,
+ position int,
+ title varchar(255),
+ last_updated_on date,
+ last_updated_at date
+)
+EOS
+
$dbh->do(<<EOS);
CREATE TABLE dbic_t_schema.sequence_test (
pkid1 integer
for my $stat (
'DROP SCHEMA dbic_t_schema_5 CASCADE',
- 'DROP SEQUENCE public.artist_artistid_seq',
+ 'DROP SEQUENCE public.artist_artistid_seq CASCADE',
'DROP SCHEMA dbic_t_schema_4 CASCADE',
'DROP SCHEMA dbic_t_schema CASCADE',
- 'DROP SEQUENCE pkid1_seq',
- 'DROP SEQUENCE pkid2_seq',
- 'DROP SEQUENCE nonpkid_seq',
+ 'DROP SEQUENCE pkid1_seq CASCADE',
+ 'DROP SEQUENCE pkid2_seq CASCADE',
+ 'DROP SEQUENCE nonpkid_seq CASCADE',
'DROP SCHEMA dbic_t_schema_2 CASCADE',
'DROP SCHEMA dbic_t_schema_3 CASCADE',
) {
use strict;
use warnings;
- use base 'DBIx::Class';
+ use base 'DBIx::Class::Core';
- __PACKAGE__->load_components(qw/Core/);
__PACKAGE__->table('apk');
@eapk_id_columns = qw( id1 id2 id3 id4 );
my @eapk_schemas;
BEGIN{ @eapk_schemas = map "dbic_apk_$_", 0..5 }
+my %seqs; #< hash of schema.table.col => currval of its (DBIC) primary key sequence
sub run_extended_apk_tests {
my $schema = shift;
my $search_path_save = eapk_get_search_path($schema);
eapk_drop_all($schema);
+ %seqs = ();
# make the test schemas and sequences
$schema->storage->dbh_do(sub {
for @eapk_schemas;
$dbh->do("CREATE SEQUENCE $eapk_schemas[5].fooseq");
+ $dbh->do("SELECT setval('$eapk_schemas[5].fooseq',400)");
+ $seqs{"$eapk_schemas[1].apk.id2"} = 400;
+
$dbh->do("CREATE SEQUENCE $eapk_schemas[4].fooseq");
+ $dbh->do("SELECT setval('$eapk_schemas[4].fooseq',300)");
+ $seqs{"$eapk_schemas[3].apk.id2"} = 300;
+
$dbh->do("CREATE SEQUENCE $eapk_schemas[3].fooseq");
+ $dbh->do("SELECT setval('$eapk_schemas[3].fooseq',200)");
+ $seqs{"$eapk_schemas[4].apk.id2"} = 200;
$dbh->do("SET search_path = ".join ',', reverse @eapk_schemas );
});
# do a DBIC create on the apk table in the given schema number (which is an
# index of @eapk_schemas)
-my %seqs; #< sanity-check hash of schema.table.col => currval of its sequence
-
sub eapk_poke {
my ($s, $schema_num) = @_;
lives_ok {
my $new;
for my $inc (1,2,3) {
- $new = $schema->resultset('ExtAPK')->create({});
+ $new = $schema->resultset('ExtAPK')->create({ id1 => 1});
my $proper_seqval = ++$seqs{"$schema_name_actual.apk.id2"};
is( $new->id2, $proper_seqval, "$schema_name_actual.apk.id2 correct inc $inc" )
or eapk_seq_diag($s,$schema_name);
$new->discard_changes;
- for my $id (grep $_ ne 'id2', @eapk_id_columns) {
+ is( $new->id1, 1 );
+ for my $id ('id3','id4') {
my $proper_seqval = ++$seqs{"$schema_name_actual.apk.$id"};
is( $new->$id, $proper_seqval, "$schema_name_actual.apk.$id correct inc $inc" )
or eapk_seq_diag($s,$schema_name);
local $_[1]->{Warn} = 0;
my $id_def = $a{nextval}
- ? "integer primary key not null default nextval('$a{nextval}'::regclass)"
- : 'serial primary key';
+ ? "integer not null default nextval('$a{nextval}'::regclass)"
+ : 'serial';
$dbh->do(<<EOS);
CREATE TABLE $table_name (
id1 serial
, id2 $id_def
- , id3 serial
+ , id3 serial primary key
, id4 serial
)
EOS
projects / dbsrgits/DBIx-Class.git / blobdiff