view release on metacpan or  search on metacpan

t/30long.t  view on Meta::CPAN

#!perl

use strict;
use warnings;

use lib 't/lib';
use DBDOracleTestLib qw/ table drop_table oracle_test_dsn db_handle
                        show_db_charsets long_test_cols create_table
                        cmp_ok_byte_nice db_ochar_is_utf client_ochar_is_utf8
                        nice_string db_nchar_is_utf client_nchar_is_utf8
/;

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

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

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

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( { PrintError => 0 } )
 or plan skip_all => 'Unable to connect to Oracle';

my $tests_per_set = 97;

my $ora_server_version = $dbh->func('ora_server_version');

show_db_charsets($dbh);

foreach (@test_sets) {
    my ( $type_name, $type_num, $test_no_type ) = @$_;
    subtest $type_name => sub {
        plan tests => $tests_per_set;
        $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;
      }
}

done_testing();

### END OF TESTS, ONLY FUNCTIONS BELOW ###

END {
    eval{ drop_table($dbh) }
}

sub use_utf8_data {
    my ( $dbh, $type_name ) = @_;

    return 0
      unless ( $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}++;
}

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_data = map { length($_) } @long_data;

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

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