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