Skip error/warn frames within CAG - saner callsite error messages this way
[dbsrgits/DBIx-Class.git] / t / 746mssql.t
CommitLineData
c1cac633 1use strict;
b9a2c3a5 2use warnings;
c1cac633 3
4use Test::More;
893403c8 5use Test::Exception;
199fbc45 6use Try::Tiny;
7use DBIx::Class::SQLMaker::LimitDialects;
8use DBIx::Class::Optional::Dependencies ();
c1cac633 9use lib qw(t/lib);
10use DBICTest;
b2d16f1f 11use DBIC::SqlMakerTest;
c1cac633 12
199fbc45 13plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_mssql_odbc')
14 unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mssql_odbc');
15
fcb7fcbb 16my $OFFSET = DBIx::Class::SQLMaker::LimitDialects->__offset_bindtype;
17my $TOTAL = DBIx::Class::SQLMaker::LimitDialects->__total_bindtype;
18
c1cac633 19my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ODBC_${_}" } qw/DSN USER PASS/};
20
21plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ODBC_DSN}, _USER and _PASS to run this test'
22 unless ($dsn && $user);
23
77c7628c 24{
25 my $srv_ver = DBICTest::Schema->connect($dsn, $user, $pass)->storage->_server_info->{dbms_version};
26 ok ($srv_ver, 'Got a test server version on fresh schema: ' . ($srv_ver||'???') );
27}
28
ca791b95 29DBICTest::Schema->load_classes('ArtistGUID');
42e5b103 30my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
c1cac633 31
8c0104fe 32{
33 no warnings 'redefine';
34 my $connect_count = 0;
35 my $orig_connect = \&DBI::connect;
36 local *DBI::connect = sub { $connect_count++; goto &$orig_connect };
37
38 $schema->storage->ensure_connected;
39
40 is( $connect_count, 1, 'only one connection made');
41}
9b3e916d 42
c1cac633 43isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server' );
44
cf89555e 45{
46 my $schema2 = $schema->connect ($schema->storage->connect_info);
47 ok (! $schema2->storage->connected, 'a re-connected cloned schema starts unconnected');
48}
49
ecdf1ac8 50$schema->storage->_dbh->disconnect;
51
52lives_ok {
53 $schema->storage->dbh_do(sub { $_[1]->do('select 1') })
54} '_ping works';
55
384b8bce 56my %opts = (
57 use_mars =>
9ffaf8a3 58 { opts => { on_connect_call => 'use_mars' } },
384b8bce 59 use_dynamic_cursors =>
9ffaf8a3 60 { opts => { on_connect_call => 'use_dynamic_cursors' }, required => 1 },
384b8bce 61 use_server_cursors =>
9ffaf8a3 62 { opts => { on_connect_call => 'use_server_cursors' } },
63 NO_OPTION =>
64 { opts => {}, required => 1 },
384b8bce 65);
66
67for my $opts_name (keys %opts) {
68 SKIP: {
9ffaf8a3 69 my $opts = $opts{$opts_name}{opts};
384b8bce 70 $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
71
72 try {
73 $schema->storage->ensure_connected
74 }
75 catch {
9ffaf8a3 76 if ($opts{$opts_name}{required}) {
77 BAIL_OUT "on_connect_call option '$opts_name' is not functional: $_";
78 }
79 else {
80 skip
81"on_connect_call option '$opts_name' not functional in this configuration: $_",
821;
83 }
384b8bce 84 };
85
e56b1c2d 86 $schema->storage->dbh_do (sub {
87 my ($storage, $dbh) = @_;
88 eval { $dbh->do("DROP TABLE artist") };
89 $dbh->do(<<'SQL');
c1cac633 90CREATE TABLE artist (
91 artistid INT IDENTITY NOT NULL,
a0dd8679 92 name VARCHAR(100),
39da2a2b 93 rank INT NOT NULL DEFAULT '13',
2eebd801 94 charfield CHAR(10) NULL,
c1cac633 95 primary key(artistid)
96)
c5f77f6c 97SQL
e56b1c2d 98 });
c5f77f6c 99
384b8bce 100# test Auto-PK
101 $schema->resultset('Artist')->search({ name => 'foo' })->delete;
c1cac633 102
384b8bce 103 my $new = $schema->resultset('Artist')->create({ name => 'foo' });
7b1b2582 104
384b8bce 105 ok(($new->artistid||0) > 0, "Auto-PK worked for $opts_name");
7b1b2582 106
384b8bce 107# Test multiple active statements
108 SKIP: {
109 skip 'not a multiple active statements configuration', 1
110 if $opts_name eq 'plain';
41dd5d30 111
384b8bce 112 my $artist_rs = $schema->resultset('Artist');
41dd5d30 113
384b8bce 114 $artist_rs->delete;
c1cac633 115
384b8bce 116 $artist_rs->create({ name => "Artist$_" }) for (1..3);
ca791b95 117
384b8bce 118 my $forward = $artist_rs->search({},
119 { order_by => { -asc => 'artistid' } });
120 my $backward = $artist_rs->search({},
121 { order_by => { -desc => 'artistid' } });
122
123 my @map = (
124 [qw/Artist1 Artist3/], [qw/Artist2 Artist2/], [qw/Artist3 Artist1/]
125 );
126 my @result;
127
128 while (my $forward_row = $forward->next) {
129 my $backward_row = $backward->next;
130 push @result, [$forward_row->name, $backward_row->name];
131 }
132
133 is_deeply \@result, \@map, "multiple active statements in $opts_name";
134
135 $artist_rs->delete;
136 }
ca791b95 137
a54bd479 138# Test populate
f6b185e1 139
e56b1c2d 140 {
141 $schema->storage->dbh_do (sub {
142 my ($storage, $dbh) = @_;
143 eval { $dbh->do("DROP TABLE owners") };
144 eval { $dbh->do("DROP TABLE books") };
145 $dbh->do(<<'SQL');
02495deb 146CREATE TABLE books (
b9a2c3a5 147 id INT IDENTITY (1, 1) NOT NULL,
148 source VARCHAR(100),
149 owner INT,
150 title VARCHAR(10),
151 price INT NULL
152)
153
02495deb 154CREATE TABLE owners (
b9a2c3a5 155 id INT IDENTITY (1, 1) NOT NULL,
42e5b103 156 name VARCHAR(100),
b9a2c3a5 157)
b9a2c3a5 158SQL
a54bd479 159 });
160
e56b1c2d 161 lives_ok ( sub {
162 # start a new connection, make sure rebless works
163 my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
164 $schema->populate ('Owners', [
165 [qw/id name /],
166 [qw/1 wiggle/],
167 [qw/2 woggle/],
168 [qw/3 boggle/],
169 [qw/4 fRIOUX/],
170 [qw/5 fRUE/],
171 [qw/6 fREW/],
172 [qw/7 fROOH/],
173 [qw/8 fISMBoC/],
174 [qw/9 station/],
175 [qw/10 mirror/],
176 [qw/11 dimly/],
177 [qw/12 face_to_face/],
178 [qw/13 icarus/],
179 [qw/14 dream/],
180 [qw/15 dyrstyggyr/],
181 ]);
182 }, 'populate with PKs supplied ok' );
183
184
185 lives_ok (sub {
186 # start a new connection, make sure rebless works
187 # test an insert with a supplied identity, followed by one without
188 my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
189 for (2, 1) {
190 my $id = $_ * 20 ;
191 $schema->resultset ('Owners')->create ({ id => $id, name => "troglodoogle $id" });
192 $schema->resultset ('Owners')->create ({ name => "troglodoogle " . ($id + 1) });
193 }
194 }, 'create with/without PKs ok' );
195
196 is ($schema->resultset ('Owners')->count, 19, 'owner rows really in db' );
197
198 lives_ok ( sub {
199 # start a new connection, make sure rebless works
200 my $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
201 $schema->populate ('BooksInLibrary', [
202 [qw/source owner title /],
203 [qw/Library 1 secrets0/],
204 [qw/Library 1 secrets1/],
205 [qw/Eatery 1 secrets2/],
206 [qw/Library 2 secrets3/],
207 [qw/Library 3 secrets4/],
208 [qw/Eatery 3 secrets5/],
209 [qw/Library 4 secrets6/],
210 [qw/Library 5 secrets7/],
211 [qw/Eatery 5 secrets8/],
212 [qw/Library 6 secrets9/],
213 [qw/Library 7 secrets10/],
214 [qw/Eatery 7 secrets11/],
215 [qw/Library 8 secrets12/],
216 ]);
217 }, 'populate without PKs supplied ok' );
a54bd479 218 }
fb7cd45f 219
e56b1c2d 220# test simple, complex LIMIT and limited prefetch support, with both dialects and quote combinations (if possible)
221 for my $dialect (
222 'Top',
223 ($schema->storage->_server_info->{normalized_dbms_version} || 0 ) >= 9
224 ? ('RowNumberOver')
225 : ()
226 ,
227 ) {
228 for my $quoted (0, 1) {
229
230 $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
231 limit_dialect => $dialect,
232 %$opts,
233 $quoted
234 ? ( quote_char => [ qw/ [ ] / ], name_sep => '.' )
235 : ()
236 ,
237 });
238
239 my $test_type = "Dialect:$dialect Quoted:$quoted";
240
241 # basic limit support
242 TODO: {
243 my $art_rs = $schema->resultset ('Artist');
244 $art_rs->delete;
245 $art_rs->create({ name => 'Artist ' . $_ }) for (1..6);
246
247 my $it = $schema->resultset('Artist')->search( {}, {
248 rows => 4,
249 offset => 3,
250 order_by => 'artistid',
251 });
252
253 is( $it->count, 3, "$test_type: LIMIT count ok" );
254
255 local $TODO = "Top-limit does not work when your limit ends up past the resultset"
256 if $dialect eq 'Top';
257
258 is( $it->next->name, 'Artist 4', "$test_type: iterator->next ok" );
259 $it->next;
260 is( $it->next->name, 'Artist 6', "$test_type: iterator->next ok" );
261 is( $it->next, undef, "$test_type: next past end of resultset ok" );
262 }
f0bd60fc 263
e56b1c2d 264 # plain ordered subqueries throw
265 throws_ok (sub {
266 $schema->resultset('Owners')->search ({}, { order_by => 'name' })->as_query
267 }, qr/ordered subselect encountered/, "$test_type: Ordered Subselect detection throws ok");
a54bd479 268
e56b1c2d 269 # make sure ordered subselects *somewhat* work
270 {
271 my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 });
272 my $sealed_owners = $owners->as_subselect_rs;
273
274 is_deeply (
275 [ map { $_->name } ($sealed_owners->all) ],
276 [ map { $_->name } ($owners->all) ],
277 "$test_type: Sort preserved from within a subquery",
278 );
279 }
a54bd479 280
e56b1c2d 281 {
282 my $book_owner_ids = $schema->resultset ('BooksInLibrary')->search ({}, {
283 rows => 6,
284 offset => 2,
285 join => 'owner',
286 distinct => 1,
287 order_by => 'owner.name',
288 unsafe_subselect_ok => 1
289 })->get_column ('owner');
290
291 my @ids = $book_owner_ids->all;
292
293 is (@ids, 6, 'Limit works');
294
295 my $book_owners = $schema->resultset ('Owners')->search ({
296 id => { -in => $book_owner_ids->as_query }
297 });
298
299 TODO: {
300 local $TODO = "Correlated limited IN subqueries will probably never preserve order";
301
302 is_deeply (
303 [ map { $_->id } ($book_owners->all) ],
304 [ $book_owner_ids->all ],
305 "$test_type: Sort is preserved across IN subqueries",
306 );
307 }
308 }
a54bd479 309
e56b1c2d 310 # still even with lost order of IN, we should be getting correct
311 # sets
312 {
313 my $owners = $schema->resultset ('Owners')->search ({}, { order_by => 'name', offset => 2, rows => 3, unsafe_subselect_ok => 1 });
314 my $corelated_owners = $owners->result_source->resultset->search (
315 {
316 id => { -in => $owners->get_column('id')->as_query },
317 },
318 {
319 order_by => 'name' #reorder because of what is shown above
320 },
321 );
322
323 is (
324 join ("\x00", map { $_->name } ($corelated_owners->all) ),
325 join ("\x00", map { $_->name } ($owners->all) ),
326 "$test_type: With an outer order_by, everything still matches",
327 );
328 }
a54bd479 329
e56b1c2d 330 # make sure right-join-side single-prefetch ordering limit works
331 {
332 my $rs = $schema->resultset ('BooksInLibrary')->search (
333 {
334 'owner.name' => { '!=', 'woggle' },
335 },
336 {
337 prefetch => 'owner',
338 order_by => 'owner.name',
339 }
340 );
341 # this is the order in which they should come from the above query
342 my @owner_names = qw/boggle fISMBoC fREW fRIOUX fROOH fRUE wiggle wiggle/;
343
344 is ($rs->all, 8, "$test_type: Correct amount of objects from right-sorted joined resultset");
345 is_deeply (
346 [map { $_->owner->name } ($rs->all) ],
347 \@owner_names,
348 "$test_type: Prefetched rows were properly ordered"
349 );
350
351 my $limited_rs = $rs->search ({}, {rows => 6, offset => 2, unsafe_subselect_ok => 1});
352 is ($limited_rs->count, 6, "$test_type: Correct count of limited right-sorted joined resultset");
353 is ($limited_rs->count_rs->next, 6, "$test_type: Correct count_rs of limited right-sorted joined resultset");
354
355 my $queries;
356 my $orig_debug = $schema->storage->debug;
357 $schema->storage->debugcb(sub { $queries++; });
358 $schema->storage->debug(1);
359
360 is_deeply (
361 [map { $_->owner->name } ($limited_rs->all) ],
362 [@owner_names[2 .. 7]],
363 "$test_type: Prefetch-limited rows were properly ordered"
364 );
365 is ($queries, 1, "$test_type: Only one query with prefetch");
366
367 $schema->storage->debugcb(undef);
368 $schema->storage->debug($orig_debug);
369
370 is_deeply (
371 [map { $_->name } ($limited_rs->search_related ('owner')->all) ],
372 [@owner_names[2 .. 7]],
373 "$test_type: Rows are still properly ordered after search_related",
374 );
375 }
a54bd479 376
e56b1c2d 377 # try a ->has_many direction with duplicates
378 my $owners = $schema->resultset ('Owners')->search (
379 {
380 'books.id' => { '!=', undef },
381 'me.name' => { '!=', 'somebogusstring' },
382 },
383 {
384 prefetch => 'books',
385 order_by => { -asc => \['name + ?', [ test => 'xxx' ]] }, # test bindvar propagation
386 group_by => [ map { "me.$_" } $schema->source('Owners')->columns ], # the literal order_by requires an explicit group_by
387 rows => 3, # 8 results total
388 unsafe_subselect_ok => 1,
389 },
390 );
a54bd479 391
e56b1c2d 392 my ($sql, @bind) = @${$owners->page(3)->as_query};
0e773352 393 is_same_bind (
e56b1c2d 394 \@bind,
395 [
fcb7fcbb 396 ($dialect eq 'Top' ? [ { dbic_colname => 'test' } => 'xxx' ] : ()), # the extra re-order bind
397 [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' }
398 => 'somebogusstring' ],
399 [ { dbic_colname => 'test' }
400 => 'xxx' ],
401 ($dialect ne 'Top' ? ( [ $OFFSET => 7 ], [ $TOTAL => 9 ] ) : ()), # parameterised RNO
402 [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'me.name' }
403 => 'somebogusstring' ],
404 [ { dbic_colname => 'test' }
405 => 'xxx' ],
e56b1c2d 406 ],
a54bd479 407 );
fb7cd45f 408
e56b1c2d 409 is ($owners->page(1)->all, 3, "$test_type: has_many prefetch returns correct number of rows");
410 is ($owners->page(1)->count, 3, "$test_type: has-many prefetch returns correct count");
a54bd479 411
e56b1c2d 412 is ($owners->page(3)->count, 2, "$test_type: has-many prefetch returns correct count");
413 TODO: {
414 local $TODO = "Top-limit does not work when your limit ends up past the resultset"
415 if $dialect eq 'Top';
416 is ($owners->page(3)->all, 2, "$test_type: has_many prefetch returns correct number of rows");
417 is ($owners->page(3)->count_rs->next, 2, "$test_type: has-many prefetch returns correct count_rs");
a54bd479 418 }
a54bd479 419
a54bd479 420
e56b1c2d 421 # try a ->belongs_to direction (no select collapse, group_by should work)
422 my $books = $schema->resultset ('BooksInLibrary')->search (
423 {
424 'owner.name' => [qw/wiggle woggle/],
425 },
426 {
427 distinct => 1,
428 having => \['1 = ?', [ test => 1 ] ], #test having propagation
429 prefetch => 'owner',
430 rows => 2, # 3 results total
431 order_by => { -desc => 'me.owner' },
432 unsafe_subselect_ok => 1,
433 },
434 );
6de07ea3 435
e56b1c2d 436 ($sql, @bind) = @${$books->page(3)->as_query};
0e773352 437 is_same_bind (
e56b1c2d 438 \@bind,
439 [
440 # inner
0e773352 441 [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
442 => 'wiggle' ],
443 [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
444 => 'woggle' ],
445 [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
446 => 'Library' ],
447 [ { dbic_colname => 'test' }
448 => '1' ],
449
fcb7fcbb 450 # rno(?)
451 $dialect ne 'Top' ? ( [ $OFFSET => 5 ], [ $TOTAL => 6 ] ) : (),
e56b1c2d 452 # outer
0e773352 453 [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
454 => 'wiggle' ],
455 [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'owner.name' }
456 => 'woggle' ],
457 [ { sqlt_datatype => 'varchar', sqlt_size => 100, dbic_colname => 'source' }
458 => 'Library' ],
e56b1c2d 459 ],
460 );
4bb438ca 461
e56b1c2d 462 is ($books->page(1)->all, 2, "$test_type: Prefetched grouped search returns correct number of rows");
463 is ($books->page(1)->count, 2, "$test_type: Prefetched grouped search returns correct count");
a54bd479 464
e56b1c2d 465 is ($books->page(2)->count, 1, "$test_type: Prefetched grouped search returns correct count");
466 TODO: {
467 local $TODO = "Top-limit does not work when your limit ends up past the resultset"
468 if $dialect eq 'Top';
469 is ($books->page(2)->all, 1, "$test_type: Prefetched grouped search returns correct number of rows");
470 is ($books->page(2)->count_rs->next, 1, "$test_type: Prefetched grouped search returns correct count_rs");
471 }
472 }
a54bd479 473 }
6de07ea3 474
475
a54bd479 476# test GUID columns
e56b1c2d 477 {
478 $schema->storage->dbh_do (sub {
479 my ($storage, $dbh) = @_;
480 eval { $dbh->do("DROP TABLE artist_guid") };
481 $dbh->do(<<'SQL');
b1bdb76d 482CREATE TABLE artist_guid (
a54bd479 483 artistid UNIQUEIDENTIFIER NOT NULL,
484 name VARCHAR(100),
485 rank INT NOT NULL DEFAULT '13',
486 charfield CHAR(10) NULL,
487 a_guid UNIQUEIDENTIFIER,
488 primary key(artistid)
489)
490SQL
e56b1c2d 491 });
8ff60918 492
e56b1c2d 493 # start disconnected to make sure insert works on an un-reblessed storage
494 $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts);
8ff60918 495
e56b1c2d 496 my $row;
497 lives_ok {
498 $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
499 } 'created a row with a GUID';
8ff60918 500
e56b1c2d 501 ok(
502 eval { $row->artistid },
503 'row has GUID PK col populated',
504 );
505 diag $@ if $@;
8ff60918 506
e56b1c2d 507 ok(
508 eval { $row->a_guid },
509 'row has a GUID col with auto_nextval populated',
510 );
511 diag $@ if $@;
8ff60918 512
e56b1c2d 513 my $row_from_db = $schema->resultset('ArtistGUID')
514 ->search({ name => 'mtfnpy' })->first;
f0bd60fc 515
e56b1c2d 516 is $row_from_db->artistid, $row->artistid,
517 'PK GUID round trip';
b9a2c3a5 518
e56b1c2d 519 is $row_from_db->a_guid, $row->a_guid,
520 'NON-PK GUID round trip';
521 }
02d133f0 522
a54bd479 523# test MONEY type
e56b1c2d 524 {
525 $schema->storage->dbh_do (sub {
526 my ($storage, $dbh) = @_;
527 eval { $dbh->do("DROP TABLE money_test") };
528 $dbh->do(<<'SQL');
a54bd479 529CREATE TABLE money_test (
530 id INT IDENTITY PRIMARY KEY,
531 amount MONEY NULL
532)
533SQL
e56b1c2d 534 });
9010bab8 535
9ffaf8a3 536 TODO: {
35af31a1 537 my $freetds_and_dynamic_cursors = 1
538 if $opts_name eq 'use_dynamic_cursors' &&
539 $schema->storage->using_freetds;
540
541 local $TODO =
9ffaf8a3 542'these tests fail on freetds with dynamic cursors for some reason'
35af31a1 543 if $freetds_and_dynamic_cursors;
544 local $ENV{DBIC_NULLABLE_KEY_NOWARN} = 1
545 if $freetds_and_dynamic_cursors;
56d2561e 546
9ffaf8a3 547 my $rs = $schema->resultset('Money');
548 my $row;
6bc666a5 549
9ffaf8a3 550 lives_ok {
551 $row = $rs->create({ amount => 100 });
552 } 'inserted a money value';
b9a2c3a5 553
9ffaf8a3 554 cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 100,
555 'money value round-trip');
fc85215b 556
9ffaf8a3 557 lives_ok {
558 $row->update({ amount => 200 });
559 } 'updated a money value';
b1e1d073 560
9ffaf8a3 561 cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 200,
562 'updated money value round-trip');
b1e1d073 563
9ffaf8a3 564 lives_ok {
565 $row->update({ amount => undef });
566 } 'updated a money value to NULL';
567
568 is try { $rs->find($row->id)->amount }, undef,
569 'updated money value to NULL round-trip';
570 }
e56b1c2d 571 }
572 }
384b8bce 573}
c1cac633 574
afcfff01 575done_testing;
576
c1cac633 577# clean up our mess
578END {
ca791b95 579 if (my $dbh = eval { $schema->storage->_dbh }) {
580 eval { $dbh->do("DROP TABLE $_") }
b1bdb76d 581 for qw/artist artist_guid money_test books owners/;
ca791b95 582 }
c1cac633 583}
fc85215b 584# vim:sw=2 sts=2