1use strict; 2use warnings; 3 4use Test::More; 5use Test::Exception; 6use Try::Tiny; 7 8use DBIx::Class::Optional::Dependencies (); 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 12use lib qw(t/lib); 13use DBICTest; 14 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 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 25DBICTest::Schema->load_classes('ArtistGUID'); 26my $schema = DBICTest::Schema->connect($dsn, $user, $pass); 27 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} 38 39isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server' ); 40 41{ 42 my $schema2 = $schema->connect (@{$schema->storage->connect_info}); 43 ok (! $schema2->storage->connected, 'a re-connected cloned schema starts unconnected'); 44} 45$schema->storage->_dbh->disconnect; 46 47lives_ok { 48 $schema->storage->dbh_do(sub { $_[1]->do('select 1') }) 49} '_ping works'; 50 51my %opts = ( 52 use_mars => 53 { opts => { on_connect_call => 'use_mars' } }, 54 use_dynamic_cursors => 55 { opts => { on_connect_call => 'use_dynamic_cursors' }, 56 required => $schema->storage->_using_freetds ? 0 : 1, 57 }, 58 use_server_cursors => 59 { opts => { on_connect_call => 'use_server_cursors' } }, 60 plain => 61 { opts => {}, required => 1 }, 62); 63 64for my $opts_name (keys %opts) { 65 SKIP: { 66 my $opts = $opts{$opts_name}{opts}; 67 $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts); 68 69 try { 70 $schema->storage->ensure_connected 71 } 72 catch { 73 if ($opts{$opts_name}{required}) { 74 die "on_connect_call option '$opts_name' is not functional: $_"; 75 } 76 else { 77 skip 78 "on_connect_call option '$opts_name' not functional in this configuration: $_", 79 1 80 ; 81 } 82 }; 83 84 $schema->storage->dbh_do (sub { 85 my ($storage, $dbh) = @_; 86 eval { $dbh->do("DROP TABLE artist") }; 87 $dbh->do(<<'SQL'); 88CREATE TABLE artist ( 89 artistid INT IDENTITY NOT NULL, 90 name VARCHAR(100), 91 rank INT NOT NULL DEFAULT '13', 92 charfield CHAR(10) NULL, 93 primary key(artistid) 94) 95SQL 96 }); 97 98# test Auto-PK 99 $schema->resultset('Artist')->search({ name => 'foo' })->delete; 100 101 my $new = $schema->resultset('Artist')->create({ name => 'foo' }); 102 103 ok(($new->artistid||0) > 0, "Auto-PK worked for $opts_name"); 104 105# Test multiple active statements 106 SKIP: { 107 skip 'not a multiple active statements configuration', 1 108 if $opts_name eq 'plain'; 109 110 $schema->storage->ensure_connected; 111 112 lives_ok { 113 114 no warnings 'redefine'; 115 local *DBI::connect = sub { die "NO RECONNECTS!!!" }; 116 117 my $artist_rs = $schema->resultset('Artist'); 118 119 $artist_rs->delete; 120 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 } 137 138 is_deeply \@result, \@map, "multiple active statements in $opts_name"; 139 140 $artist_rs->delete; 141 142 is($artist_rs->count, 0, '$dbh still viable'); 143 } "Multiple active statements survive $opts_name"; 144 } 145 146# Test populate 147 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'); 154CREATE TABLE books ( 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 162CREATE TABLE owners ( 163 id INT IDENTITY (1, 1) NOT NULL, 164 name VARCHAR(100), 165) 166SQL 167 }); 168 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' ); 226 } 227 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 250 { 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 } 271 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"); 276 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 [ sort map { $_->name } ($sealed_owners->all) ], 284 [ sort map { $_->name } ($owners->all) ], 285 "$test_type: Sort preserved from within a subquery", 286 ); 287 } 288 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 } 308 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 $schema->is_executed_querycount( sub { 335 is_deeply ( 336 [map { $_->owner->name } ($limited_rs->all) ], 337 [@owner_names[2 .. 7]], 338 "$test_type: Prefetch-limited rows were properly ordered" 339 ); 340 }, 1, "$test_type: Only one query with prefetch" ); 341 342 is_deeply ( 343 [map { $_->name } ($limited_rs->search_related ('owner')->all) ], 344 [@owner_names[2 .. 7]], 345 "$test_type: Rows are still properly ordered after search_related", 346 ); 347 } 348 349 # try a ->has_many direction with duplicates 350 my $owners = $schema->resultset ('Owners')->search ( 351 { 352 'books.id' => { '!=', undef }, 353 'me.name' => { '!=', 'somebogusstring' }, 354 }, 355 { 356 prefetch => 'books', 357 order_by => [ { -asc => \['name + ?', [ test => 'xxx' ]] }, 'me.id' ], # test bindvar propagation 358 group_by => [ map { "me.$_" } $schema->source('Owners')->columns ], # the literal order_by requires an explicit group_by 359 rows => 3, # 8 results total 360 unsafe_subselect_ok => 1, 361 }, 362 ); 363 364 is ($owners->page(1)->all, 3, "$test_type: has_many prefetch returns correct number of rows"); 365 is ($owners->page(1)->count, 3, "$test_type: has-many prefetch returns correct count"); 366 367 is ($owners->page(3)->count, 2, "$test_type: has-many prefetch returns correct count"); 368 { 369 local $TODO = "Top-limit does not work when your limit ends up past the resultset" 370 if $dialect eq 'Top'; 371 is ($owners->page(3)->all, 2, "$test_type: has_many prefetch returns correct number of rows"); 372 is ($owners->page(3)->count_rs->next, 2, "$test_type: has-many prefetch returns correct count_rs"); 373 } 374 375 376 # try a ->belongs_to direction (no select collapse, group_by should work) 377 my $books = $schema->resultset ('BooksInLibrary')->search ( 378 { 379 'owner.name' => [qw/wiggle woggle/], 380 }, 381 { 382 distinct => 1, 383 having => \['1 = ?', [ test => 1 ] ], #test having propagation 384 prefetch => 'owner', 385 rows => 2, # 3 results total 386 order_by => [{ -desc => 'me.owner' }, 'me.id'], 387 unsafe_subselect_ok => 1, 388 }, 389 ); 390 391 is ($books->page(1)->all, 2, "$test_type: Prefetched grouped search returns correct number of rows"); 392 is ($books->page(1)->count, 2, "$test_type: Prefetched grouped search returns correct count"); 393 394 is ($books->page(2)->count, 1, "$test_type: Prefetched grouped search returns correct count"); 395 { 396 local $TODO = "Top-limit does not work when your limit ends up past the resultset" 397 if $dialect eq 'Top'; 398 is ($books->page(2)->all, 1, "$test_type: Prefetched grouped search returns correct number of rows"); 399 is ($books->page(2)->count_rs->next, 1, "$test_type: Prefetched grouped search returns correct count_rs"); 400 } 401 } 402 } 403 404 405# test GUID columns 406 { 407 $schema->storage->dbh_do (sub { 408 my ($storage, $dbh) = @_; 409 eval { $dbh->do("DROP TABLE artist_guid") }; 410 $dbh->do(<<'SQL'); 411CREATE TABLE artist_guid ( 412 artistid UNIQUEIDENTIFIER NOT NULL, 413 name VARCHAR(100), 414 rank INT NOT NULL DEFAULT '13', 415 charfield CHAR(10) NULL, 416 a_guid UNIQUEIDENTIFIER, 417 primary key(artistid) 418) 419SQL 420 }); 421 422 # start disconnected to make sure insert works on an un-reblessed storage 423 $schema = DBICTest::Schema->connect($dsn, $user, $pass, $opts); 424 425 my $row; 426 lives_ok { 427 $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' }) 428 } 'created a row with a GUID'; 429 430 ok( 431 eval { $row->artistid }, 432 'row has GUID PK col populated', 433 ); 434 diag $@ if $@; 435 436 ok( 437 eval { $row->a_guid }, 438 'row has a GUID col with auto_nextval populated', 439 ); 440 diag $@ if $@; 441 442 my $row_from_db = $schema->resultset('ArtistGUID') 443 ->search({ name => 'mtfnpy' })->first; 444 445 is $row_from_db->artistid, $row->artistid, 446 'PK GUID round trip'; 447 448 is $row_from_db->a_guid, $row->a_guid, 449 'NON-PK GUID round trip'; 450 } 451 452# test MONEY type 453 { 454 $schema->storage->dbh_do (sub { 455 my ($storage, $dbh) = @_; 456 eval { $dbh->do("DROP TABLE money_test") }; 457 $dbh->do(<<'SQL'); 458CREATE TABLE money_test ( 459 id INT IDENTITY PRIMARY KEY, 460 amount MONEY NULL 461) 462SQL 463 }); 464 465 { 466 my $freetds_and_dynamic_cursors = 1 467 if $opts_name eq 'use_dynamic_cursors' && 468 $schema->storage->_using_freetds; 469 470 local $TODO = 471'these tests fail on freetds with dynamic cursors for some reason' 472 if $freetds_and_dynamic_cursors; 473 local $ENV{DBIC_NULLABLE_KEY_NOWARN} = 1 474 if $freetds_and_dynamic_cursors; 475 476 my $rs = $schema->resultset('Money'); 477 my $row; 478 479 lives_ok { 480 $row = $rs->create({ amount => 100 }); 481 } 'inserted a money value'; 482 483 cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 100, 484 'money value round-trip'); 485 486 lives_ok { 487 $row->update({ amount => 200 }); 488 } 'updated a money value'; 489 490 cmp_ok ((try { $rs->find($row->id)->amount })||0, '==', 200, 491 'updated money value round-trip'); 492 493 lives_ok { 494 $row->update({ amount => undef }); 495 } 'updated a money value to NULL'; 496 497 is try { $rs->find($row->id)->amount }, undef, 498 'updated money value to NULL round-trip'; 499 } 500 } 501 502# Test leakage of PK on implicit retrieval 503 { 504 505 my $next_owner = $schema->resultset('Owners')->get_column('id')->max + 1; 506 my $next_book = $schema->resultset('BooksInLibrary')->get_column('id')->max + 1; 507 508 cmp_ok( 509 $next_owner, 510 '!=', 511 $next_book, 512 'Preexisting auto-inc PKs staggered' 513 ); 514 515 my $yet_another_owner = $schema->resultset('Owners')->create({ name => 'YAO' }); 516 my $yet_another_book; 517 warnings_exist { 518 $yet_another_book = $yet_another_owner->create_related( books => { title => 'YAB' }) 519 } qr/Missing value for primary key column 'id' on BooksInLibrary - perhaps you forgot to set its 'is_auto_increment'/; 520 521 is( 522 $yet_another_owner->id, 523 $next_owner, 524 'Expected Owner id' 525 ); 526 527 is( 528 $yet_another_book->id, 529 $next_book, 530 'Expected Book id' 531 ); 532 } 533 } 534} 535 536done_testing; 537 538# clean up our mess 539END { 540 if (my $dbh = eval { $schema->storage->_dbh }) { 541 eval { $dbh->do("DROP TABLE $_") } 542 for qw/artist artist_guid money_test books owners/; 543 } 544 undef $schema; 545} 546# vim:sw=2 sts=2 547