t/20SqlServer.t - metacpan.org

#!/usr/bin/perl -w -I./t
use Test::More;
use strict;

$| = 1;

my $has_test_nowarnings = 1;
eval "require Test::NoWarnings";
$has_test_nowarnings = undef if $@;
my $tests = 67;
$tests += 1 if $has_test_nowarnings;
plan tests => $tests;

my $dbh;

use DBI qw(:sql_types);
use DBI::Const::GetInfoType;

use_ok('ODBCTEST');

BEGIN {
    plan skip_all => "DBI_DSN is undefined" if (!defined $ENV{DBI_DSN});
}

END {
    # tidy up
    if ($dbh) {
        local $dbh->{PrintError} = 0;
        local $dbh->{PrintWarn} = 0;
        eval {
            $dbh->do(q/drop procedure PERL_DBD_PROC1/);
            $dbh->do(q/drop procedure PERL_DBD_PROC2/);
            $dbh->do(q/drop table PERL_DBD_TABLE1/);
        };
    }
    Test::NoWarnings::had_no_warnings()
          if ($has_test_nowarnings);
}

my $dbms_name;
my $dbms_version;
my $m_dbmsversion;
my $driver_name;

sub getinfo
{
    my $dbh = shift;

    $dbms_name = $dbh->get_info($GetInfoType{SQL_DBMS_NAME});
    ok($dbms_name, "got DBMS name: $dbms_name");
    $dbms_version = $dbh->get_info($GetInfoType{SQL_DBMS_VER});
    ok($dbms_version, "got DBMS version: $dbms_version");
    $m_dbmsversion = $dbms_version;
    $m_dbmsversion =~ s/^(\d+).*/$1/;
    ok($m_dbmsversion, "got DBMS major version: $m_dbmsversion");
    $driver_name = $dbh->get_info($GetInfoType{SQL_DRIVER_NAME});
    ok($driver_name, "got Driver Name: $driver_name");
}

sub varmax_test
{
    my ($dbh, $coltype) = @_;

  SKIP: {
        skip "SQL Server major version $m_dbmsversion too old", 4
            if $m_dbmsversion < 9;

        my $data = 'x' x 1000;
        my $datalen = length($data);
        local $dbh->{PrintError} = 0;
        local $dbh->{RaiseError} = 1;
        local $dbh->{LongReadLen} = length($data) * 2;

        eval {$dbh->do(q/drop table PERL_DBD_TABLE1/);};
        eval {
            $dbh->do(qq/create table PERL_DBD_TABLE1 (a int identity, b $coltype(MAX))/);
            # workaround freeTDS problem:
            if ($driver_name =~ /tdsodbc/) {
                $dbh->do( qq/insert into PERL_DBD_TABLE1 (b) values(CAST(? AS $coltype(MAX)))/, undef, $data);
            } else {
            $dbh->do(q/insert into PERL_DBD_TABLE1 (b) values(?)/,
                     undef, $data);
            }
        };
        diag($@) if $@;
        ok(!$@, "create PERL_DBD_TABLE1 and insert test data");
      SKIP: {
            skip "failed to create test table or insert data", 3 if $@;

            my $sth = $dbh->prepare(q/select a,b from PERL_DBD_TABLE1/);
            $sth->execute;
            my ($a, $b);
            eval {
                ($a, $b) = $sth->fetchrow_array;
            };
            diag($@) if $@;
            ok(!$@, "fetchrow for $coltype(max)");
          SKIP: {
                skip "fetchrow failed", 2 if $@;

                ok($b, "data received from $coltype(max)");
                is(length($b), $datalen,
                   'all data (' . length($b) . ") received from $coltype(max)");
            };
        };
    };
    eval {
        local $dbh->{PrintError} = 0;
        local $dbh->{RaiseError} = 0;
        $dbh->do(q/drop table PERL_DBD_TABLE1/);
    };
}

sub _do_proc
{
    my ($dbh, $proc) = @_;

    my $sth;

    eval {$sth = $dbh->prepare($proc, {odbc_exec_direct => 1})};
    my $ev = $@;
    diag($ev) if $ev;
    ok(!$ev, "prepare for $proc");

  SKIP: {
        skip "prepare for $proc failed", 3 if $ev;
      SKIP: {
            eval {$sth->execute};
            $ev = $@;
            diag($ev) if $ev;
            ok(!$ev, "execute for $proc");

          SKIP: {
                skip "execute for $proc failed", 2 if $ev;

                my $fields;
                eval {$fields = $sth->{NUM_OF_FIELDS}};
                $ev = $@;
                diag($ev) if $ev;
                ok(!$ev, "NUM_OF_FIELDS for $proc");
                like($fields, qr|^\d+$|, "numeric fields");
            };
            $sth->finish;
        };
    };
}

sub procs_with_no_results
{
    my $dbh = shift;

    local $dbh->{PrintError} = 0;

    eval {$dbh->do(q/drop procedure PERL_DBD_PROC1/)};
    eval {$dbh->do(q/drop procedure PERL_DBD_PROC2/)};

    my $proc1 = <<EOT;
create procedure PERL_DBD_PROC1 as
begin
select * from master..sysprocesses
delete from #tmp
end
EOT

    my $proc2 = <<EOT;
create procedure PERL_DBD_PROC2 as
begin
select * into #tmp from master..sysprocesses
delete from #tmp
end
EOT

    eval {$dbh->do($proc1)};
    my $ev = $@;
    diag($ev) if $ev;
    ok(!$ev, 'create perl_dbd_proc1 procedure');
  SKIP: {
        skip 'failed to create perl_dbd_proc1 procedure', 9 if $ev;

      SKIP: {
            eval {$dbh->do($proc2)};
            $ev = $@;
            diag($ev) if $ev;
            ok(!$ev, 'create perl_dbd_proc2 procedure');

          SKIP: {
                skip 'failed to create perl_dbd_proc2 procedure', 8 if $ev;

                _do_proc($dbh, 'PERL_DBD_PROC1');

                _do_proc($dbh, 'PERL_DBD_PROC2');
            };
        };
    };
}

sub Multiple_concurrent_stmts {
   my ($dbh, $expect) = @_;
   my $sth = $dbh->prepare("select * from PERL_DBD_TABLE1");
   $dbh->{RaiseError} = 1;
   $sth->execute;
   my @row;
   eval {
       while (@row = $sth->fetchrow_array()) {
           my $sth2 = $dbh->prepare("select * from $ODBCTEST::table_name");
           $sth2->execute;
           my @row2;
           while (@row2 = $sth2->fetchrow_array()) {
           }
       }
   };

   if ($@) {
       diag($@) if (defined($expect) && ($expect == 1));
       return 0;
   }
   diag("Expected fail of MARS and it worked!")
       if (defined($expect) && ($expect == 0));
   return 1;
}

$dbh = DBI->connect();
unless($dbh) {
   BAIL_OUT("Unable to connect to the database $DBI::errstr\nTests skipped.\n");
   exit 0;
}
my $sth;

my $dbname = $dbh->get_info($GetInfoType{SQL_DBMS_NAME});
SKIP: {
   skip "Microsoft SQL Server tests not supported using $dbname", 66
       unless ($dbname =~ /Microsoft SQL Server/i);

   getinfo($dbh);

   varmax_test($dbh, 'varchar');
   varmax_test($dbh, 'varbinary');
   varmax_test($dbh, 'nvarchar');

   procs_with_no_results($dbh);

   # the times chosen below are VERY specific to NOT cause rounding errors,
   # but may cause different errors on different versions of SQL Server.
   my @data = (
	       [undef, "z" x 13 ],
	       ["2001-01-01 01:01:01.110", "a" x 12],   # "aaaaaaaaaaaa"
	       ["2002-02-02 02:02:02.123", "b" x 114],
	       ["2003-03-03 03:03:03.333", "c" x 251],
	       ["2004-04-04 04:04:04.443", "d" x 282],
	       ["2005-05-05 05:05:05.557", "e" x 131]
	      );

   eval {
      local $dbh->{PrintError} = 0;
      $dbh->do("DROP TABLE PERL_DBD_TABLE1");
   };

   $dbh->{RaiseError} = 1;
   $dbh->{LongReadLen} = 800;

   my @types = (SQL_TYPE_TIMESTAMP, SQL_TIMESTAMP);
   my $row = $dbh->type_info(\@types);
   BAIL_OUT("Unable to find a suitable test type for date field") if !$row;
   my $datetype = $row->{TYPE_NAME};
   $dbh->do("CREATE TABLE PERL_DBD_TABLE1 (i INTEGER, time $datetype, str VARCHAR(4000))");


   # Insert records into the database:
   my $sth1 = $dbh->prepare("INSERT INTO PERL_DBD_TABLE1 (i,time,str) values (?,?,?)");
   for (my $i=0; $i<@data; $i++) {
      my ($time,$str) = @{$data[$i]};
      # print "Inserting:  $i, ";
      # print  $time if (defined($time));
      # print " string length " . length($str) . "\n";
      $sth1->bind_param (1, $i,    SQL_INTEGER);
      $sth1->bind_param (2, $time, SQL_TIMESTAMP);
      $sth1->bind_param (3, $str,  SQL_LONGVARCHAR);
      $sth1->execute  or die ($DBI::errstr);
   }

   # Retrieve records from the database, and see if they match original data:
   my $sth2 = $dbh->prepare("SELECT i,time,str FROM PERL_DBD_TABLE1");
   $sth2->execute  or die ($DBI::errstr);
   my $iErrCount = 0;
   while (my ($i,$time,$str) = $sth2->fetchrow_array()) {
       if (defined($time)) {
           $time =~ s/0000$//o;
       }
      if ((defined($time) && $time ne $data[$i][0]) ||
              defined($time) != defined($data[$i][0])) {
	 diag("Retrieving: $i, $time string length: " . length($str) . "\t!time ");
	 $iErrCount++;
      }

      if ($str  ne $data[$i][1]) {
	 diag("Retrieving: $i, $time string length: " . length($str) . "\t!string ");
	 $iErrCount++;
      }
      # print "\n";
   }
   is($iErrCount, 0, "errors on data comparison");


   eval {
      local $dbh->{RaiseError} = 0;
      $dbh->do("DROP TABLE PERL_DBD_TABLE1");
   };

   my $sql = 'CREATE TABLE #PERL_DBD_TABLE1 (id INT PRIMARY KEY, val VARCHAR(4))';
   $dbh->do($sql);
   # doesn't work with prepare, etc...hmmm why not?
   # $sth = $dbh->prepare($sql);
   # $sth->execute;
   # $sth->finish;
   # See http://technet.microsoft.com/en-US/library/ms131667.aspx
   # which says
   # "Prepared statements cannot be used to create temporary objects on SQL
   # Server 2000 or later..."
   #
   $sth = $dbh->prepare("INSERT INTO #PERL_DBD_TABLE1 (id, val) VALUES (?, ?)");
   $sth2 = $dbh->prepare("INSERT INTO #PERL_DBD_TABLE1 (id, val) VALUES (?, ?)");
   my @data2 = (undef, 'foo', 'bar', 'blet', undef);
   my $i = 0;
   my $val;
   foreach $val (@data2) {
      $sth2->execute($i++, $val);
   }
   $i = 0;
   $sth = $dbh->prepare("Select id, val from #PERL_DBD_TABLE1");
   $sth->execute;
   $iErrCount = 0;
   while (my @row = $sth->fetchrow_array) {
      unless ((!defined($row[1]) && !defined($data2[$i])) || ($row[1] eq $data2[$i])) {
	 $iErrCount++ ;
	 print "$row[1] ne $data2[$i]\n";
      }
      $i++;
   }

   is($iErrCount, 0, "temporary table handling");
   diag("Please upgrade your ODBC drivers to the latest SQL Server drivers available.  For example, 2000.80.194.00 is known to be problematic.  Use MDAC 2.7, if possible\n") if ($iErrCount != 0);

   $dbh->{PrintError} = 0;
   eval {$dbh->do("DROP TABLE PERL_DBD_TABLE1");};
   eval {$dbh->do("CREATE TABLE PERL_DBD_TABLE1 (i INTEGER)");};

   eval {$dbh->do("DROP PROCEDURE PERL_DBD_PROC1");};
   eval {$dbh->do("CREATE PROCEDURE PERL_DBD_PROC1 \@inputval int AS ".
		  "INSERT INTO PERL_DBD_TABLE1 VALUES (\@inputval); " .
		  "	return \@inputval;");};


   $sth1 = $dbh->prepare ("{? = call PERL_DBD_PROC1(?) }");
   my $output = undef;
   $i = 1;
   $iErrCount = 0;
   while ($i < 4) {
      $sth1->bind_param_inout(1, \$output, 50, DBI::SQL_INTEGER);
      $sth1->bind_param(2, $i, DBI::SQL_INTEGER);

      $sth1->execute();
      # print "$output";
      if (!defined($output) || ($output !~ /\d+/) || ($output != $i)) {
	 $iErrCount++;
	 diag("output='$output' error, expected $i\n");
      }
      # print "\n";
      $i++;
   }

   is($iErrCount, 0, "bind param in out with insert result set");
   $iErrCount = 0;
   eval {$dbh->do("DROP PROCEDURE PERL_DBD_PROC1");};
   my $proc1 =
	      "CREATE PROCEDURE PERL_DBD_PROC1 (\@i int, \@result int OUTPUT) AS ".
	      "BEGIN ".
	      "    SET \@result = \@i+1;".
	      "END ";
   # print "$proc1\n";
   $dbh->do($proc1);

   # $dbh->{PrintError} = 1;
   $sth1 = $dbh->prepare ("{call PERL_DBD_PROC1(?, ?)}");
   $i = 12;
   $output = undef;
   $sth1->bind_param(1, $i, DBI::SQL_INTEGER);
   $sth1->bind_param_inout(2, \$output, 100, DBI::SQL_INTEGER);
   $sth1->execute;
   is($i, $output-1, "test output params accurate");

   $iErrCount = 0;
   $sth = $dbh->prepare("select * from PERL_DBD_TABLE1 order by i");
   $sth->execute;
   $i = 1;
   while (my @row = $sth->fetchrow_array) {
      if ($i != $row[0]) {
	 diag(join(', ', @row), " ERROR!\n");
	 $iErrCount++;
      }
      $i++;
   }


   is($iErrCount, 0, "verify select data");

   eval {$dbh->do("DROP TABLE PERL_DBD_TABLE1");};
   eval {$dbh->do("CREATE TABLE PERL_DBD_TABLE1 (d DATETIME)");};
   $sth = $dbh->prepare ("INSERT INTO PERL_DBD_TABLE1 (d) VALUES (?)");
   $sth->bind_param (1, undef, SQL_TYPE_TIMESTAMP);
   $sth->execute();
   $sth->bind_param (1, "2002-07-12 05:08:37.350", SQL_TYPE_TIMESTAMP);
   $sth->execute();
   $sth->bind_param (1, undef, SQL_TYPE_TIMESTAMP);
   $sth->execute();

   $iErrCount = 0;
   $sth2 = $dbh->prepare("select * from PERL_DBD_TABLE1 where d is not null");
   $sth2->execute;
   while (my @row = $sth2->fetchrow_array) {
      if ($row[0] ne "2002-07-12 05:08:37.350") {
	 $iErrCount++ ;
	 diag(join(", ", @row), "\n");
      }
   }
   is($iErrCount, 0, "timestamp handling");

   eval {$dbh->do('DROP TABLE PERL_DBD_TABLE1');};
   eval {$dbh->do('DROP PROCEDURE PERL_DBD_PROC1');};

   eval {$dbh->do('CREATE TABLE PERL_DBD_TABLE1 (i INTEGER, j integer)')}
   or diag($@);

   $proc1 = <<EOT;
CREATE PROCEDURE PERL_DBD_PROC1 (\@i INT) AS
DECLARE \@result INT;
BEGIN
   SET \@result = \@i;
   IF (\@i = 99)
      BEGIN
	 UPDATE PERL_DBD_TABLE1 SET i=\@i;
	 SET \@result = \@i + 1;
      END;
   SELECT \@result;
END
EOT
   $dbh->{RaiseError} = 0;
   # NOTE: MS SQL native client for linux fails this test because
   # SQLExecute returns SQL_NO_DATA even though the proc never did
   # a searched update/delete - AND it works on the same Windows driver.
   eval {$dbh->do($proc1)} or diag($@);
   my $sth = $dbh->prepare ('{call PERL_DBD_PROC1 (?)}');
   my $success = -1;

   $sth->bind_param (1, 99, SQL_INTEGER);
   my $cres = $sth->execute();
   ok(defined($cres), "execute for non searched update via procedure");
   if (!defined($cres)) {
       note("Your driver has a bug which means it is probably incorrectly returning SQL_NO_DATA from a non-searched update");
   }
 SKIP: {
       skip "execute failed - probably SQL_NO_DATA bug", 4 if !defined($cres);
       ok($cres eq '0E0' || $cres == -1, "0/unknown rows updated");

       $success = -1;
       while (my @data = $sth->fetchrow_array()) {($success) = @data;}
       is($success, 100, 'procedure outputs results as result set');

       $sth->bind_param (1, 10, SQL_INTEGER);
       $sth->execute();
       $success = -1;
       while (my @data = $sth->fetchrow_array()) {($success) = @data;}
       is($success,10, 'procedure outputs results as result set2');

       $sth->bind_param (1, 111, SQL_INTEGER);
       $sth->execute();
       $success = -1;
       do {
           my @data;
           while (@data = $sth->fetchrow_array()) {
               if ($#data == 0) {
                   ($success) = @data;
               }
           }
       } while ($sth->{odbc_more_results});
       is($success, 111, 'procedure outputs results as result set 3');
   };

   #
   # special tests for even stranger cases...
   #
   eval {$dbh->do("DROP PROCEDURE PERL_DBD_PROC1");};
   $proc1 = <<EOT;
   CREATE PROCEDURE PERL_DBD_PROC1 (\@i INT) AS
   DECLARE \@result INT;
   BEGIN
   SET \@result = \@i;
   IF (\@i = 99)
      BEGIN
	 UPDATE PERL_DBD_TABLE1 SET i=\@i;
	 SET \@result = \@i + 1;
      END;
   IF (\@i > 100)
      BEGIN
	 INSERT INTO PERL_DBD_TABLE1 (i, j) VALUES (\@i, \@i);
	 SELECT i, j from PERL_DBD_TABLE1;
      END;
   SELECT \@result;
   END
EOT

   eval {$dbh->do($proc1);};

   # set the required attribute and check it.
   $dbh->{odbc_force_rebind} = 1;
   is($dbh->{odbc_force_rebind}, 1, "setting force_rebind");
   $dbh->{odbc_force_rebind} = 0;
   is($dbh->{odbc_force_rebind}, 0, "resetting force_rebind");

   $sth = $dbh->prepare ("{call PERL_DBD_PROC1 (?)}");
   is($sth->{odbc_force_rebind}, 0, "testing force rebind after procedure call");
   $success = -1;

   $sth->bind_param (1, 99, SQL_INTEGER);
   $cres = $sth->execute();
   ok(defined($cres), "execute for non searched update via procedure, force_rebind");
   if (!defined($cres)) {
       note("Your driver has a bug which means it is probably incorrectly returning SQL_NO_DATA from a non-searched update");
   }
 SKIP: {
       skip "execute failed - probably SQL_NO_DATA bug", 3 if !defined($cres);
       $success = -1;
       while (my @data = $sth->fetchrow_array()) {($success) = @data;}
       is($success, 100, "force rebind test part 2");

       $sth->bind_param (1, 10, SQL_INTEGER);
       $sth->execute();
       $success = -1;
       while (my @data = $sth->fetchrow_array()) {($success) = @data;}
       is($success, 10, "force rebind test part 3");

       $sth->bind_param (1, 111, SQL_INTEGER);
       $sth->execute();
       $success = -1;
       do {
           my @data;
           while (@data = $sth->fetchrow_array()) {
               if ($#data == 0) {
                   ($success) = @data;
               } else {
                   # diag("Data: ", join(',', @data), "\n");
               }
           }
       } while ($sth->{odbc_more_results});
       is($success, 111, "force rebind test part 4");

       # ensure the attribute is automatically set.
       # the multiple result sets will trigger this.
       is($sth->{odbc_force_rebind}, 1, "forced rebind final");
   }

   #
   # more special tests
   # make sure output params are being set properly when
   # multiple result sets are available.  Also, ensure fetchrow_hashref
   # works with multiple statements.
   #
   eval {$dbh->do("DROP PROCEDURE PERL_DBD_PROC1");};
   $dbh->do("CREATE PROCEDURE  PERL_DBD_PROC1
\@parameter1 int = 22
AS
	/* SET NOCOUNT ON */
	select 1 as some_data
	select isnull(\@parameter1, 0) as parameter1, 3 as some_more_data
	RETURN(\@parameter1 + 1)");

   my $queryInputParameter1 = 2222;
   my $queryOutputParameter = 0;

   $sth = $dbh->prepare('{? = call PERL_DBD_PROC1(?) }');
   $sth->bind_param_inout(1, \$queryOutputParameter, 30, { TYPE => DBI::SQL_INTEGER });
   $sth->bind_param(2, $queryInputParameter1, { TYPE => DBI::SQL_INTEGER });

   $sth->execute();

   do {
      for(my $rowRef; $rowRef = $sth->fetchrow_hashref('NAME'); )  {
	 my %outputData = %$rowRef;
	 if (defined($outputData{some_data})) {
	    is($outputData{some_data},1,"Select data available");
	    ok(!defined($outputData{parameter1}), "output param not yet available");
	    ok(!defined($outputData{some_more_data}), "output param not yet available2");
	 } else {
	    is($outputData{parameter1},2222, "Output param data available");
	    is($outputData{some_more_data},3, "Output param data available 2");
	    ok(!defined($outputData{some_data}), "select data done");
	 }
	 # diag('outputData ', Dumper(\%outputData), "\n");
      }
      # print "out of for loop\n";
   } while($sth->{odbc_more_results});
   # print "out of while loop\n";
   is($queryOutputParameter, $queryInputParameter1 + 1, "valid output data");

   # test a procedure with no parameters
   eval {$dbh->do("DROP PROCEDURE PERL_DBD_PROC1");};
   eval {$dbh->do("CREATE PROCEDURE PERL_DBD_PROC1 AS return 1;");};

   $sth1 = $dbh->prepare ("{ ? = call PERL_DBD_PROC1 }");
   $output = undef;
   $iErrCount = 0;
   $sth1->bind_param_inout(1, \$output, 50, DBI::SQL_INTEGER);

   $sth1->execute();
   is($output, 1, "test procedure with no input params");
   $sth1 = undef;		# could still be active with some drivers

   $dbh->{odbc_async_exec} = 1;
   # print "odbc_async_exec is: $dbh->{odbc_async_exec}\n";
   is($dbh->{odbc_async_exec}, 1, "test odbc_async_exec attribute set");

   # not sure if this should be a test.  May have permissions problems, but
   # it's the only sample of the error handler stuff I have.
   my $testpass = 0;
   my $lastmsg;

   sub err_handler {
      my ($state, $msg, $nativeerr) = @_;
      # Strip out all of the driver ID stuff
      # normally something like [SQL Server Native Client 10.0][SQL Server]
      $msg =~ s/^(\[[\w\s:\.]*\])+//;
      $lastmsg = $msg;
      #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.\n\n");
           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;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)