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