(travis) Run a couple tests in single-threaded mode
[dbsrgits/DBIx-Class.git] / t / 72pg.t
CommitLineData
cb551b07 1use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_pg';
2
70350518 3use strict;
4617b792 4use warnings;
70350518 5
6use Test::More;
9ba627e3 7use Test::Exception;
bbdda281 8use Sub::Name;
bb961936 9use Config;
199fbc45 10use DBIx::Class::Optional::Dependencies ();
70350518 11use lib qw(t/lib);
12use DBICTest;
b5ce6748 13use SQL::Abstract 'is_literal_value';
bb961936 14use DBIx::Class::_Util 'is_exception';
70350518 15
0567538f 16my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
17
52c53388 18### load any test classes that are defined further down in the file via BEGIN blocks
70a201a5 19our @test_classes; #< array that will be pushed into by test classes defined in this file
20DBICTest::Schema->load_classes( map {s/.+:://;$_} @test_classes ) if @test_classes;
efd38994 21
52c53388 22### pre-connect tests (keep each test separate as to make sure rebless() runs)
bab40dee 23 {
24 my $s = DBICTest::Schema->connect($dsn, $user, $pass);
bab40dee 25 # make sure sqlt_type overrides work (::Storage::DBI::Pg does this)
26 ok (!$s->storage->_dbh, 'definitely not connected');
27 is ($s->storage->sqlt_type, 'PostgreSQL', 'sqlt_type correct pre-connection');
28 ok (!$s->storage->_dbh, 'still not connected');
29 }
0567538f 30
97277745 31# test LIMIT support
32{
33 my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
34 drop_test_schema($schema);
35 create_test_schema($schema);
36 for (1..6) {
37 $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
38 }
39 my $it = $schema->resultset('Artist')->search( {},
40 { rows => 3,
41 offset => 2,
42 order_by => 'artistid' }
43 );
44 is( $it->count, 3, "LIMIT count ok" ); # ask for 3 rows out of 6 artists
45 is( $it->next->name, "Artist 3", "iterator->next ok" );
46 $it->next;
47 $it->next;
48 $it->next;
49 is( $it->next, undef, "next past end of resultset ok" );
e5372da4 50
51 # Limit with select-lock
52 lives_ok {
53 $schema->txn_do (sub {
54 isa_ok (
55 $schema->resultset('Artist')->find({artistid => 1}, {for => 'update', rows => 1}),
56 'DBICTest::Schema::Artist',
57 );
58 });
59 } 'Limited FOR UPDATE select works';
97277745 60}
61
bbdda281 62# check if we indeed do support stuff
63my $test_server_supports_insert_returning = do {
af1f4f84 64
65 my $si = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info;
66 die "Unparseable Pg server version: $si->{dbms_version}\n"
67 unless $si->{normalized_dbms_version};
68
69 $si->{normalized_dbms_version} < 8.002 ? 0 : 1;
bbdda281 70};
71is (
72 DBICTest::Schema->connect($dsn, $user, $pass)->storage->_use_insert_returning,
73 $test_server_supports_insert_returning,
74 'insert returning capability guessed correctly'
75);
76
77my $schema;
78for my $use_insert_returning ($test_server_supports_insert_returning
79 ? (0,1)
80 : (0)
81) {
82
6892eb09 83 no warnings qw/once redefine/;
84 my $old_connection = DBICTest::Schema->can('connection');
bbdda281 85 local *DBICTest::Schema::connection = subname 'DBICTest::Schema::connection' => sub {
6892eb09 86 my $s = shift->$old_connection(@_);
bbdda281 87 $s->storage->_use_insert_returning ($use_insert_returning);
88 $s;
89 };
90
91### test capability override
92 {
93 my $s = DBICTest::Schema->connect($dsn, $user, $pass);
94
95 ok (!$s->storage->_dbh, 'definitely not connected');
96
97 ok (
98 ! ($s->storage->_use_insert_returning xor $use_insert_returning),
99 'insert returning capability set correctly',
100 );
101 ok (!$s->storage->_dbh, 'still not connected (capability override works)');
102 }
103
70a201a5 104### connect, create postgres-specific test schema
c3af542a 105
bab40dee 106 $schema = DBICTest::Schema->connect($dsn, $user, $pass);
1f5aae08 107 $schema->storage->ensure_connected;
108
bab40dee 109 drop_test_schema($schema);
110 create_test_schema($schema);
609c5f1b 111
70a201a5 112### begin main tests
4617b792 113
372da819 114# run a BIG bunch of tests for last-insert-id / Auto-PK / sequence
115# discovery
bab40dee 116 run_apk_tests($schema); #< older set of auto-pk tests
117 run_extended_apk_tests($schema); #< new extended set of auto-pk tests
70a201a5 118
c58303cd 119
120######## test the pg-specific syntax from https://rt.cpan.org/Ticket/Display.html?id=99503
121 lives_ok {
122 is(
123 $schema->resultset('Artist')->search({ artistid => { -in => \ '(select 4) union (select 5)' } })->count,
124 2,
125 'Two expected artists found on subselect union within IN',
126 );
127 };
128
bab40dee 129### type_info tests
52c53388 130
bab40dee 131 my $test_type_info = {
132 'artistid' => {
133 'data_type' => 'integer',
134 'is_nullable' => 0,
135 'size' => 4,
136 },
137 'name' => {
138 'data_type' => 'character varying',
139 'is_nullable' => 1,
140 'size' => 100,
141 'default_value' => undef,
142 },
143 'rank' => {
144 'data_type' => 'integer',
145 'is_nullable' => 0,
146 'size' => 4,
147 'default_value' => 13,
52c53388 148
bab40dee 149 },
150 'charfield' => {
151 'data_type' => 'character',
152 'is_nullable' => 1,
153 'size' => 10,
154 'default_value' => undef,
155 },
156 'arrayfield' => {
157 'data_type' => 'integer[]',
158 'is_nullable' => 1,
159 'size' => undef,
160 'default_value' => undef,
161 },
162 };
52c53388 163
bab40dee 164 my $type_info = $schema->storage->columns_info_for('dbic_t_schema.artist');
165 my $artistid_defval = delete $type_info->{artistid}->{default_value};
70a201a5 166
f45dc928 167 # The curor info is too radically different from what is in the column_info
168 # call - just punt it (DBD::SQLite tests the codepath plenty enough)
169 unless (DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE) {
170 like(
171 $artistid_defval,
172 qr/^nextval\('([^\.]*\.){0,1}artist_artistid_seq'::(?:text|regclass)\)/,
173 'columns_info_for - sequence matches Pg get_autoinc_seq expectations'
174 );
a953d8d9 175
f45dc928 176 is_deeply($type_info, $test_type_info,
177 'columns_info_for - column data types');
178 }
a953d8d9 179
bab40dee 180####### Array tests
70a201a5 181
bab40dee 182 BEGIN {
183 package DBICTest::Schema::ArrayTest;
184 push @main::test_classes, __PACKAGE__;
70a201a5 185
bab40dee 186 use strict;
187 use warnings;
41519379 188 use base 'DBICTest::BaseResult';
70a201a5 189
bab40dee 190 __PACKAGE__->table('dbic_t_schema.array_test');
191 __PACKAGE__->add_columns(qw/id arrayfield/);
192 __PACKAGE__->column_info_from_storage(1);
193 __PACKAGE__->set_primary_key('id');
70a201a5 194
bab40dee 195 }
196 SKIP: {
0647e0cc 197 skip "Need DBD::Pg 2.9.2 or newer for array tests", 4 if $DBD::Pg::VERSION < 2.009002;
70a201a5 198
41519379 199 my $arr_rs = $schema->resultset('ArrayTest');
200
bab40dee 201 lives_ok {
41519379 202 $arr_rs->create({
bab40dee 203 arrayfield => [1, 2],
204 });
205 } 'inserting arrayref as pg array data';
70a201a5 206
bab40dee 207 lives_ok {
41519379 208 $arr_rs->update({
bab40dee 209 arrayfield => [3, 4],
210 });
211 } 'updating arrayref as pg array data';
ac45262b 212
41519379 213 $arr_rs->create({
0647e0cc 214 arrayfield => [5, 6],
9ba627e3 215 });
c224117b 216
f6faeab8 217 lives_ok {
218 $schema->populate('ArrayTest', [
219 [ qw/arrayfield/ ],
220 [ [0,0] ],
221 ]);
222 } 'inserting arrayref using void ctx populate';
223
41519379 224 # Search using arrays
225 lives_ok {
226 is_deeply (
227 $arr_rs->search({ arrayfield => { -value => [3,4] } })->first->arrayfield,
228 [3,4],
229 'Array value matches'
230 );
231 } 'searching by arrayref';
a780a0ff 232
bab40dee 233 lives_ok {
41519379 234 is_deeply (
235 $arr_rs->search({ arrayfield => { '=' => { -value => [3,4] }} })->first->arrayfield,
49eeb48d 236 [3,4],
41519379 237 'Array value matches explicit equal'
238 );
239 } 'searching by arrayref (explicit equal sign)';
a780a0ff 240
41519379 241 lives_ok {
242 is_deeply (
243 $arr_rs->search({ arrayfield => { '>' => { -value => [3,1] }} })->first->arrayfield,
244 [3,4],
245 'Array value matches greater than'
246 );
247 } 'searching by arrayref (greater than)';
248
249 lives_ok {
250 is (
251 $arr_rs->search({ arrayfield => { '>' => { -value => [3,7] }} })->count,
252 1,
253 'Greater than search found [5,6]',
254 );
255 } 'searching by arrayref (greater than)';
256
257 # Find using arrays
258 lives_ok {
259 is_deeply (
260 $arr_rs->find({ arrayfield => { -value => [3,4] } })->arrayfield,
261 [3,4],
262 'Array value matches implicit equal'
263 );
264 } 'find by arrayref';
265
266 lives_ok {
267 is_deeply (
268 $arr_rs->find({ arrayfield => { '=' => { -value => [3,4] }} })->arrayfield,
269 [3,4],
270 'Array value matches explicit equal'
271 );
272 } 'find by arrayref (equal)';
273
274 # test inferred condition for creation
4ca1fd6f 275 for my $cond (
41519379 276 { -value => [3,4] },
277 \[ '= ?' => [arrayfield => [3, 4]] ],
278 ) {
5f35ba0f 279 local $TODO = 'No introspection of complex literal conditions :('
280 if is_literal_value $cond;
281
282
41519379 283 my $arr_rs_cond = $arr_rs->search({ arrayfield => $cond });
284
285 my $row = $arr_rs_cond->create({});
a780a0ff 286 is_deeply ($row->arrayfield, [3,4], 'Array value taken from $rs condition');
287 $row->discard_changes;
288 is_deeply ($row->arrayfield, [3,4], 'Array value made it to storage');
289 }
bab40dee 290 }
9ba627e3 291
70a201a5 292########## Case check
293
bab40dee 294 BEGIN {
295 package DBICTest::Schema::Casecheck;
296 push @main::test_classes, __PACKAGE__;
70a201a5 297
bab40dee 298 use strict;
299 use warnings;
300 use base 'DBIx::Class::Core';
70a201a5 301
bab40dee 302 __PACKAGE__->table('dbic_t_schema.casecheck');
303 __PACKAGE__->add_columns(qw/id name NAME uc_name/);
304 __PACKAGE__->column_info_from_storage(1);
305 __PACKAGE__->set_primary_key('id');
306 }
70a201a5 307
bab40dee 308 my $name_info = $schema->source('Casecheck')->column_info( 'name' );
309 is( $name_info->{size}, 1, "Case sensitive matching info for 'name'" );
ae515736 310
bab40dee 311 my $NAME_info = $schema->source('Casecheck')->column_info( 'NAME' );
312 is( $NAME_info->{size}, 2, "Case sensitive matching info for 'NAME'" );
ae515736 313
bab40dee 314 my $uc_name_info = $schema->source('Casecheck')->column_info( 'uc_name' );
315 is( $uc_name_info->{size}, 3, "Case insensitive matching info for 'uc_name'" );
ae515736 316
70a201a5 317
ecccae8a 318## Test ResultSet->update
319my $artist = $schema->resultset('Artist')->first;
320my $cds = $artist->cds_unordered->search({
321 year => { '!=' => 2010 }
322}, { prefetch => 'liner_notes' });
67b79ae1 323lives_ok { $cds->update({ year => '2010' }) } 'Update on prefetched rs';
70a201a5 324
325## Test SELECT ... FOR UPDATE
bab40dee 326 SKIP: {
bb961936 327 skip "Your system does not support unsafe signals (d_sigaction) - unable to run deadlock test", 1
328 unless eval { $Config{d_sigaction} and require POSIX };
bab40dee 329
330 my ($timed_out, $artist2);
331
332 for my $t (
333 {
334 # Make sure that an error was raised, and that the update failed
335 update_lock => 1,
336 test_sub => sub {
337 ok($timed_out, "update from second schema times out");
338 ok($artist2->is_column_changed('name'), "'name' column is still dirty from second schema");
339 },
52c53388 340 },
bab40dee 341 {
342 # Make sure that an error was NOT raised, and that the update succeeded
343 update_lock => 0,
344 test_sub => sub {
345 ok(! $timed_out, "update from second schema DOES NOT timeout");
346 ok(! $artist2->is_column_changed('name'), "'name' column is NOT dirty from second schema");
347 },
52c53388 348 },
bab40dee 349 ) {
350 # create a new schema
351 my $schema2 = DBICTest::Schema->connect($dsn, $user, $pass);
352 $schema2->source("Artist")->name("dbic_t_schema.artist");
353
354 $schema->txn_do( sub {
d2408067 355 my $rs = $schema->resultset('Artist')->search(
bab40dee 356 {
357 artistid => 1
358 },
359 $t->{update_lock} ? { for => 'update' } : {}
d2408067 360 );
361 ok ($rs->count, 'Count works');
362
363 my $artist = $rs->next;
bab40dee 364 is($artist->artistid, 1, "select returns artistid = 1");
365
366 $timed_out = 0;
bb961936 367
bab40dee 368 eval {
bb961936 369 # can not use %SIG assignment directly - we need sigaction below
370 # localization to a block still works however
371 local $SIG{ALRM};
372
373 POSIX::sigaction( POSIX::SIGALRM() => POSIX::SigAction->new(
374 sub { die "DBICTestTimeout" },
375 ));
376
bab40dee 377 $artist2 = $schema2->resultset('Artist')->find(1);
378 $artist2->name('fooey');
731c2d8b 379
380 # FIXME - this needs to go away in lieu of a non-retrying runner
381 # ( i.e. after solving RT#47005 )
382 local *DBIx::Class::Storage::DBI::_ping = sub { 1 }, DBIx::Class::_ENV_::OLD_MRO && Class::C3->reinitialize()
383 if DBIx::Class::_Util::modver_gt_or_eq( 'DBD::Pg' => '3.5.0' );
384
385 alarm(1);
bab40dee 386 $artist2->update;
bab40dee 387 };
bb961936 388
389 alarm(0);
390
391 if (is_exception($@)) {
392 $timed_out = $@ =~ /DBICTestTimeout/
393 or die $@;
394 }
bab40dee 395 });
396
397 $t->{test_sub}->();
398 }
399 }
95ba7ee4 400
70a201a5 401
372da819 402######## other older Auto-pk tests
70a201a5 403
bab40dee 404 $schema->source("SequenceTest")->name("dbic_t_schema.sequence_test");
405 for (1..5) {
406 my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
407 is($st->pkid1, $_, "Auto-PK for sequence without default: First primary key");
408 is($st->pkid2, $_ + 9, "Auto-PK for sequence without default: Second primary key");
409 is($st->nonpkid, $_ + 19, "Auto-PK for sequence without default: Non-primary key");
410 }
411 my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
412 is($st->pkid1, 55, "Auto-PK for sequence without default: First primary key set manually");
4d4dc518 413
414
38d5ea9f 415######## test non-serial auto-pk
4d4dc518 416
bbdda281 417 if ($schema->storage->_use_insert_returning) {
bab40dee 418 $schema->source('TimestampPrimaryKey')->name('dbic_t_schema.timestamp_primary_key_test');
419 my $row = $schema->resultset('TimestampPrimaryKey')->create({});
420 ok $row->id;
421 }
d093d3eb 422
be860760 423######## test with_deferred_fk_checks
424
bab40dee 425 $schema->source('CD')->name('dbic_t_schema.cd');
426 $schema->source('Track')->name('dbic_t_schema.track');
427 lives_ok {
428 $schema->storage->with_deferred_fk_checks(sub {
429 $schema->resultset('Track')->create({
430 trackid => 999, cd => 999, position => 1, title => 'deferred FK track'
431 });
432 $schema->resultset('CD')->create({
433 artist => 1, cdid => 999, year => '2003', title => 'deferred FK cd'
434 });
be860760 435 });
bab40dee 436 } 'with_deferred_fk_checks code survived';
be860760 437
bab40dee 438 is eval { $schema->resultset('Track')->find(999)->title }, 'deferred FK track',
8273e845 439 'code in with_deferred_fk_checks worked';
be860760 440
bab40dee 441 throws_ok {
442 $schema->resultset('Track')->create({
443 trackid => 1, cd => 9999, position => 1, title => 'Track1'
444 });
445 } qr/constraint/i, 'with_deferred_fk_checks is off';
446}
be860760 447
2fbf50ff 448done_testing;
609c5f1b 449
5935c90a 450END {
f66c9ba8 451 return unless $schema;
5935c90a 452 drop_test_schema($schema);
65d35121 453 eapk_drop_all($schema);
454 undef $schema;
5935c90a 455};
70a201a5 456
457
458######### SUBROUTINES
459
460sub create_test_schema {
2fbf50ff 461 my $schema = shift;
462 $schema->storage->dbh_do(sub {
463 my (undef,$dbh) = @_;
70a201a5 464
2fbf50ff 465 local $dbh->{Warn} = 0;
70a201a5 466
2fbf50ff 467 my $std_artist_table = <<EOS;
70a201a5 468(
469 artistid serial PRIMARY KEY
470 , name VARCHAR(100)
471 , rank INTEGER NOT NULL DEFAULT '13'
472 , charfield CHAR(10)
473 , arrayfield INTEGER[]
474)
475EOS
476
881def48 477 $dbh->do("CREATE SCHEMA dbic_t_schema");
478 $dbh->do("CREATE TABLE dbic_t_schema.artist $std_artist_table");
4d4dc518 479
480 $dbh->do(<<EOS);
481CREATE TABLE dbic_t_schema.timestamp_primary_key_test (
be860760 482 id timestamp default current_timestamp
4d4dc518 483)
484EOS
2fbf50ff 485 $dbh->do(<<EOS);
be860760 486CREATE TABLE dbic_t_schema.cd (
487 cdid int PRIMARY KEY,
488 artist int,
489 title varchar(255),
490 year varchar(4),
491 genreid int,
492 single_track int
493)
494EOS
495 $dbh->do(<<EOS);
496CREATE TABLE dbic_t_schema.track (
497 trackid int,
498 cd int REFERENCES dbic_t_schema.cd(cdid) DEFERRABLE,
499 position int,
500 title varchar(255),
501 last_updated_on date,
3d98c75e 502 last_updated_at date
be860760 503)
504EOS
505
506 $dbh->do(<<EOS);
881def48 507CREATE TABLE dbic_t_schema.sequence_test (
70a201a5 508 pkid1 integer
509 , pkid2 integer
510 , nonpkid integer
511 , name VARCHAR(100)
512 , CONSTRAINT pk PRIMARY KEY(pkid1, pkid2)
513)
514EOS
2fbf50ff 515 $dbh->do("CREATE SEQUENCE pkid1_seq START 1 MAXVALUE 999999 MINVALUE 0");
516 $dbh->do("CREATE SEQUENCE pkid2_seq START 10 MAXVALUE 999999 MINVALUE 0");
517 $dbh->do("CREATE SEQUENCE nonpkid_seq START 20 MAXVALUE 999999 MINVALUE 0");
518 $dbh->do(<<EOS);
881def48 519CREATE TABLE dbic_t_schema.casecheck (
70a201a5 520 id serial PRIMARY KEY
521 , "name" VARCHAR(1)
522 , "NAME" VARCHAR(2)
523 , "UC_NAME" VARCHAR(3)
70a201a5 524)
525EOS
2fbf50ff 526 $dbh->do(<<EOS);
881def48 527CREATE TABLE dbic_t_schema.array_test (
70a201a5 528 id serial PRIMARY KEY
529 , arrayfield INTEGER[]
530)
531EOS
881def48 532 $dbh->do("CREATE SCHEMA dbic_t_schema_2");
533 $dbh->do("CREATE TABLE dbic_t_schema_2.artist $std_artist_table");
534 $dbh->do("CREATE SCHEMA dbic_t_schema_3");
535 $dbh->do("CREATE TABLE dbic_t_schema_3.artist $std_artist_table");
536 $dbh->do('set search_path=dbic_t_schema,public');
537 $dbh->do("CREATE SCHEMA dbic_t_schema_4");
538 $dbh->do("CREATE SCHEMA dbic_t_schema_5");
2fbf50ff 539 $dbh->do(<<EOS);
881def48 540 CREATE TABLE dbic_t_schema_4.artist
70a201a5 541 (
542 artistid integer not null default nextval('artist_artistid_seq'::regclass) PRIMARY KEY
543 , name VARCHAR(100)
544 , rank INTEGER NOT NULL DEFAULT '13'
545 , charfield CHAR(10)
546 , arrayfield INTEGER[]
547 );
548EOS
881def48 549 $dbh->do('set search_path=public,dbic_t_schema,dbic_t_schema_3');
2fbf50ff 550 $dbh->do('create sequence public.artist_artistid_seq'); #< in the public schema
551 $dbh->do(<<EOS);
881def48 552 CREATE TABLE dbic_t_schema_5.artist
70a201a5 553 (
554 artistid integer not null default nextval('public.artist_artistid_seq'::regclass) PRIMARY KEY
555 , name VARCHAR(100)
556 , rank INTEGER NOT NULL DEFAULT '13'
557 , charfield CHAR(10)
558 , arrayfield INTEGER[]
559 );
560EOS
881def48 561 $dbh->do('set search_path=dbic_t_schema,public');
2fbf50ff 562 });
70a201a5 563}
564
565
566
567sub drop_test_schema {
52c53388 568 my ( $schema, $warn_exceptions ) = @_;
2fbf50ff 569
570 $schema->storage->dbh_do(sub {
571 my (undef,$dbh) = @_;
572
573 local $dbh->{Warn} = 0;
574
575 for my $stat (
881def48 576 'DROP SCHEMA dbic_t_schema_5 CASCADE',
e78c769d 577 'DROP SEQUENCE public.artist_artistid_seq CASCADE',
881def48 578 'DROP SCHEMA dbic_t_schema_4 CASCADE',
579 'DROP SCHEMA dbic_t_schema CASCADE',
e78c769d 580 'DROP SEQUENCE pkid1_seq CASCADE',
581 'DROP SEQUENCE pkid2_seq CASCADE',
582 'DROP SEQUENCE nonpkid_seq CASCADE',
881def48 583 'DROP SCHEMA dbic_t_schema_2 CASCADE',
584 'DROP SCHEMA dbic_t_schema_3 CASCADE',
2fbf50ff 585 ) {
586 eval { $dbh->do ($stat) };
52c53388 587 diag $@ if $@ && $warn_exceptions;
2fbf50ff 588 }
589 });
3ff5b740 590}
7603d2a5 591
372da819 592
ee9f372c 593### auto-pk / last_insert_id / sequence discovery
594sub run_apk_tests {
595 my $schema = shift;
596
597 # This is in Core now, but it's here just to test that it doesn't break
598 $schema->class('Artist')->load_components('PK::Auto');
599 cmp_ok( $schema->resultset('Artist')->count, '==', 0, 'this should start with an empty artist table');
600
601 # test that auto-pk also works with the defined search path by
602 # un-schema-qualifying the table name
603 apk_t_set($schema,'artist');
604
605 my $unq_new;
606 lives_ok {
607 $unq_new = $schema->resultset('Artist')->create({ name => 'baz' });
608 } 'insert into unqualified, shadowed table succeeds';
609
610 is($unq_new && $unq_new->artistid, 1, "and got correct artistid");
611
612 my @test_schemas = ( [qw| dbic_t_schema_2 1 |],
613 [qw| dbic_t_schema_3 1 |],
614 [qw| dbic_t_schema_4 2 |],
615 [qw| dbic_t_schema_5 1 |],
616 );
617 foreach my $t ( @test_schemas ) {
618 my ($sch_name, $start_num) = @$t;
619 #test with dbic_t_schema_2
620 apk_t_set($schema,"$sch_name.artist");
621 my $another_new;
622 lives_ok {
623 $another_new = $schema->resultset('Artist')->create({ name => 'Tollbooth Willy'});
624 is( $another_new->artistid,$start_num, "got correct artistid for $sch_name")
625 or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>');
626 } "$sch_name liid 1 did not die"
627 or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>');
628 lives_ok {
629 $another_new = $schema->resultset('Artist')->create({ name => 'Adam Sandler'});
630 is( $another_new->artistid,$start_num+1, "got correct artistid for $sch_name")
631 or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>');
632 } "$sch_name liid 2 did not die"
633 or diag "USED SEQUENCE: ".($schema->source('Artist')->column_info('artistid')->{sequence} || '<none>');
634
635 }
636
637 lives_ok {
638 apk_t_set($schema,'dbic_t_schema.artist');
639 my $new = $schema->resultset('Artist')->create({ name => 'foo' });
640 is($new->artistid, 4, "Auto-PK worked");
641 $new = $schema->resultset('Artist')->create({ name => 'bar' });
642 is($new->artistid, 5, "Auto-PK worked");
643 } 'old auto-pk tests did not die either';
644}
645
ee9f372c 646# sets the artist table name and clears sequence name cache
647sub apk_t_set {
648 my ( $s, $n ) = @_;
649 $s->source("Artist")->name($n);
650 $s->source('Artist')->column_info('artistid')->{sequence} = undef; #< clear sequence name cache
651}
652
372da819 653
5935c90a 654######## EXTENDED AUTO-PK TESTS
655
f295a73c 656my @eapk_id_columns;
5935c90a 657BEGIN {
658 package DBICTest::Schema::ExtAPK;
659 push @main::test_classes, __PACKAGE__;
660
661 use strict;
662 use warnings;
d88ecca6 663 use base 'DBIx::Class::Core';
5935c90a 664
f295a73c 665 __PACKAGE__->table('apk');
5935c90a 666
f295a73c 667 @eapk_id_columns = qw( id1 id2 id3 id4 );
5935c90a 668 __PACKAGE__->add_columns(
669 map { $_ => { data_type => 'integer', is_auto_increment => 1 } }
f295a73c 670 @eapk_id_columns
5935c90a 671 );
672
f295a73c 673 __PACKAGE__->set_primary_key('id2'); #< note the SECOND column is
674 #the primary key
5935c90a 675}
676
f295a73c 677my @eapk_schemas;
678BEGIN{ @eapk_schemas = map "dbic_apk_$_", 0..5 }
ae645c61 679my %seqs; #< hash of schema.table.col => currval of its (DBIC) primary key sequence
5935c90a 680
372da819 681sub run_extended_apk_tests {
11da4e66 682 my $schema = shift;
372da819 683
f295a73c 684 #save the search path and reset it at the end
49aa7e87 685 my $search_path_save = eapk_get_search_path($schema);
f295a73c 686
52c53388 687 eapk_drop_all($schema);
bab40dee 688 %seqs = ();
5935c90a 689
f295a73c 690 # make the test schemas and sequences
11da4e66 691 $schema->storage->dbh_do(sub {
f295a73c 692 my ( undef, $dbh ) = @_;
693
694 $dbh->do("CREATE SCHEMA $_")
695 for @eapk_schemas;
696
697 $dbh->do("CREATE SEQUENCE $eapk_schemas[5].fooseq");
ae645c61 698 $dbh->do("SELECT setval('$eapk_schemas[5].fooseq',400)");
699 $seqs{"$eapk_schemas[1].apk.id2"} = 400;
700
fb7be534 701 $dbh->do("CREATE SEQUENCE $eapk_schemas[4].fooseq");
ae645c61 702 $dbh->do("SELECT setval('$eapk_schemas[4].fooseq',300)");
703 $seqs{"$eapk_schemas[3].apk.id2"} = 300;
704
93a6e8fa 705 $dbh->do("CREATE SEQUENCE $eapk_schemas[3].fooseq");
ae645c61 706 $dbh->do("SELECT setval('$eapk_schemas[3].fooseq',200)");
707 $seqs{"$eapk_schemas[4].apk.id2"} = 200;
f295a73c 708
78c9596c 709 $dbh->do("SET search_path = ".join ',', reverse @eapk_schemas );
11da4e66 710 });
372da819 711
f295a73c 712 # clear our search_path cache
713 $schema->storage->{_pg_search_path} = undef;
714
715 eapk_create( $schema,
716 with_search_path => [0,1],
717 );
718 eapk_create( $schema,
719 with_search_path => [1,0,'public'],
720 nextval => "$eapk_schemas[5].fooseq",
721 );
722 eapk_create( $schema,
723 with_search_path => ['public',0,1],
724 qualify_table => 2,
725 );
fb7be534 726 eapk_create( $schema,
727 with_search_path => [3,1,0,'public'],
728 nextval => "$eapk_schemas[4].fooseq",
729 );
93a6e8fa 730 eapk_create( $schema,
731 with_search_path => [3,1,0,'public'],
732 nextval => "$eapk_schemas[3].fooseq",
733 qualify_table => 4,
734 );
372da819 735
78c9596c 736 eapk_poke( $schema );
f295a73c 737 eapk_poke( $schema, 0 );
eb80e8d5 738 eapk_poke( $schema, 2 );
93a6e8fa 739 eapk_poke( $schema, 4 );
f295a73c 740 eapk_poke( $schema, 1 );
eb80e8d5 741 eapk_poke( $schema, 0 );
f295a73c 742 eapk_poke( $schema, 1 );
78c9596c 743 eapk_poke( $schema );
93a6e8fa 744 eapk_poke( $schema, 4 );
fb7be534 745 eapk_poke( $schema, 3 );
eb80e8d5 746 eapk_poke( $schema, 1 );
747 eapk_poke( $schema, 2 );
748 eapk_poke( $schema, 0 );
f295a73c 749
750 # set our search path back
751 eapk_set_search_path( $schema, @$search_path_save );
752}
753
754# do a DBIC create on the apk table in the given schema number (which is an
755# index of @eapk_schemas)
756
f295a73c 757sub eapk_poke {
758 my ($s, $schema_num) = @_;
372da819 759
f295a73c 760 my $schema_name = defined $schema_num
761 ? $eapk_schemas[$schema_num]
762 : '';
763
78c9596c 764 my $schema_name_actual = $schema_name || eapk_find_visible_schema($s);
f295a73c 765
8ce84173 766 $s->source('ExtAPK')->name($schema_name ? $schema_name.'.apk' : 'apk');
f295a73c 767 #< clear sequence name cache
768 $s->source('ExtAPK')->column_info($_)->{sequence} = undef
769 for @eapk_id_columns;
770
771 no warnings 'uninitialized';
772 lives_ok {
773 my $new;
774 for my $inc (1,2,3) {
ae645c61 775 $new = $schema->resultset('ExtAPK')->create({ id1 => 1});
691f3663 776 my $proper_seqval = ++$seqs{"$schema_name_actual.apk.id2"};
777 is( $new->id2, $proper_seqval, "$schema_name_actual.apk.id2 correct inc $inc" )
778 or eapk_seq_diag($s,$schema_name);
779 $new->discard_changes;
ae645c61 780 is( $new->id1, 1 );
781 for my $id ('id3','id4') {
f295a73c 782 my $proper_seqval = ++$seqs{"$schema_name_actual.apk.$id"};
93a6e8fa 783 is( $new->$id, $proper_seqval, "$schema_name_actual.apk.$id correct inc $inc" )
fb7be534 784 or eapk_seq_diag($s,$schema_name);
f295a73c 785 }
786 }
787 } "create in schema '$schema_name' lives"
fb7be534 788 or eapk_seq_diag($s,$schema_name);
372da819 789}
790
f295a73c 791# print diagnostic info on which sequences were found in the ExtAPK
792# class
793sub eapk_seq_diag {
794 my $s = shift;
78c9596c 795 my $schema = shift || eapk_find_visible_schema($s);
f295a73c 796
797 diag "$schema.apk sequences: ",
798 join(', ',
799 map "$_:".($s->source('ExtAPK')->column_info($_)->{sequence} || '<none>'),
800 @eapk_id_columns
801 );
802}
803
49aa7e87 804# get the postgres search path as an arrayref
805sub eapk_get_search_path {
806 my ( $s ) = @_;
807 # cache the search path as ['schema','schema',...] in the storage
808 # obj
809
810 return $s->storage->dbh_do(sub {
811 my (undef, $dbh) = @_;
812 my @search_path;
813 my ($sp_string) = $dbh->selectrow_array('SHOW search_path');
814 while ( $sp_string =~ s/("[^"]+"|[^,]+),?// ) {
815 unless( defined $1 and length $1 ) {
816 die "search path sanity check failed: '$1'";
817 }
818 push @search_path, $1;
819 }
820 \@search_path
821 });
822}
f295a73c 823sub eapk_set_search_path {
824 my ($s,@sp) = @_;
825 my $sp = join ',',@sp;
826 $s->storage->dbh_do( sub { $_[1]->do("SET search_path = $sp") } );
827}
828
829# create the apk table in the given schema, can set whether the table name is qualified, what the nextval is for the second ID
5935c90a 830sub eapk_create {
831 my ($schema, %a) = @_;
832
372da819 833 $schema->storage->dbh_do(sub {
5935c90a 834 my (undef,$dbh) = @_;
372da819 835
5935c90a 836 my $searchpath_save;
837 if ( $a{with_search_path} ) {
838 ($searchpath_save) = $dbh->selectrow_array('SHOW search_path');
839
f295a73c 840 my $search_path = join ',',map {/\D/ ? $_ : $eapk_schemas[$_]} @{$a{with_search_path}};
5935c90a 841
842 $dbh->do("SET search_path = $search_path");
843 }
844
f295a73c 845 my $table_name = $a{qualify_table}
846 ? ($eapk_schemas[$a{qualify_table}] || die). ".apk"
847 : 'apk';
e25fe566 848 local $_[1]->{Warn} = 0;
f295a73c 849
850 my $id_def = $a{nextval}
ae645c61 851 ? "integer not null default nextval('$a{nextval}'::regclass)"
852 : 'serial';
5935c90a 853 $dbh->do(<<EOS);
f295a73c 854CREATE TABLE $table_name (
855 id1 serial
856 , id2 $id_def
ae645c61 857 , id3 serial primary key
5935c90a 858 , id4 serial
859)
860EOS
372da819 861
5935c90a 862 if( $searchpath_save ) {
863 $dbh->do("SET search_path = $searchpath_save");
864 }
372da819 865 });
866}
867
5935c90a 868sub eapk_drop_all {
52c53388 869 my ( $schema, $warn_exceptions ) = @_;
372da819 870
871 $schema->storage->dbh_do(sub {
872 my (undef,$dbh) = @_;
873
874 local $dbh->{Warn} = 0;
5935c90a 875
876 # drop the test schemas
f295a73c 877 for (@eapk_schemas ) {
11da4e66 878 eval{ $dbh->do("DROP SCHEMA $_ CASCADE") };
52c53388 879 diag $@ if $@ && $warn_exceptions;
11da4e66 880 }
881
372da819 882
372da819 883 });
884}
78c9596c 885
886sub eapk_find_visible_schema {
887 my ($s) = @_;
888
889 my ($schema) =
890 $s->storage->dbh_do(sub {
891 $_[1]->selectrow_array(<<EOS);
892SELECT n.nspname
893FROM pg_catalog.pg_namespace n
894JOIN pg_catalog.pg_class c ON c.relnamespace = n.oid
895WHERE c.relname = 'apk'
896 AND pg_catalog.pg_table_is_visible(c.oid)
897EOS
898 });
899 return $schema;
900}