view release on metacpan or  search on metacpan

t/lib/DBDOracleTestLib.pm  view on Meta::CPAN

# perl 5.6 doesn't define utf8::is_utf8()
unless ( defined &{'utf8::is_utf8'} ) {
    die "Can't run this test using Perl $] without DBI >= 1.38"
      unless $DBI::VERSION >= 1.38;
    *utf8::is_utf8 = sub {
        my $raw = shift;
        return 0 if !defined $raw;
        my $v = DBI::neat($raw);
        return 1 if $v =~ m/^"/;    # XXX ugly hack, sufficient here
        return 0 if $v =~ m/^'/;    # XXX ugly hack, sufficient here
        carp "Emulated utf8::is_utf8 is unreliable for $v ($raw)";
        return 0;
      }
}

=head binmode STDOUT, ':utf8'

 Wide character in print at t/nchar_test_lib.pl line 134 (#1)
    (W utf8) Perl met a wide character (>255) when it wasn't expecting
    one.  This warning is by default on for I/O (like print).  The easiest
    way to quiet this warning is simply to add the :utf8 layer to the
    output, e.g. binmode STDOUT, ':utf8'.  Another way to turn off the
    warning is to add no warnings 'utf8'; but that is often closer to
    cheating.  In general, you are supposed to explicitly mark the
    filehandle with an encoding, see open and perlfunc/binmode.
=cut

eval { binmode STDOUT, ':utf8' };    # Fails for perl 5.6
diag("Can't set binmode(STDOUT, ':utf8'): $@") if $@;
eval { binmode STDERR, ':utf8' };    # Fails for perl 5.6
diag("Can't set binmode(STDERR, ':utf8'): $@") if $@;

# Test::More duplicates STDOUT/STDERR at the start but does not copy the IO
# layers from our STDOUT/STDERR. As a result any calls to Test::More::diag
# with utf8 data will show warnings. Similarly, if we pass utf8 into
# Test::More::pass, ok, etc etc. To get around this we specifically tell
# Test::More to use our newly changed STDOUT and STDERR for failure_output
# and output.
my $tb = Test::More->builder;
binmode( $tb->failure_output, ':utf8' );
binmode( $tb->output,         ':utf8' );

sub long_test_cols {
    my ($type) = @_;
    return [ [ lng => $type ], ];
}


sub extra_wide_rows {

    # Non-BMP characters require use of surrogates with UTF-16
    # So U+10304 becomes U+D800 followed by U+DF04 (I think) in UTF-16.
    #
    # When encoded as standard UTF-8, which Oracle calls AL32UTF8, it should
    # be a single UTF-8 code point (that happens to occupy 4 bytes).
    #
    # When encoded as "CESU-8", which Oracle calls "UTF8", each surrogate
    # is treated as a code point so you get 2 UTF-8 code points
    # (that happen to occupy 3 bytes each). That is not valid UTF-8.
    # See http://www.unicode.org/reports/tr26/ for more information.
    return unless ORA_OCI >= 9.2;    # need AL32UTF8 for these to work
    return (
        [ "\x{10304}", 'SMP Plane 1 wide char' ],    # OLD ITALIC LETTER E
        [ "\x{20301}", 'SIP Plane 2 wide char' ]
        ,    # CJK Unified Ideographs Extension B
    );
}

{

my $char_cols =
    [ [ ch => 'varchar2(20)' ], [ descr => 'varchar2(50)' ], ];

my $nchar_cols =
    [ [ nch => 'nvarchar2(20)' ], [ descr => 'varchar2(50)' ], ];

my $wide_data =
    [
        [ "\x{03}",   'control-C'   ],
        [ 'a',        'lowercase a' ],
        [ 'b',        'lowercase b' ],
        [ "\x{263A}", 'smiley face' ],

        # These are not safe for db's with US7ASCII
        #       [ "\x{A1}", "upside down bang" ],
        #       [ "\x{A2}", "cent char"        ],
        #       [ "\x{A3}", "british pound"    ],
    ];

sub _narrow_data    # Assuming WE8ISO8859P1 or WE8MSWIN1252 character set
{
    my $highbitset = [

        # These non-unicode strings are not safe if client charset is utf8
        # because we have to let oracle assume they're utf8 but they're not
        [ chr(161), 'upside down bang' ],
        [ chr(162), 'cent char'        ],
        [ chr(163), 'british pound'    ],
    ];
    [
        [ 'a',    'lowercase a' ],
        [ 'b',    'lowercase b' ],
        [ chr(3), 'control-C'   ],
        ( _nls_local_has_utf8() ) ? () : @$highbitset
    ];
}

my $tdata_hr = {
    narrow_char => {
        cols => $char_cols,
        rows => _narrow_data()
    },
    narrow_nchar => {
        cols => $nchar_cols,
        rows => _narrow_data()
    },
    wide_char => {
        cols => $char_cols,
        rows => $wide_data
    },
    wide_nchar => {
        cols => $nchar_cols,
        rows => $wide_data
    },
};

sub test_data {
    my ($which) = @_;
    my $test_data = $tdata_hr->{$which} or die;
    $test_data->{dump} = 'DUMP(%s)';
    if ( $ENV{DBD_ORACLE_TESTLOB} ) {    # XXX temp. needs reworking
                                         # Nvarchar -> Nclob and varchar -> clob
        $test_data->{cols}[0][1] =~ s/varchar.*/CLOB/;
        $test_data->{dump} = 'DUMP(DBMS_LOB.SUBSTR(%s))';
    }
    return $test_data;
}

}

sub oracle_test_dsn {
    my ( $default, $dsn ) = ( 'dbi:Oracle:', $ENV{ORACLE_DSN} );

    $dsn ||= $ENV{DBI_DSN}
      if $ENV{DBI_DSN} && ( $ENV{DBI_DSN} =~ m/^$default/io );
    $dsn ||= $default;

    return $dsn;
}

sub db_handle {

    my $p = shift;

t/lib/DBDOracleTestLib.pm  view on Meta::CPAN

        "nice_string test of $description" );
    return $ok1 && $ok2;
}

sub create_table {
    my ( $dbh, $tdata, $drop ) = @_;
    my $tcols = $tdata->{cols};
    my $table = table();
    my $sql   = "create table $table ( idx integer, ";
    foreach my $col (@$tcols) {
        $sql .= $$col[0] . ' ' . $$col[1] . ', ';
    }
    $sql .= ' dt date )';

    drop_table($dbh) if $drop;

    #$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);
    }
    elsif ( $dbh->err ) {
        return;
    }
    else {
        #$sql =~ s/ \( */(\n\t/g;
        #$sql =~ s/, */,\n\t/g;
        note("$sql\n");
    }
    return $table;

    #    ok( not $dbh->err, "create table $table..." );
}

sub show_db_charsets {
    my ($dbh) = @_;
    my $out;
    my $ora_server_version = join '.',
      @{ $dbh->func('ora_server_version') || [] };
    my $paramsH = $dbh->ora_nls_parameters();
    $out =
      sprintf
"Database $ora_server_version CHAR set is %s (%s), NCHAR set is %s (%s)\n",
      $paramsH->{NLS_CHARACTERSET},
      db_ochar_is_utf($dbh) ? 'Unicode' : 'Non-Unicode',
      $paramsH->{NLS_NCHAR_CHARACTERSET},
      db_nchar_is_utf($dbh) ? 'Unicode' : 'Non-Unicode';
    note($out);
    my $ora_client_version = ORA_OCI();
    $out =
      sprintf
      "Client $ora_client_version NLS_LANG is '%s', NLS_NCHAR is '%s'\n",
      ora_env_var('NLS_LANG')  || '<unset>',
      ora_env_var('NLS_NCHAR') || '<unset>';
    note($out);
}

sub db_ochar_is_utf { return shift->ora_can_unicode & 2 }
sub db_nchar_is_utf { return shift->ora_can_unicode & 1 }

sub client_ochar_is_utf8 {
    my $NLS_LANG = ora_env_var('NLS_LANG') || q();
    $NLS_LANG =~ s/.*\.//;
    return $NLS_LANG =~ m/utf8/i;
}

sub client_nchar_is_utf8 {
    my $NLS_LANG = ora_env_var('NLS_LANG') || q();
    $NLS_LANG =~ s/.*\.//;
    my $NLS_NCHAR = ora_env_var('NLS_NCHAR') || $NLS_LANG;
    return $NLS_NCHAR =~ m/utf8/i;
}

sub _nls_local_has_utf8 {
    return client_ochar_is_utf8() || client_nchar_is_utf8();
}

sub set_nls_nchar {
    my ( $cset, $verbose ) = @_;
    if ( defined $cset ) {
        $ENV{NLS_NCHAR} = "$cset";
    }
    else {
        undef $ENV{NLS_NCHAR};    # XXX windows? (perhaps $ENV{NLS_NCHAR}=""?)
    }

    # Special treatment for environment variables under Cygwin -
    # see comments in dbdimp.c for details.
    DBD::Oracle::ora_cygwin_set_env( 'NLS_NCHAR', $ENV{NLS_NCHAR} || '' )
      if $^O eq 'cygwin';
    note(
        defined ora_env_var('NLS_NCHAR')
        ?    # defined?
          "set \$ENV{NLS_NCHAR}=$cset\n"
        : "set \$ENV{NLS_LANG}=undef\n"
      )      # XXX ?
      if defined $verbose;
}

sub set_nls_lang_charset {
    my ( $lang, $verbose ) = @_;

    $ENV{NLS_LANG} = $lang ? "AMERICAN_AMERICA.$lang" : q();

    note sprintf( q|set $ENV{NLS_LANG}='%s'|, $ENV{NLS_LANG} );

    # Special treatment for environment variables under Cygwin -
    # see comments in dbdimp.c for details.
    DBD::Oracle::ora_cygwin_set_env( 'NLS_LANG', $ENV{NLS_LANG} || '' )
      if $^O eq 'cygwin';
}

sub _byte_string {
    my $ret = join( '|', unpack( 'C*', $_[0] ) );
    return $ret;
}

sub nice_string {
    my @raw_chars = ( utf8::is_utf8( $_[0] ) )
      ? unpack( 'U*', $_[0] )     # unpack unicode characters
      : unpack( 'C*', $_[0] );    # not unicode, so unpack as bytes
    my @chars = map {
        $_ > 255
          ?                       # if wide character...
          sprintf( "\\x{%04X}", $_ )
          :                       # \x{...}
          chr($_) =~ /[[:cntrl:]]/
          ?                       # else if control character ...
          sprintf( "\\x%02X", $_ )
          :                       # \x..
          chr($_)                 # else as themselves
    } @raw_chars;

    for my $c (@chars) {
        if ( $c =~ m/\\x\{08(..)}/ ) {
            $c .= q|='| . chr( hex($1) ) . q(');
        }
    }
    my $ret = join( q||, @chars );

}

sub view_with_sqlplus {
    my ( $use_nls_lang, $tdata ) = @_;
    my $table   = table();
    my $tcols   = $tdata->{cols};
    my $sqlfile = 'sql.txt';
    my $cols    = 'idx,nch_col';
    open my $F, '>', $sqlfile or die "could open $sqlfile";
    print $F $ENV{ORACLE_USERID} . "\n";
    my $str = qq(
col idx form 99
col ch_col form a8
col nch_col form a16
select $cols from $table;
);
    print $F $str;
    print $F "exit;\n";
    close $F;

    my $nls = 'unset';
    $nls = ora_env_var('NLS_LANG') if ora_env_var('NLS_LANG');
    local $ENV{NLS_LANG} = '' if not $use_nls_lang;
    print "From sqlplus...$str\n  ...with NLS_LANG = $nls\n";
    system("sqlplus -s \@$sqlfile");
    unlink $sqlfile;
}

1;