t/746mssql.t

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