t/746mssql.t

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