t/746mssql.t

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