#!perl -w
# vim:ts=8:sw=4

use DBI;
use DBD::Oracle qw(:ora_types SQLCS_NCHAR SQLCS_IMPLICIT ORA_OCI);
use strict;
use Test::More;

*BAILOUT = sub { die "@_\n" } unless defined &BAILOUT;

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

my @test_sets;
push @test_sets, [ "LONG",	0,		0 ];
push @test_sets, [ "LONG RAW",	ORA_LONGRAW,	0 ];
push @test_sets, [ "NCLOB",	ORA_CLOB,	0 ] unless ORA_OCI() < 9.0 or $ENV{DBD_ALL_TESTS};
push @test_sets, [ "CLOB",	ORA_CLOB,	0 ] ;
push @test_sets, [ "BLOB",	ORA_BLOB,	0 ] ;

my $tests_per_set = 96;
my $tests = @test_sets * $tests_per_set-1; 
#very odd little thing that took a while to figure out.
#Seems I now have 479 tests which is 9 more so 96 test then -1 to round it off

$| = 1;
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $table = table();
my $use_utf8_data;	# set per test_set below
my %warnings;

my @skip_unicode;
push @skip_unicode, "Perl < 5.6 "          if $] < 5.006;
push @skip_unicode, "Oracle client < 9.0 " if ORA_OCI() < 9.0 and !$ENV{DBD_ALL_TESTS};

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

my($p1, $p2, $tmp, @tmp);

#my $dbh = db_handle();


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

if ($dbh) {
    plan tests => $tests;
} else {
    plan skip_all => "Unable to connect to Oracle";
}

my $ora_server_version = $dbh->func("ora_server_version");
note("ora_server_version: @$ora_server_version\n");
show_db_charsets($dbh) if $dbh;

foreach (@test_sets) {
    my ($type_name, $type_num, $test_no_type) = @$_;
    $use_utf8_data = use_utf8_data($dbh,$type_name);
    note( qq(
    =========================================================================
    Running long test for $type_name ($type_num) use_utf8_data=$use_utf8_data
));
    run_long_tests($dbh, $type_name, $type_num);
    run_long_tests($dbh, $type_name, 0) if $test_no_type;
}

exit 0;

# end.


END {
    drop_table( $dbh ) if not $ENV{DBD_SKIP_TABLE_DROP};
    $dbh->disconnect if $dbh;
}


sub use_utf8_data
{
    my ( $dbh, $type_name ) = @_;
    if (   ($type_name =~ m/^CLOB/i  and db_ochar_is_utf($dbh) && client_ochar_is_utf8())
        or ($type_name =~ m/^NCLOB/i and db_nchar_is_utf($dbh) && client_nchar_is_utf8()) ) {
	return 1 unless @skip_unicode;
	warn "Skipping Unicode data tests: @skip_unicode\n" if !$warnings{use_utf8_data}++;
    }
    return 0;
}

sub run_long_tests
{
    my ($dbh, $type_name, $type_num) = @_;
    my ($sth);
    my $append_len;
    SKIP:
    { #it all

        # relationships between these lengths are important # e.g.
        my %long_data;
        my @long_data;
        $long_data[2] = ("2bcdefabcd"  x 1024) x ($sz-1);  # 70KB  > 64KB && < long_data1
        $long_data[1] = ("1234567890"  x 1024) x ($sz  );  # 80KB >> 64KB && > long_data2
        $long_data[0] = ("0\177x\0X"   x 2048) x (1    );  # 10KB  < 64KB

        if ( $use_utf8_data ) { # make $long_data0 be UTF8
            my $utf_x = "0\x{263A}xyX"; #lab: the ubiquitous smiley face
            $long_data[0] = ($utf_x x 2048) x (1    );        # 10KB  < 64KB
            if (length($long_data[0]) > 10240) {
                note "known bug in perl5.6.0 utf8 support, applying workaround\n";
                my $utf_z = "0\x{263A}xyZ" ;
                $long_data[0] = $utf_z;
                $long_data[0] .= $utf_z foreach (1..2047);
            }
            if ($type_name eq 'BLOB') {
                # convert string from utf-8 to byte encoding XXX
                $long_data[0] = pack "C*", (unpack "C*", $long_data[0]);
            }
        }
	my $be_utf8 = ($type_name eq  'BLOB') ? 0
		    : ($type_name eq  'CLOB') ? client_ochar_is_utf8()
		    : ($type_name eq 'NCLOB') ? client_nchar_is_utf8()
		    : 0; # XXX umm, what about LONGs?

        # special hack for long_data[0] since RAW types need pairs of HEX
        $long_data[0] = "00FF" x (length($long_data[0]) / 2) if $type_name =~ /RAW/i;

        my $len_data0 = length($long_data[0]);
        my $len_data1 = length($long_data[1]);
        my $len_data2 = length($long_data[2]);

        # warn if some of the key aspects of the data sizing are tampered with
        warn "long_data[0] is > 64KB: $len_data0\n"
                if $len_data0 > 65535;
        warn "long_data[1] is < 64KB: $len_data1\n"
                if $len_data1 < 65535;
        warn "long_data[2] is not smaller than $long_data[1] ($len_data2 > $len_data1)\n"
                if $len_data2 >= $len_data1;

        my $tdata = {
            cols => long_test_cols( $type_name ),
            rows => []
        };


        skip "Unable to create test table for '$type_name' data ($DBI::err)." ,$tests_per_set
            if (!create_table($dbh, $tdata, 1));
            # typically OCI 8 client talking to Oracle 7 database

        note("long_data[0] length $len_data0\n");
        note("long_data[1] length $len_data1\n");
        note("long_data[2] length $len_data2\n");

        note(" --- insert some $type_name data (ora_type $type_num)\n");
        my $sqlstr = "insert into $table values (?, ?, SYSDATE)" ;
        ok( $sth = $dbh->prepare( $sqlstr ), "prepare: $sqlstr" );
        my $bind_attr = { ora_type => $type_num };
	# The explicit SQLCS_IMPLICIT is needed in some odd cases
        $bind_attr->{ora_csform} = ($type_name =~ /^NCLOB/) ? SQLCS_NCHAR : SQLCS_IMPLICIT;

        $sth->bind_param(2, undef, $bind_attr )
		or die "$type_name: $DBI::errstr" if $type_num;

        ok($sth->execute(40, $long_data{40} = $long_data[0] ), "insert long data 40" );
        ok($sth->execute(41, $long_data{41} = $long_data[1] ), "insert long data 41" );
        ok($sth->execute(42, $long_data{42} = $long_data[2] ), "insert long data 42" );
        ok($sth->execute(43, $long_data{43} = undef), "insert long data undef 43" ); # NULL

        array_test($dbh);

        note(" --- fetch $type_name data back again -- truncated - LongTruncOk == 1\n");
        $dbh->{LongReadLen} = 20;
        $dbh->{LongTruncOk} =  1;
        note("LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n");

        # This behaviour isn't specified anywhere, sigh:
        my $out_len = $dbh->{LongReadLen};
        $out_len *= 2 if ($type_name =~ /RAW/i);

        $sqlstr = "select * from $table order by idx";
        ok($sth = $dbh->prepare($sqlstr), "prepare: $sqlstr" );
        $sth->trace(0);
        ok($sth->execute, "execute: $sqlstr" );
        ok($tmp = $sth->fetchall_arrayref, "fetch_arrayref for $sqlstr" );
        $sth->trace(0);
        SKIP: {
            if ($DBI::err && $DBI::errstr =~ /ORA-01801:/) {
                # ORA-01801: date format is too long for internal buffer
                skip " If you're using Oracle <= 8.1.7 then this error is probably\n"
                    ." due to an Oracle bug and not a DBD::Oracle problem.\n" , 5 ;
            }
            cmp_ok(@$tmp ,'==' ,4 ,'four rows' );
            #print "tmp->[0][1] = " .$tmp->[0][1] ."\n" ;
	    for my $i (0..2) {
		my $v = $tmp->[$i][1];
		cmp_ok_byte_nice($v, substr($long_data[$i],0,$out_len), "truncated to LongReadLen $out_len");
		if ($type_name eq 'BLOB') {
		    ok( !utf8::is_utf8($v), "BLOB non-UTF8");
		}
		else {
		    # allow result to have UTF8 flag even if source data didn't
		    # (not ideal but would need better test data)
		    ok( utf8::is_utf8($v) >= utf8::is_utf8($long_data[$i]),
			"$type_name UTF8 setting");
		}
	    }
            # use Data::Dumper; print Dumper($tmp->[3]);
            ok(!defined $tmp->[3][1], "last row undefined"); # NULL # known bug in DBD::Oracle <= 1.13
        }

        note(" --- fetch $type_name data back again -- truncated - LongTruncOk == 0\n");
        $dbh->{LongReadLen} = $len_data1 - 10; # so $long_data[0] fits but long_data[1] doesn't
        $dbh->{LongReadLen} = $dbh->{LongReadLen} / 2 if $type_name =~ /RAW/i;
        my $LongReadLen = $dbh->{LongReadLen};
        $dbh->{LongTruncOk} = 0;
        note("LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n");

        $sqlstr = "select * from $table order by idx";
        ok($sth = $dbh->prepare($sqlstr), "prepare $sqlstr" );
        ok($sth->execute, "execute $sqlstr" );
        ok($tmp = $sth->fetchrow_arrayref, "fetchrow_arrayref $sqlstr" );
        ok($tmp->[1] eq $long_data[0], "length tmp->[1] ".length($tmp->[1]) );

        {
            local $sth->{PrintError} = 0;
            ok(!defined $sth->fetchrow_arrayref,
                    "truncation error not triggered "
                    ."(LongReadLen $LongReadLen, data ".length($tmp->[1]||0).")");
            $tmp = $sth->err || 0;
            ok( ($tmp == 1406 || $tmp == 24345) ,"tmp==1406 || tmp==24345 tmp actually=$tmp" );
        }
	$sth->finish;

        note(" --- fetch $type_name data back again -- complete - LongTruncOk == 0\n");
        $dbh->{LongReadLen} = $len_data1 +1000;
        $dbh->{LongTruncOk} = 0;
        note("LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n");

        $sqlstr = "select * from $table order by idx";
        ok($sth = $dbh->prepare($sqlstr), "prepare: $sqlstr" );
        ok($sth->execute, "execute $sqlstr" );

	for my $i (0..2) {
	    ok($tmp = $sth->fetchrow_arrayref, "fetchrow_arrayref $sqlstr" );
	    ok($tmp->[1] eq $long_data[$i],
                cdif($tmp->[1],$long_data[$i], "Len ".length($tmp->[1])) );
	}
	$sth->finish;


        SKIP: {
            skip( "blob_read tests for LONGs - not currently supported", 15 )
                if ($type_name =~ /LONG/i) ;

            #$dbh->trace(4);
            note(" --- fetch $type_name data back again -- via blob_read\n\n");

            $dbh->{LongReadLen} = 1024 * 90;
            $dbh->{LongTruncOk} =  1;
            $sqlstr = "select idx, lng, dt from $table order by idx";
            ok($sth = $dbh->prepare($sqlstr) ,"prepare $sqlstr" );
            ok($sth->execute, "execute $sqlstr" );


	    note("fetch via fetchrow_arrayref\n");
            ok($tmp = $sth->fetchrow_arrayref, "fetchrow_arrayref 1: $sqlstr"  );
	    cmp_ok_byte_nice($tmp->[1], $long_data[0], "truncated to LongReadLen $out_len");

	    note("read via blob_read_all\n");
            cmp_ok(blob_read_all($sth, 1, \$p1, 4096) ,'==', length($long_data[0]),
	    	"blob_read_all = length(\$long_data[0])" );
            ok($p1 eq $long_data[0], cdif($p1, $long_data[0]) );
	    $sth->trace(0);


            ok($tmp = $sth->fetchrow_arrayref, "fetchrow_arrayref 2: $sqlstr" );
            cmp_ok(blob_read_all($sth, 1, \$p1, 12345) ,'==', length($long_data[1]),
	    	"blob_read_all = length(long_data[1])" );
            ok($p1 eq $long_data[1], cdif($p1, $long_data[1]) );


            ok($tmp = $sth->fetchrow_arrayref, "fetchrow_arrayref 3: $sqlstr"  );
            my $len = blob_read_all($sth, 1, \$p1, 34567);

	    cmp_ok($len,'==', length($long_data[2]), "length of long_data[2] = $len" );
	    cmp_ok_byte_nice($p1, $long_data[2], "3rd row via blob_read_all");

	    note("result is ".(utf8::is_utf8($p1) ? "UTF8" : "non-UTF8")."\n");
	    if ($be_utf8) {
	        ok( utf8::is_utf8($p1), "result should be utf8");
	    }
	    else {
	        ok( !utf8::is_utf8($p1), "result should not be utf8");
	    }
        } #skip


        SKIP: {
            skip( "ora_auto_lob tests for $type_name" ."s - not supported", 7+(13*3) )
                if not ( $type_name =~ /LOB/i );

            note(" --- testing ora_auto_lob to access $type_name LobLocator\n\n");
            my $data_fmt = "%03d foo!";

            $sqlstr = qq{
                    SELECT lng, idx FROM $table ORDER BY idx
                    FOR UPDATE -- needed so lob locator is writable
                };
            my $ll_sth = $dbh->prepare($sqlstr, { ora_auto_lob => 0 } );  # 0: get lob locator instead of lob contents
            ok($ll_sth ,"prepare $sqlstr" );

            ok($ll_sth->execute ,"execute $sqlstr" );
            while (my ($lob_locator, $idx) = $ll_sth->fetchrow_array) {
                note("$idx: ".DBI::neat($lob_locator)."\n");
                last if !defined($lob_locator) && $idx == 43;

                ok($lob_locator, '$lob_locator is true' );
                is(ref $lob_locator , 'OCILobLocatorPtr', '$lob_locator is a OCILobLocatorPtr' );
                ok( (ref $lob_locator and $$lob_locator), '$lob_locator deref ptr is true' ) ;
                
                # check ora_lob_chunk_size:
		my $chunk_size = $dbh->func($lob_locator, 'ora_lob_chunk_size');
		ok(!$DBI::err, "DBI::errstr");
		
                my $data = sprintf $data_fmt, $idx; #create a little data
                note("length of data to be written at offset 1: " .length($data) ."\n" );
                ok($dbh->func($lob_locator, 1, $data, 'ora_lob_write') ,"ora_lob_write" );
            }
	    is($ll_sth->rows, 4);

            note(" --- round again to check contents after $type_name write updates...\n");
	    ok($ll_sth->execute,"execute (again 1) $sqlstr" );
	    while (my ($lob_locator, $idx) = $ll_sth->fetchrow_array) {
		note("$idx locator: ".DBI::neat($lob_locator)."\n");
                next if !defined($lob_locator) && $idx == 43;
		diag("DBI::errstr=$DBI::errstr\n") if $DBI::err ;

		my $content = $dbh->func($lob_locator, 1, 20, 'ora_lob_read');
		diag("DBI::errstr=$DBI::errstr\n") if $DBI::err ;
		ok($content,"content is true" );
		note("$idx content: ".nice_string($content)."\n"); #.DBI::neat($content)."\n";
		cmp_ok(length($content) ,'==', 20 ,"lenth(content)" );

		# but prefix has been overwritten:
		my $data = sprintf $data_fmt, $idx;
		ok(substr($content,0,length($data)) eq $data ,"length(content)=length(data)" );

		# ora_lob_length agrees:
		my $len = $dbh->func($lob_locator, 'ora_lob_length');
		ok(!$DBI::err ,"DBI::errstr" );
		cmp_ok($len ,'==', length($long_data{$idx}) ,"length(long_data{idx}) = length of locator data" );

		# now trim the length
		$dbh->func($lob_locator, $idx, 'ora_lob_trim');
		ok(!$DBI::err, "DBI::errstr" );

		# and append some text
		SKIP: {
		    $append_len = 0;
		    skip( "ora_lob_append() not reliable in Oracle 8 (Oracle bug #886191)", 1 )
			if ORA_OCI() < 9 or $ora_server_version->[0] < 9;

		    my $append_data = "12345";
		    $append_len = length($append_data);
		    $dbh->func($lob_locator, $append_data, 'ora_lob_append');
		    ok(!$DBI::err ,"ora_lob_append DBI::errstr" );
		    # XXX ought to test data was actually appended
		}

	    } #while fetchrow
	    is($ll_sth->rows, 4);

            note(" --- round again to check the $type_name length...\n");
	    ok($ll_sth->execute ,"execute (again 2) $sqlstr" );
	    while (my ($lob_locator, $idx) = $ll_sth->fetchrow_array) {
	       note("$idx locator: ".DBI::neat($lob_locator)."\n");
               next if !defined($lob_locator) && $idx == 43;
	       my $len = $dbh->func($lob_locator, 'ora_lob_length');
	       #lab: possible logic error here w/resp. to len
	       ok(!$DBI::err ,"DBI::errstr" );
	       cmp_ok( $len ,'==', $idx + $append_len ,"len == idx+5" );
	    }
	    is($ll_sth->rows, 4);

        } #skip for LONG types

    } #skip it all (tests_per_set)

    $sth->finish if $sth;
    drop_table( $dbh )

} # end of run_long_tests



sub array_test {
    my ($dbh) = @_;
    return 0;	# XXX disabled
    eval {
	$dbh->{RaiseError}=1;
	$dbh->trace(0);
	my $sth = $dbh->prepare(qq{
	   UPDATE $table set idx=idx+1 RETURNING idx INTO ?
	});
	my ($a,$b);
	$a = [];
	$sth->bind_param_inout(1,\$a, 2);
	$sth->execute;
	note("a=$a\n");
	note("a=@$a\n");
    };
    die "RETURNING array: $@";
}


sub print_substrs
{
    my ($dbh,$len) = @_;
    my $tsql = "select substr(lng,1,$len),idx from $table order by idx" ;
    diag("-- prepare: $tsql\n") ;
    my $tsth = $dbh->prepare( $tsql );
    $tsth->execute();
    while ( my ( $d,$i ) = $tsth->fetchrow_array() )
    {
        last if not defined $d;
        diag("$i: $d\n");
    }
}

sub print_lengths
{
    my ($dbh) = @_;
    my $tsql = "select length(lng),idx from $table order by idx" ;
    diag("-- prepare: $tsql\n");
    my $tsth = $dbh->prepare( $tsql );
    $tsth->execute();
    while ( my ( $l,$i ) = $tsth->fetchrow_array() )
    {
        last if not defined $l;
        diag("$i: $l\n");
    }
}


sub blob_read_all {
    my ($sth, $field_idx, $blob_ref, $lump) = @_;

    $lump ||= 4096; # use benchmarks to get best value for you
    my $offset = 0;
    my @frags;
    while (1) {
	my $frag = $sth->blob_read($field_idx, $offset, $lump);
	last unless defined $frag;
	my $len = length $frag;
	last unless $len;
	push @frags, $frag;
	$offset += $len;
	#print "blob_read_all: offset $offset, len $len\n";
    }
    $$blob_ref = join "", @frags;
    return length($$blob_ref);
}

sub unc {
    my @str = @_;
    foreach (@str) { s/([\000-\037\177-\377])/ sprintf "\\%03o", ord($_) /eg; }
    return join "", @str unless wantarray;
    return @str;
}

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)$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)";
}


__END__