#!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
plan tests => $tests;
$| = 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() or BAILOUT("Can't connect to database: $DBI::errstr");
my $ora_server_version = $dbh->func("ora_server_version");
diag("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);
    diag( 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) {
                diag "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
        diag("long_data[0] length $len_data0\n");
        diag("long_data[1] length $len_data1\n");
        diag("long_data[2] length $len_data2\n");
        diag(" --- 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);
        diag(" --- fetch $type_name data back again -- truncated - LongTruncOk == 1\n");
        $dbh->{LongReadLen} = 20;
        $dbh->{LongTruncOk} =  1;
        diag("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
        }
        diag(" --- 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;
        diag("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;
        diag(" --- fetch $type_name data back again -- complete - LongTruncOk == 0\n");
        $dbh->{LongReadLen} = $len_data1 +1000;
        $dbh->{LongTruncOk} = 0;
        diag("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);
            diag(" --- 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" );
            diag("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");
            diag("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");
            diag("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 );
            diag(" --- 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) {
                diag("$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
                diag("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);
            diag(" --- 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) {
                diag("$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" );
                diag("$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);
            diag(" --- 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) {
               diag("$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;
        diag("a=$a\n");
        diag("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__