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