t/747mssql_ado.t

   1 use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_mssql_ado';
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Exception;
   8 use Try::Tiny;
   9 use DBIx::Class::Optional::Dependencies ();
  10 use lib qw(t/lib);
  11 use DBICTest;
  12
  13 # Example DSN (from frew):
  14 # dbi:ADO:PROVIDER=sqlncli10;SERVER=tcp:172.24.2.10;MARS Connection=True;Initial Catalog=CIS;UID=cis_web;PWD=...;DataTypeCompatibility=80;
  15 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PASS/};
  16
  17 DBICTest::Schema->load_classes(qw/VaryingMAX ArtistGUID/);
  18
  19 my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
  20 $binstr{'large'} = $binstr{'small'} x 1024;
  21
  22 my $maxloblen = length $binstr{'large'};
  23
  24 my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
  25   auto_savepoint => 1,
  26   LongReadLen => $maxloblen,
  27 });
  28
  29 $schema->storage->ensure_connected;
  30
  31 isa_ok($schema->storage, 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server');
  32
  33 my $ver = $schema->storage->_server_info->{normalized_dbms_version};
  34
  35 ok $ver, 'can introspect DBMS version';
  36
  37 # 2005 and greater
  38 is $schema->storage->sql_limit_dialect, ($ver >= 9 ? 'RowNumberOver' : 'Top'),
  39   'correct limit dialect detected';
  40
  41 $schema->storage->dbh_do (sub {
  42     my ($storage, $dbh) = @_;
  43     try { local $^W = 0; $dbh->do("DROP TABLE artist") };
  44     $dbh->do(<<'SQL');
  45 CREATE TABLE artist (
  46    artistid INT IDENTITY NOT NULL,
  47    name VARCHAR(100),
  48    rank INT NOT NULL DEFAULT '13',
  49    charfield CHAR(10) NULL,
  50    primary key(artistid)
  51 )
  52 SQL
  53 });
  54
  55 $schema->storage->dbh_do (sub {
  56   my ($storage, $dbh) = @_;
  57   try { local $^W = 0; $dbh->do("DROP TABLE artist_guid") };
  58   $dbh->do(<<"SQL");
  59 CREATE TABLE artist_guid (
  60  artistid UNIQUEIDENTIFIER NOT NULL,
  61  name VARCHAR(100),
  62  rank INT NULL,
  63  charfield CHAR(10) NULL,
  64  a_guid UNIQUEIDENTIFIER,
  65  primary key(artistid)
  66 )
  67 SQL
  68 });
  69
  70 my $have_max = $ver >= 9; # 2005 and greater
  71
  72 $schema->storage->dbh_do (sub {
  73     my ($storage, $dbh) = @_;
  74     try { local $^W = 0; $dbh->do("DROP TABLE varying_max_test") };
  75     $dbh->do("
  76 CREATE TABLE varying_max_test (
  77    id INT IDENTITY NOT NULL,
  78 " . ($have_max ? "
  79    varchar_max VARCHAR(MAX),
  80    nvarchar_max NVARCHAR(MAX),
  81    varbinary_max VARBINARY(MAX),
  82 " : "
  83    varchar_max TEXT,
  84    nvarchar_max NTEXT,
  85    varbinary_max IMAGE,
  86 ") . "
  87    primary key(id)
  88 )");
  89 });
  90
  91 my $ars = $schema->resultset('Artist');
  92
  93 my $new = $ars->create({ name => 'foo' });
  94 ok($new->artistid > 0, 'Auto-PK worked');
  95
  96 # make sure select works
  97 my $found = $schema->resultset('Artist')->search({ name => 'foo' })->first;
  98 is $found->artistid, $new->artistid, 'search works';
  99
 100 # test large column list in select
 101 $found = $schema->resultset('Artist')->search({ name => 'foo' }, {
 102   select => ['artistid', 'name', map \"'foo' foo_$_", 0..50],
 103   as     => ['artistid', 'name', map        "foo_$_", 0..50],
 104 })->first;
 105 is $found->artistid, $new->artistid, 'select with big column list';
 106 is $found->get_column('foo_50'), 'foo', 'last item in big column list';
 107
 108 # create a few more rows
 109 for (1..12) {
 110   $schema->resultset('Artist')->create({ name => 'Artist ' . $_ });
 111 }
 112
 113 # test multiple active cursors
 114 my $rs1 = $schema->resultset('Artist')->search({}, { order_by => 'artistid' });
 115 my $rs2 = $schema->resultset('Artist')->search({}, { order_by => 'name' });
 116
 117 while ($rs1->next) {
 118   ok try { $rs2->next }, 'multiple active cursors';
 119 }
 120
 121 # test bug where ADO blows up if the first bindparam is shorter than the second
 122 is $schema->resultset('Artist')->search({ artistid => 2 })->first->name,
 123   'Artist 1',
 124   'short bindparam';
 125
 126 is $schema->resultset('Artist')->search({ artistid => 13 })->first->name,
 127   'Artist 12',
 128   'longer bindparam';
 129
 130 # test explicit key spec
 131 $new = $ars->create ({ name => 'bar', artistid => 66 });
 132 is($new->artistid, 66, 'Explicit PK worked');
 133 $new->discard_changes;
 134 is($new->artistid, 66, 'Explicit PK assigned');
 135
 136 # test basic transactions
 137 $schema->txn_do(sub {
 138   $ars->create({ name => 'transaction_commit' });
 139 });
 140 ok($ars->search({ name => 'transaction_commit' })->first,
 141   'transaction committed');
 142 $ars->search({ name => 'transaction_commit' })->delete,
 143 throws_ok {
 144   $schema->txn_do(sub {
 145     $ars->create({ name => 'transaction_rollback' });
 146     die 'rolling back';
 147   });
 148 } qr/rolling back/, 'rollback executed';
 149 is $ars->search({ name => 'transaction_rollback' })->first, undef,
 150   'transaction rolled back';
 151
 152 # test two-phase commit and inner transaction rollback from nested transactions
 153 $schema->txn_do(sub {
 154   $ars->create({ name => 'in_outer_transaction' });
 155   $schema->txn_do(sub {
 156     $ars->create({ name => 'in_inner_transaction' });
 157   });
 158   ok($ars->search({ name => 'in_inner_transaction' })->first,
 159     'commit from inner transaction visible in outer transaction');
 160   throws_ok {
 161     $schema->txn_do(sub {
 162       $ars->create({ name => 'in_inner_transaction_rolling_back' });
 163       die 'rolling back inner transaction';
 164     });
 165   } qr/rolling back inner transaction/, 'inner transaction rollback executed';
 166 });
 167 ok($ars->search({ name => 'in_outer_transaction' })->first,
 168   'commit from outer transaction');
 169 ok($ars->search({ name => 'in_inner_transaction' })->first,
 170   'commit from inner transaction');
 171 is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first,
 172   undef,
 173   'rollback from inner transaction';
 174 $ars->search({ name => 'in_outer_transaction' })->delete;
 175 $ars->search({ name => 'in_inner_transaction' })->delete;
 176
 177 # test populate
 178 lives_ok (sub {
 179   my @pop;
 180   for (1..2) {
 181     push @pop, { name => "Artist_$_" };
 182   }
 183   $ars->populate (\@pop);
 184 });
 185
 186 # test populate with explicit key
 187 lives_ok (sub {
 188   my @pop;
 189   for (1..2) {
 190     push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
 191   }
 192   $ars->populate (\@pop);
 193 });
 194
 195 # count what we did so far
 196 is ($ars->count, 18, 'Simple count works');
 197
 198 # test empty insert
 199 my $current_artistid = $ars->search({}, {
 200   select => [ { max => 'artistid' } ], as => ['artistid']
 201 })->first->artistid;
 202
 203 my $row;
 204 lives_ok { $row = $ars->create({}) }
 205   'empty insert works';
 206
 207 $row->discard_changes;
 208
 209 is $row->artistid, $current_artistid+1,
 210   'empty insert generated correct PK';
 211
 212 # test that autoinc column still works after empty insert
 213   $row = $ars->create({ name => 'after_empty_insert' });
 214
 215   is $row->artistid, $current_artistid+2,
 216     'autoincrement column functional aftear empty insert';
 217
 218 my $rs = $schema->resultset('VaryingMAX');
 219
 220 foreach my $size (qw/small large/) {
 221   local $schema->storage->{debug} = 0 if $size eq 'large';
 222
 223   my $str = $binstr{$size};
 224   my $row;
 225   lives_ok {
 226     $row = $rs->create({
 227       varchar_max => $str, nvarchar_max => $str, varbinary_max => $str
 228     });
 229   } "created $size VARXXX(MAX) LOBs";
 230
 231   lives_ok {
 232     $row->discard_changes;
 233   } 're-selected just-inserted LOBs';
 234
 235   cmp_ok try { $row->varchar_max },   'eq', $str, 'VARCHAR(MAX) matches';
 236   cmp_ok try { $row->nvarchar_max },  'eq', $str, 'NVARCHAR(MAX) matches';
 237   cmp_ok try { $row->varbinary_max }, 'eq', $str, 'VARBINARY(MAX) matches';
 238 }
 239
 240 # test regular blobs
 241
 242 try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE bindtype_test') };
 243 $schema->storage->dbh->do(qq[
 244 CREATE TABLE bindtype_test
 245 (
 246   id     INT IDENTITY NOT NULL PRIMARY KEY,
 247   bytea  INT NULL,
 248   blob   IMAGE NULL,
 249   clob   TEXT NULL,
 250   a_memo NTEXT NULL
 251 )
 252 ],{ RaiseError => 1, PrintError => 1 });
 253
 254 $rs = $schema->resultset('BindType');
 255 my $id = 0;
 256
 257 foreach my $type (qw( blob clob a_memo )) {
 258   foreach my $size (qw( small large )) {
 259     $id++;
 260
 261     lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
 262       "inserted $size $type without dying" or next;
 263
 264     my $from_db = eval { $rs->find($id)->$type } || '';
 265     diag $@ if $@;
 266
 267     ok($from_db eq $binstr{$size}, "verified inserted $size $type" )
 268       or do {
 269         my $hexdump = sub {
 270           join '', map sprintf('%02X', ord), split //, shift
 271         };
 272         diag 'Got: ', "\n", substr($hexdump->($from_db),0,255), '...',
 273           substr($hexdump->($from_db),-255);
 274         diag 'Size: ', length($from_db);
 275         diag 'Expected Size: ', length($binstr{$size});
 276         diag 'Expected: ', "\n",
 277           substr($hexdump->($binstr{$size}), 0, 255),
 278           "...", substr($hexdump->($binstr{$size}),-255);
 279       };
 280   }
 281 }
 282 # test IMAGE update
 283 lives_ok {
 284   $rs->search({ id => 0 })->update({ blob => $binstr{small} });
 285 } 'updated IMAGE to small binstr without dying';
 286
 287 lives_ok {
 288   $rs->search({ id => 0 })->update({ blob => $binstr{large} });
 289 } 'updated IMAGE to large binstr without dying';
 290
 291 # test GUIDs
 292 lives_ok {
 293   $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' })
 294 } 'created a row with a GUID';
 295
 296 ok(
 297   eval { $row->artistid },
 298   'row has GUID PK col populated',
 299 );
 300 diag $@ if $@;
 301
 302 my $guid = try { $row->artistid }||'';
 303
 304 ok(($guid !~ /^{.*?}\z/), 'GUID not enclosed in braces')
 305   or diag "GUID is: $guid";
 306
 307 ok(
 308   eval { $row->a_guid },
 309   'row has a GUID col with auto_nextval populated',
 310 );
 311 diag $@ if $@;
 312
 313 my $row_from_db = $schema->resultset('ArtistGUID')
 314   ->search({ name => 'mtfnpy' })->first;
 315
 316 is try { $row_from_db->artistid }, try { $row->artistid },
 317   'PK GUID round trip (via ->search->next)';
 318
 319 is try { $row_from_db->a_guid }, try { $row->a_guid },
 320   'NON-PK GUID round trip (via ->search->next)';
 321
 322 $row_from_db = try { $schema->resultset('ArtistGUID')
 323   ->find($row->artistid) };
 324
 325 is try { $row_from_db->artistid }, try { $row->artistid },
 326   'PK GUID round trip (via ->find)';
 327
 328 is try { $row_from_db->a_guid }, try { $row->a_guid },
 329   'NON-PK GUID round trip (via ->find)';
 330
 331 ($row_from_db) = $schema->resultset('ArtistGUID')
 332   ->search({ name => 'mtfnpy' })->all;
 333
 334 is try { $row_from_db->artistid }, try { $row->artistid },
 335   'PK GUID round trip (via ->search->all)';
 336
 337 is try { $row_from_db->a_guid }, try { $row->a_guid },
 338   'NON-PK GUID round trip (via ->search->all)';
 339
 340 lives_ok {
 341   $row = $schema->resultset('ArtistGUID')->create({
 342       artistid => '70171270-4822-4450-81DF-921F99BA3C06',
 343       name => 'explicit_guid',
 344   });
 345 } 'created a row with explicit PK GUID';
 346
 347 is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C06',
 348   'row has correct PK GUID';
 349
 350 lives_ok {
 351   $row->update({ artistid => '70171270-4822-4450-81DF-921F99BA3C07' });
 352 } "updated row's PK GUID";
 353
 354 is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C07',
 355   'row has correct PK GUID';
 356
 357 lives_ok {
 358   $row->delete;
 359 } 'deleted the row';
 360
 361 lives_ok {
 362   $schema->resultset('ArtistGUID')->populate([{
 363       artistid => '70171270-4822-4450-81DF-921F99BA3C06',
 364       name => 'explicit_guid',
 365   }]);
 366 } 'created a row with explicit PK GUID via ->populate in void context';
 367
 368 done_testing;
 369
 370 # clean up our mess
 371 END {
 372   local $SIG{__WARN__} = sub {};
 373   if (my $dbh = try { $schema->storage->_dbh }) {
 374     (try { $dbh->do("DROP TABLE $_") })
 375       for qw/artist artist_guid varying_max_test bindtype_test/;
 376   }
 377
 378   undef $schema;
 379 }
 380 # vim:sw=2 sts=2