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