view release on metacpan or  search on metacpan

t/20SqlServer.t  view on Meta::CPAN

      #diag "===> state: $state msg: $msg nativeerr: $nativeerr\n";
      $testpass++;
      return 0;
   }

   $dbh->{odbc_err_handler} = \&err_handler;

   $sth = $dbh->prepare("dbcc TRACESTATUS(0)");
   $sth->execute;
   cmp_ok($testpass, '>', 0, "dbcc messages being returned");
   $testpass = 0;
   $dbh->{odbc_async_exec} = 0;
   is($dbh->{odbc_async_exec}, 0, "reset async exec");

   $dbh->do(q/delete from PERL_DBD_TABLE1/);
   $dbh->do(q/insert into PERL_DBD_TABLE1 values(1, 1)/);
   $dbh->{odbc_exec_direct} = 1;
   is($dbh->{odbc_exec_direct}, 1, "test setting odbc_exec_direct");
   $sth2 = $dbh->prepare("print 'START' select count(*) from PERL_DBD_TABLE1 print 'END'");
   $sth2->execute;
   do {
      while (my @row = $sth2->fetchrow_array) {
	 is($row[0], 1, "Valid select results with print statements");
      }
   } while ($sth2->{odbc_more_results});

   is($testpass,2, "ensure 2 error messages from two print statements");
   is($lastmsg, 'END', "validate error messages being retrieved");

   # need the finish if there are print statements (for now)
   #$sth2->finish;
   $dbh->{odbc_err_handler} = undef;
   # We need to make sure there is sufficient data returned to
   # overflow the TDS buffer. If all the results fit into one buffer
   # the tests checking for MAS not working work succeed.
   for (my $i = 1; $i < 1000; $i += 2) {
       $dbh->do('insert into PERL_DBD_TABLE1 (i, j) values (?, ?)', undef, $i, $i+1);
   }
   #$dbh->do("insert into PERL_DBD_TABLE1 (i, j) values (1, 2)");
   #$dbh->do("insert into PERL_DBD_TABLE1 (i, j) values (3, 4)");

   $dbh->disconnect;

   my $dsn = $ENV{DBI_DSN};
   if ($dsn !~ /^dbi:ODBC:DSN=/ && $dsn !~ /DRIVER=/i) {
       my @a = split(q/:/, $ENV{DBI_DSN});
       $dsn = join(q/:/, @a[0..($#a - 1)]) . ":DSN=" . $a[-1];
   }
   my $base_dsn = $dsn;
   $dsn .= ";MARS_Connection=no";
   $dbh = DBI->connect($dsn, $ENV{DBI_USER}, $ENV{DBI_PASS}, {PrintError => 0});
   ok($dbh, "Connected with MARS_Connection");
   diag("$DBI::errstr\n$dsn\n") if !$dbh;
 SKIP: {
       skip "could not connect with MARS_Connection attribute", 1 if !$dbh;

       ok(!&Multiple_concurrent_stmts($dbh, 0), "Multiple concurrent statements should fail");
       $dbh->disconnect;
   };

   $dbh = DBI->connect($dsn, $ENV{DBI_USER}, $ENV{DBI_PASS}, { odbc_cursortype => 2, PrintError => 0 });
   # $dbh->{odbc_err_handler} = \&err_handler;
   ok(&Multiple_concurrent_stmts($dbh, 1), "Multiple concurrent statements succeed (odbc_cursortype set)");

 SKIP: {
       skip "MS SQL Server version < 9", 1 if ($m_dbmsversion < 9);
       $dbh->disconnect; # throw away non-mars connection
       $dsn = "$base_dsn;MARS_Connection=yes;";
       $dbh = DBI->connect($dsn, $ENV{DBI_USER}, $ENV{DBI_PASS}, {PrintError => 0});
       my $tst = "Multiple concurrent statements succeed with MARS";
       if (&Multiple_concurrent_stmts($dbh,1)) {
           pass($tst);
       } else {
           diag("DSN=$dsn\n");
           diag("\nNOTE: You failed this test because your SQL Server driver\nis too old to handle the MARS_Connection attribute. This test cannot\neasily skip this test for old drivers as there is no definite SQL Server\ndriver version it can check....
           skip 'WARNING: driver does NOT support MARS_Connection', 1;
       }
       $dbh->disconnect; # throw away mars connection
       $dbh = DBI->connect;
   }

   # clean up test table and procedure
   # reset err handler
   # $dbh->{odbc_err_handler} = undef;
   eval {$dbh->do("DROP TABLE PERL_DBD_TABLE1");};
   eval {$dbh->do("DROP PROCEDURE PERL_DBD_PROC1");};

   eval { local $dbh->{PrintError} = 0; $dbh->do("drop table perl_dbd_test1"); };
   $dbh->do("create table perl_dbd_test1 (i integer primary key, t varchar(30))");
   $dbh->{AutoCommit} = 0;
   $dbh->do("insert into perl_dbd_test1 (i, t) values (1, 'initial')");
   $dbh->commit;
   $dbh->do("update perl_dbd_test1 set t = 'second' where i = 1");

   my $dbh2 = DBI->connect($ENV{DBI_DSN}, $ENV{DBI_USER}, $ENV{DBI_PASS}, {odbc_query_timeout => 2, PrintError=>0});
   # $dbh2->{odbc_query_timeout} = 5;
   $dbh2->{AutoCommit} = 0;
   $dbh2->do("update perl_dbd_test1 set t = 'bad' where i = ?",undef,1);
   $dbh2->rollback;
   # should timeout and get to here.  if so, test will pass
   pass("passed timeout on query using odbc_query_timeout using do with bind params");
   $dbh2->do("update perl_dbd_test1 set t = 'bad' where i = 1");
   $dbh2->rollback;
   $dbh2->disconnect;
   pass("passed timeout on query using odbc_query_timeout using do without bind params");
   $dbh->commit;
   $dbh->do("drop table perl_dbd_test1");
   $dbh->commit;

};

$dbh->disconnect;


exit 0;
# get rid of use once warnings
print $DBI::errstr;
print $ODBCTEST::table_name;