#!perl -w

use DBI;
use DBD::Oracle qw(:ora_types ORA_OCI);
use Data::Dumper;
use Math::BigInt;
use strict;

unshift @INC ,'t';
require 'nchar_test_lib.pl';

sub ok ($$;$);

$| = 1;
my $t = 0;
my $failed = 0;
my %ocibug;
my $table = "dbd_ora__drop_me" . ($ENV{DBD_ORACLE_SEQ}||'');


my $dsn = oracle_test_dsn();
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbh = DBI->connect($dsn, $dbuser, '', {
	AutoCommit => 1,
	PrintError => 0,
});

unless($dbh) {
    warn "Unable to connect to Oracle ($DBI::errstr)\nTests skiped.\n";
    print "1..0\n";
    exit 0;
}

my $utf8_test = ($] >= 5.006)
	&& client_ochar_is_utf8() # for correct output (utf8 bind vars should be fine regardless)
	&& ($dbh->ora_can_unicode() & 2);
print "Including unicode test\n" if $utf8_test;

unless(create_test_table("str CHAR(10)", 1)) {
    warn "Unable to create test table ($DBI::errstr)\nTests skiped.\n";
    print "1..0\n";
    exit 0;
}


my @test_sets = (
	[ "CHAR(10)",     10 ],
	[ "VARCHAR(10)",  10 ],
	[ "VARCHAR2(10)", 10 ],
);

# Set size of test data (in 10KB units)
#	Minimum value 3 (else tests fail because of assumptions)
#	Normal  value 8 (to test 64KB threshold well)
my $sz = 8;

my $tests = 3;
my $tests_per_set = 11;
$tests += @test_sets * $tests_per_set;
print "1..$tests\n";

my($sth, $p1, $p2, $tmp, @tmp);
#$dbh->trace(4);

foreach (@test_sets) {
    run_select_tests( @$_ );
}


sub run_select_tests {
  my ($type_name, $field_len) = @_;
  
  my $data0;
  if ($utf8_test) {
    $data0 = eval q{ "0\x{263A}xyX" }; #this includes the smiley from perlunicode (lab) BTW: it is busted
  } else {
    $data0 = "0\177x\0X";
  }
  my $data1 = "1234567890";
  my $data2 = "2bcdefabcd";
  
  if (!create_test_table("lng $type_name", 1)) {
    # typically OCI 8 client talking to Oracle 7 database
    warn "Unable to create test table for '$type_name' data ($DBI::err). Tests skipped.\n";
    foreach (1..$tests_per_set) { ok(0, 1) }
    return;
  }
  
  print " --- insert some $type_name data\n";
  ok(0, $sth = $dbh->prepare("insert into $table values (?, ?, SYSDATE)"), 1);
  ok(0, $sth->execute(40, $data0), 1);
  ok(0, $sth->execute(Math::BigInt->new(41), $data1), 1); # bind an overloaded value
  ok(0, $sth->execute(42, $data2), 1);

  print " --- try to insert a string that's too long\n";
  ok(0, !$sth->execute(43, "12345678901234567890"), 1);
  
  print " --- fetch $type_name data back again\n";
  
  ok(0, $sth = $dbh->prepare("select * from $table order by idx"), 1);
  ok(0, $sth->execute, 1);
  ok(0, $tmp = $sth->fetchall_arrayref, 1);
  # allow for padded blanks
  ok(0, $tmp->[0][1] =~ m/$data0/,
     cdif($tmp->[0][1], $data0, "Len ".length($tmp->[0][1])) );
  ok(0, $tmp->[1][1] =~ m/$data1/,
     cdif($tmp->[1][1], $data1, "Len ".length($tmp->[1][1])) );
  ok(0, $tmp->[2][1] =~ m/$data2/,
     cdif($tmp->[2][1], $data2, "Len ".length($tmp->[2][1])) );
  
  
} # end of run_select_tests

  my $ora_server_version = $dbh->func("ora_server_version");
  if ($ora_server_version->[0] < 10) {
    ok(0, 1, 1); # skip
  } else {
    my $data = $dbh->selectrow_array(q!
       select to_dsinterval(?) from dual
       !, {}, "1 07:00:00");
    ok (0, (defined $data and $data eq '+000000001 07:00:00.000000000'), 1);
  }

if (0) { # UNION ALL causes Oracle 9 (not 8) to describe col1 as zero length
# causing "ORA-24345: A Truncation or null fetch error occurred" error
# Looks like an Oracle bug
$dbh->trace(9);
ok 0, $sth = $dbh->prepare(qq{
	SELECT :HeadCrncy FROM DUAL
	UNION ALL
	SELECT :HeadCrncy FROM DUAL
});
$dbh->trace(0);
ok 0, $sth->execute("EUR");
ok 0, $tmp = $sth->fetchall_arrayref;
use Data::Dumper;
die Dumper $tmp;
}


# $dbh->{USER} is just there so it works for old DBI's before Username was added
my @pk = $dbh->primary_key(undef, $dbh->{USER}||$dbh->{Username}, uc $table);
print "primary_key($table): ".Dumper(\@pk);
ok(0, @pk);
ok(0, join(",",@pk) eq 'DT,IDX');

exit 0;
END {
    $dbh->do(qq{ drop table $table }) if $dbh;
}
# end.


# ----

sub create_test_table {
    my ($fields, $drop) = @_;
    my $sql = qq{create table $table (
	idx integer,
	$fields,
	dt date,
	primary key (dt, idx)
    )};
    $dbh->do(qq{ drop table $table }) if $drop;
    $dbh->do($sql);
    if ($dbh->err && $dbh->err==955) {
	$dbh->do(qq{ drop table $table });
	warn "Unexpectedly had to drop old test table '$table'\n" unless $dbh->err;
	$dbh->do($sql);
    }
    return 0 if $dbh->err;
    print "$sql\n";
    return 1;
}


sub cdif {
    my ($s1, $s2, $msg) = @_;
    $msg = ($msg) ? ", $msg" : "";
    my ($l1, $l2) = (length($s1), length($s2));
    return "Strings are identical$msg" if $s1 eq $s2;
    return "Strings are of different lengths ($l1 vs $l2)($s1 vs $s2)$msg" # check substr matches?
	if $l1 != $l2;
	
    my $i;
    for($i=0; $i < $l1; ++$i) {
	my ($c1,$c2) = (ord(substr($s1,$i,1)), ord(substr($s2,$i,1)));
	next if $c1 == $c2;
        return sprintf "Strings differ at position %d (\\%03o vs \\%03o)$msg",
		$i,$c1,$c2;
    }
    return "(cdif error $l1/$l2/$i)";
}


sub ok ($$;$) {
    my($n, $ok, $warn) = @_;
    $warn ||= '';
    ++$t;
    die "sequence error, expected $n but actually $t"
    if $n and $n != $t;
    if ($ok) {
	print "ok $t\n";
    }
    else {
	$warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1';
	warn "# failed test $t at line ".(caller)[2].". $warn\n";
	print "not ok $t\n";
	++$failed;
    }
}

__END__