#!/usr/bin/perl -w -I./t
# $Id: rt_39841.t 12710 2009-04-20 15:21:32Z mjevans $
#
# Test fix for rt 39841 - problem with SQLDecribeParam in MS SQL Server
#
use Test::More;
use strict;
use Data::Dumper;
$| = 1;

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

# can't seem to get the imports right this way
use DBI qw(:sql_types);
#1
use_ok('ODBCTEST');

my $dbh;

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

END {
    if ($dbh) {
        eval {
            local $dbh->{PrintWarn} = 0;
            local $dbh->{PrintError} = 0;
            $dbh->do(q/drop table PERL_DBD_rt_39841a/);
            $dbh->do(q/drop table PERL_DBD_rt_39841b/);
        };
    }
    Test::NoWarnings::had_no_warnings()
          if ($has_test_nowarnings);
}

$dbh = DBI->connect();
unless($dbh) {
   BAIL_OUT("Unable to connect to the database $DBI::errstr\nTests skipped.\n");
   exit 0;
}
$dbh->{RaiseError} = 1;
my $dbms_name = $dbh->get_info(17);
#2
ok($dbms_name, "got DBMS name: $dbms_name");
my $dbms_version = $dbh->get_info(18);
#3
ok($dbms_version, "got DBMS version: $dbms_version");
my $driver_name = DBI::neat($dbh->get_info(6));

my ($ev, $sth);

SKIP: {
    skip "not SQL Server", 25 if $dbms_name !~ /Microsoft SQL Server/;
    skip "not SQL Server ODBC or native client driver", 25
        if ($driver_name !~ /SQLSRV32.DLL/oi) &&
            ($driver_name !~ /sqlncli10.dll/oi) &&
                ($driver_name !~ /SQLNCLI>DLL/oi);

    my $major_version = $dbms_version;

    eval {
        local $dbh->{PrintWarn} = 0;
        local $dbh->{PrintError} = 0;
        $dbh->do('drop table PERL_DBD_39841a');
        $dbh->do('drop table PERL_DBD_39841b');
    };

    test_1($dbh);       # 16 tests
    test_2($dbh);       # 9 tests
};

#
# A bug in the SQL Server OBDC driver causes SQLDescribeParam to
# report the parameter as an integer of column_size 10 instead of
# a varchar of column size 10. Thus when you execute with 'bbbbbb'
# SQL Server will complain that an unsupported conversion has occurred.
# We can work around this by specifically telling DBD::ODBC to bind
# as a VARCHAR.
# The bug is due to SQL Server rearranging the SQL above to:
# select a1 from PERL_DBD_38941a where 1 = 2
# and it should have run
# select b2 from PERL_DBD_38941b where 1 = 2
#
sub test_1
{
    $dbh = shift;
    my $sth;

    eval {
        $dbh->do('create table PERL_DBD_39841a (a1 integer, a2 varchar(20))');
        $dbh->do('create table PERL_DBD_39841b (b1 double precision, b2 varchar(8))');
    };
    $ev = $@;
    #1
    ok(!$ev, 'create test tables');

  SKIP: {
        skip "Failed to create test table", 10 if ($ev);
        eval {
            $dbh->do(q/insert into PERL_DBD_39841a values(1, 'aaaaaaaaaa')/);
            $dbh->do(q/insert into PERL_DBD_39841b values(1, 'bbbbbbbb')/);
        };
        $ev = $@;
        #2
        ok(!$ev, "populate tables");

        eval {
            $sth = $dbh->prepare(q/select b1, ( select a2 from PERL_DBD_39841a where a1 = b1 ) from PERL_DBD_39841b where b2 = ?/);
        };
        $ev = $@;
        #3
        ok(!$ev, 'prepare select');

      SKIP: {			# 13
	  skip 'cannot prepare SQL for test', 13 if $ev;
	  eval {
	      local $sth->{PrintError} = 0;
	      $sth->execute('bbbbbb');
	  };
	  my $ev = $@;

        SKIP: {			# 5
	    if ($ev) {
                diag($dbh->errstr);
		diag($dbh->state);
		if ($dbh->state eq '22018') {
                    diag("\nNOTE: Your SQL Server ODBC driver has a bug which can describe parameters\n");
                    diag("in SQL using sub selects incorrectly. In this case a VARCHAR(8) parameter\n");
                    diag("is described as an INTEGER\n\n");
		    skip 'test_1 execute failed - bug in SQL Server ODBC Driver', 5;
		} else {
		    skip 'test_1 execute failed with unexpected error', 5;
		}
            }
	    #1
            pass('test_1 execute');
	    #2
	    is($sth->{NUM_OF_PARAMS}, 1, 'correct number of parameters');
	    #diag(Dumper($sth->{ParamTypes}));
	    #3
	    is($sth->{NUM_OF_FIELDS}, 2, 'fields in result-set');
	    my $count;
	    eval {
		while($sth->fetchrow_array) {
		    $count = 0 if !defined($count);
		    $count++};
	    };
	    #4
	    ok(!$ev, "fetchrow_array");
	    #5
	    ok(!defined($count), "no rows returned");
	  };

	SKIP: {			# 8
	    skip "no bug found", 8 if !$ev;
	    skip "unexpected error this test is not checking for", 8
		if ($dbh->state ne '22018');
	    diag("Checking you can work around bug in SQL Server ODBC Driver");
	    eval {
		$sth->bind_param(1, 'bbbbbb', SQL_VARCHAR);
		$sth->execute;
	    };
	    $ev = $@;
	    if ($ev) {
		diag("No you cannot");
		skip "Cannot work around bug", 4;
	    } else {
		diag("Yes you can");
		#1
		is($sth->{NUM_OF_PARAMS}, 1, 'correct number of parameters');
		#2
		is($sth->{NUM_OF_FIELDS}, 2, 'fields in result-set');
		#diag(Dumper($sth->{ParamTypes}));
		my $pv = $sth->{ParamValues};
		#3
		ok(defined($pv), "Parameter values");
	      SKIP: {
          	  skip "no parameter values", 3 if !$pv;
		  #1
          	  is(ref($pv), 'HASH', 'parameter value hash');
		  #2
          	  ok(exists($pv->{1}), 'parameter 1 exists');
          	  SKIP: {
		      skip "no p1", 1 if !exists($pv->{1});
		      #1
		      is($pv->{1}, 'bbbbbb', 'parameter has right value');
          	  };
		};
		my $count;
		eval {
		    while($sth->fetchrow_array) {
			$count = 0 if !defined($count);
			$count++};
		};
		#4
		ok(!$ev, "fetchrow_array");
		#5
		ok(!defined($count), "no rows returned");
	    }
	  };
	};
    }
    eval {
        local $dbh->{PrintWarn} = 0;
        local $dbh->{PrintError} = 0;
        $dbh->do('drop table PERL_DBD_39841a');
        $dbh->do('drop table PERL_DBD_39841b');
    };
}

#
# Here SQL Server gets confused and rearranges the SQL to find out about
# PERL_DBD_39841a.a2 when it should have returned information about
# PERL_DBD_39841b.b2. This used to lead to DBD::ODBC binding p1 as
# 'bbbbbbbbbbbbbbbbbbbb' but specifying a column size of 10 - hence
# data truncation error.
#
sub test_2
{
    $dbh = shift;
    my $sth;

    eval {
	local $dbh->{PrintError} = 1;
        $dbh->do('create table PERL_DBD_39841a (a1 integer, a2 varchar(10))');
        $dbh->do('create table PERL_DBD_39841b (b1 varchar(10), b2 varchar(20))');
    };
    $ev = $@;
    #1
    ok(!$ev, 'create test tables');

  SKIP: {                       # 8
        skip "Failed to create test table", 8 if ($ev);
        eval {
            $dbh->do(q/insert into PERL_DBD_39841a values(1, 'aaaaaaaaaa')/);
            $dbh->do(q/insert into PERL_DBD_39841b values('aaaaaaaaaa', 'bbbbbbbbbbbbbbbbbbbb')/);
        };
        $ev = $@;
        #1 1
        ok(!$ev, "populate tables");

        eval {
            $sth = $dbh->prepare(q/select b1, ( select a2 from PERL_DBD_39841a where a2 = b1 ) from PERL_DBD_39841b where b2 = ?/);
        };
        $ev = $@;
        #1 2
        ok(!$ev, 'prepare select');

      SKIP: {			# 6
	  skip 'cannot prepare SQL for test', 6 if $ev;
	  eval {
	      local $sth->{PrintError} = 0;
	      $sth->execute('bbbbbbbbbbbbbbbbbbbb');
	  };
	  my $ev = $@;

        SKIP: {			# 5 + 1
	    if ($ev) {
                diag($dbh->errstr);
		diag($dbh->state);
		if ($dbh->state eq '22001') {
		    diag("Bug 39841 is back in some unexpected way");
		    diag("Please report this via rt");
		    #1
		    fail('test_1 execute');
		    skip 'Bug 39841 is back', 5;
		} else {
		    diag("Unexpected error - please report this via rt");
		    fail('test_1 execute');
		    #1
		    skip 'unexpected error', 5;
		}
            } else {
		#1
		pass('test_1 execute');
	    }
	    #2
	    is($sth->{NUM_OF_PARAMS}, 1, 'correct number of parameters');
	    #diag(Dumper($sth->{ParamTypes}));
	    #3
	    is($sth->{NUM_OF_FIELDS}, 2, 'fields in result-set');
	    my $count;
	    eval {
		while($sth->fetchrow_array) {
		    $count = 0 if !defined($count);
		    $count++};
	    };
	    #4
	    ok(!$ev, "fetchrow_array");
	    #5
	    ok(defined($count), "rows returned");
	  SKIP: {               # 1
	      skip "no rows returned", 1 if !defined($count);
	      # 6
	      is($count, 1, 'correct number of rows returned');
	    };
	  };
	};
    }
    eval {
        local $dbh->{PrintWarn} = 0;
        local $dbh->{PrintError} = 0;
        $dbh->do('drop table PERL_DBD_39841a');
        $dbh->do('drop table PERL_DBD_39841b');
    };
}