t/747mssql_ado.t

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