t/746mssql.t

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