Author: byterock
Date: Wed Jul 30 14:51:54 2008
New Revision: 11613
Modified:
dbd-oracle/trunk/Changes
dbd-oracle/trunk/Makefile.PL
dbd-oracle/trunk/Oracle.pm
dbd-oracle/trunk/Oracle.xs
dbd-oracle/trunk/README
dbd-oracle/trunk/ocitrace.h
dbd-oracle/trunk/t/30long.t
dbd-oracle/trunk/t/nchar_test_lib.pl
Log:
Patch to Makfile for 64bit boxes from Alex Laslavic
Added OCILobGetLength to lob functions from Milo van der Leij
Updated readmes to state the test user has to have create, call and drop a
procedure privileges by John Scoles suggested by Gisle Aas
Modified: dbd-oracle/trunk/Changes
==============================================================================
--- dbd-oracle/trunk/Changes (original)
+++ dbd-oracle/trunk/Changes Wed Jul 30 14:51:54 2008
@@ -1,4 +1,8 @@
=head1 Changes in DBD-Oracle 1.22(svn rev xxxx) 2008
+ Patch to Makfile for 64bit boxes from Alex Laslavic
+ Added OCILobGetLength to lob functions from Milo van der Leij
+ Updated readmes to state the test user has to have create, call and drop a
procedure privileges by John Scoles suggested by Gisle Aas
+ Patch to Makfile to prevent the installation of the lib/DBD/mkta.pl fil from
Gisle Aas
Added new Test 31lob_extended.t for use of LOBs when returned via stored
procedures with bind_param_inout from Martin Evans
Update to connection part of POD from John Scoles
Fix to test suite to bring it up to standard from Martin Evans
@@ -22,6 +26,7 @@
=head1 Changes in DBD-Oracle 1.21(svn rev 11067) 11th April 2008
+
Added Notes to README.win32.txt on installing Instant Client 11.1.0.6.0 from
John Scoles
Added the oci_typecode_name method to get the name rather than just the
number of an OCI_TYPECODE from John Scoles
Fixed a unreported bug with Embedded Objects from John Scoles
Modified: dbd-oracle/trunk/Makefile.PL
==============================================================================
--- dbd-oracle/trunk/Makefile.PL (original)
+++ dbd-oracle/trunk/Makefile.PL Wed Jul 30 14:51:54 2008
@@ -1442,8 +1442,13 @@
"/include/oracle/$client_version_trim/client", # Instant Client for
RedHat FC3
"/usr/include/oracle/$client_version/client", # Instant Client 11.1 and
up
"/usr/include/oracle/$client_version/client64", # Instant Client 11.1
and up
+ "/usr/include/oracle/$client_version_trim/client64", # Instant Client 64
+ "/usr/include/oracle/$client_version_full/client64", # Instant Client 64
+
);
+
+
# Add /usr/include/oracle based on the oracle home location if oracle home
is under
# /usr/lib/oracle ( Linux RPM install ). The 11g instant client reports
# client_version as 11.1.0.6 from sqlplus, but installs under 11.1.0.1.
@@ -1635,6 +1640,12 @@
use strict;
use Config;
+ sub libscan {
+ my($self, $path) = @_;
+ return '' if $path =~ m/\.pl$/;
+ $path;
+ }
+
sub post_initialize {
my $self = shift;
Modified: dbd-oracle/trunk/Oracle.pm
==============================================================================
--- dbd-oracle/trunk/Oracle.pm (original)
+++ dbd-oracle/trunk/Oracle.pm Wed Jul 30 14:51:54 2008
@@ -72,6 +72,7 @@
DBD::Oracle::db->install_method("ora_lob_append");
DBD::Oracle::db->install_method("ora_lob_trim");
DBD::Oracle::db->install_method("ora_lob_length");
+ DBD::Oracle::db->install_method("ora_lob_chunk_size");
DBD::Oracle::db->install_method("ora_nls_parameters");
DBD::Oracle::db->install_method("ora_can_unicode");
DBD::Oracle::st->install_method("ora_fetch_scroll");
@@ -3378,6 +3379,18 @@
Returns the length of the LOB.
Uses the Oracle OCILobGetLength function.
+=item ora_lob_chunk_size
+
+ $chunk_size = $dbh->ora_lob_chunk_size($lob_locator);
+
+Returns the chunk size of the LOB.
+Uses the Oracle OCILobGetChunkSize function.
+
+For optimal performance, Oracle recommends reading from and
+writing to a LOB in batches using a multiple of the LOB chunk size.
+In Oracle 10g and before, when all defaults are in place, this
+chunk size defaults to 8k (8192).
+
=back
=head3 LOB Locator Method Examples
@@ -3449,7 +3462,7 @@
open BIN_FH, "/binary/data/source" or die;
open CHAR_FH, "/character/data/source" or die;
- my $chunk_size = 4096; # Arbitrary chunk size
+ my $chunk_size = $dbh->ora_lob_chunk_size( $bin_locator );
# BEGIN WRITING BIN_DATA COLUMN
my $offset = 1; # Offsets start at 1, not 0
@@ -3461,6 +3474,7 @@
}
# BEGIN WRITING CHAR_DATA COLUMN
+ $chunk_size = $dbh->ora_lob_chunk_size( $char_locator );
$offset = 1; # Offsets start at 1, not 0
$length = 0;
$buffer = '';
Modified: dbd-oracle/trunk/Oracle.xs
==============================================================================
--- dbd-oracle/trunk/Oracle.xs (original)
+++ dbd-oracle/trunk/Oracle.xs Wed Jul 30 14:51:54 2008
@@ -464,6 +464,24 @@
}
+void
+ora_lob_chunk_size(dbh, locator)
+ SV *dbh
+ OCILobLocator *locator
+ PREINIT:
+ D_imp_dbh(dbh);
+ sword status;
+ ub4 chunk_size = 0;
+ CODE:
+ OCILobGetChunkSize_log_stat(imp_dbh->svchp, imp_dbh->errhp, locator,
&chunk_size, status);
+ if (status != OCI_SUCCESS) {
+ oci_error(dbh, imp_dbh->errhp, status, "OCILobGetChunkSize");
+ ST(0) = &sv_undef;
+ }
+ else {
+ ST(0) = sv_2mortal(newSVuv(chunk_size));
+ }
+
MODULE = DBD::Oracle PACKAGE = DBD::Oracle::dr
Modified: dbd-oracle/trunk/README
==============================================================================
--- dbd-oracle/trunk/README (original)
+++ dbd-oracle/trunk/README Wed Jul 30 14:51:54 2008
@@ -110,8 +110,10 @@
ORACLE_USERID environment variable to supply the username/password.
So you should set that to a valid user (e.g. 'scott/tiger') and ensure that
this user has sufficient privileges to create, insert into, select from and
-drop a table, and is able to select from systemtables like 'v$sessions'.
-Using 'system/manager' might work but is not recommended! See also
+drop a table, is also able to create, call and drop a procedure and is able
to select from
+systemtables like 'v$sessions'. Using 'system/manager' might work but is not
+recommended! See also
+
README.login.txt.
make test
Modified: dbd-oracle/trunk/ocitrace.h
==============================================================================
--- dbd-oracle/trunk/ocitrace.h (original)
+++ dbd-oracle/trunk/ocitrace.h Wed Jul 30 14:51:54 2008
@@ -353,6 +353,15 @@
OciTp, (void*)sh,(void*)eh,(void*)lh,pul_t(l), \
oci_status_name(stat)),stat : stat
+
+#define OCILobGetChunkSize_log_stat(sh,eh,lh,cs,stat) \
+ stat=OCILobGetChunkSize(sh,eh,lh,cs); \
+ (DBD_OCI_TRACEON) ? PerlIO_printf(DBD_OCI_TRACEFP,
\
+ "%sLobGetChunkSize(%p,%p,%p,%p)=%s\n",
\
+ OciTp, (void*)sh,(void*)eh,(void*)lh,pul_t(cs), \
+ oci_status_name(stat)),stat : stat
+
+
#define OCILobFileOpen_log_stat(sv,eh,lh,mode,stat) \
stat=OCILobFileOpen(sv,eh,lh,mode); \
(DBD_OCI_TRACEON) ? PerlIO_printf(DBD_OCI_TRACEFP,
\
Modified: dbd-oracle/trunk/t/30long.t
==============================================================================
--- dbd-oracle/trunk/t/30long.t (original)
+++ dbd-oracle/trunk/t/30long.t Wed Jul 30 14:51:54 2008
@@ -18,8 +18,11 @@
push @test_sets, [ "CLOB", ORA_CLOB, 0 ] ;
push @test_sets, [ "BLOB", ORA_BLOB, 0 ] ;
-my $tests_per_set = 94;
-my $tests = @test_sets * $tests_per_set;
+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;
@@ -306,6 +309,11 @@
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" );
Modified: dbd-oracle/trunk/t/nchar_test_lib.pl
==============================================================================
--- dbd-oracle/trunk/t/nchar_test_lib.pl (original)
+++ dbd-oracle/trunk/t/nchar_test_lib.pl Wed Jul 30 14:51:54 2008
@@ -1,525 +1,526 @@
-use strict;
-use warnings;
-use Carp;
-use Data::Dumper;
-use DBI;
-use DBD::Oracle qw(ORA_OCI ora_env_var);
-
-require utf8;
-
-# 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 =~ /^"/; # XXX ugly hack, sufficient here
- return 0 if $v =~ /^'/; # 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');
-
-# disable diag unless TEST_VERBOSE is set.
-if (!exists($ENV{TEST_VERBOSE})) {
- $tb->no_diag(1);
-}
-sub long_test_cols
-{
- my ($type) = @_ ;
- return
- [
- [ lng => $type ],
- ];
-}
-sub char_cols
-{
- [
- [ ch => 'varchar2(20)' ],
- [ descr => 'varchar2(50)' ],
- ];
-}
-sub nchar_cols
-{
- [
- [ nch => 'nvarchar2(20)' ],
- [ descr => 'varchar2(50)' ],
- ];
-}
-sub 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 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
- );
-}
-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} =~
/^$default/io);
- $dsn ||= $default;
- return $dsn;
-}
-
-sub db_handle
-{
- my $dsn = oracle_test_dsn();
- my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
- my $dbh = DBI->connect($dsn, $dbuser, '', {
- AutoCommit => 1,
- PrintError => 1,
- ora_envhp => 0, # force fresh environment (with current NLS env vars)
- });
- return $dbh;
-}
-sub show_test_data
-{
- my ($tdata) = @_;
- my $rowsR = $tdata->{rows};
- my $cnt = 0;
- my $vcnt = 0;
- foreach my $recR ( @$rowsR )
- {
- $cnt++;
- my $v = $$recR[0];
- my $byte_string = byte_string($v);
- my $nice_string = nice_string($v);
- my $out = sprintf( "row: %3d: nice_string=%s byte_string=%s (%s,
%s)\n",
- $cnt, $nice_string, $byte_string, $v,
DBI::neat($v));
- diag($out);
- }
- return $cnt;
-}
-
-sub table { 'dbd_ora__drop_me'.($ENV{DBD_ORACLE_SEQ}||''); }
-sub drop_table
-{
- my ($dbh) = @_;
- my $table = table();
- local $dbh->{PrintError} = 0;
- $dbh->do(qq{ drop table $table }) if $dbh->{Active};
-}
-
-sub insert_handle
-{
- my ($dbh,$tcols) = @_;
- my $table = table();
- my $sql = "insert into $table ( idx, ";
- my $cnt = 1;
- foreach my $col ( @$tcols )
- {
- $sql .= $$col[0] . ", ";
- $cnt++;
- }
- $sql .= "dt ) values( " . "?, " x $cnt ."sysdate )";
- my $h = $dbh->prepare( $sql );
- ok( $h ,"prepared: $sql" );
- return $h;
-}
-sub insert_test_count
-{
- my ( $tdata ) = @_;
- my $rcnt = @{$tdata->{rows}};
- my $ccnt = @{$tdata->{cols}};
- return 1 + $rcnt*2 + $rcnt * $ccnt;
-}
-sub insert_rows #1 + rows*2 +rows*ncols tests
-{
- my ($dbh, $tdata ,$csform) = @_;
- my $trows = $tdata->{rows};
- my $tcols = $tdata->{cols};
- my $table = table();
- # local $dbh->{TraceLevel} = 4;
- my $sth = insert_handle($dbh, $tcols);
-
- my $cnt = 0;
- foreach my $rowR ( @$trows )
- {
- my $colnum = 1;
- my $attrR = $csform ? { ora_csform => $csform } : {};
- ok( $sth->bind_param( $colnum++ ,$cnt ) ,"bind_param idx" );
- for( my $i = 0; $i < @$rowR; $i++ )
- {
- my $note = 'withOUT attribute ora_csform';
- my $val = $$rowR[$i];
- my $type = $$tcols[$i][1];
- #print "type=$type\n";
- my $attr = {};
- if ( $type =~ m/^nchar|^nvar|^nclob/i )
- {
- $attr = $attrR;
- $note = $attr && $csform ? "with attribute { ora_csform =>
$csform }" : "";
- }
- ok( $sth->bind_param( $colnum++ ,$val ,$attr ) ,"bind_param " .
$$tcols[$i][0] ." $note" );
- }
- $cnt++;
- ok( $sth->execute ,"insert row $cnt: $rowR->[-1]" );
- }
-}
-sub dump_table
-{
- my ( $dbh ,@cols ) = @_;
-return; # not needed now select_handle() includes a DUMP column
- my $table = table();
- my $colstr = '';
- foreach my $col ( @cols ) {
- $colstr .= ", " if $colstr;
- $colstr .= "dump($col)"
- }
- my $sql = "select $colstr from $table order by idx" ;
- print "dumping $table\nprepared: $sql\n" ;
- my $colnum = 0;
- my $data = eval { $dbh->selectall_arrayref( $sql ) } || [];
- my $cnt = 0;
- while ( my $aref = shift @$data ) {
- $cnt++;
- my $colnum = 0;
- foreach my $col ( @cols ) {
- print "row $cnt: " ;
- print "$col=" .$$aref[$colnum] ."\n";
- $colnum++;
- }
- }
-}
-sub select_handle #1 test
-{
- my ($dbh,$tdata) = @_;
- my $table = table();
- my $sql = "select ";
- foreach my $col ( @{$tdata->{cols}} )
- {
- $sql .= $$col[0] . ", ";
- }
- $sql .= sprintf "$tdata->{dump}, ", $tdata->{cols}[0][0];
- $sql .= "dt from $table order by idx" ;
- my $h = $dbh->prepare( $sql );
- ok( $h ,"prepared: $sql" );
- return $h;
-}
-sub select_test_count
-{
- my ( $tdata ) = @_;
- my $rcnt = @{$tdata->{rows}};
- my $ccnt = @{$tdata->{cols}};
- return 2 + $ccnt + $rcnt * $ccnt * 2;
-}
-sub select_rows # 1 + numcols + rows * cols * 2
-{
- my ($dbh,$tdata,$csform) = @_;
- my $table = table();
- my $trows = $tdata->{rows};
- my $tcols = $tdata->{cols};
- my $sth = select_handle($dbh,$tdata)
- or do { fail(); return };
- my @data = ();
- my $colnum = 0;
- foreach my $col ( @$tcols )
- {
- ok( $sth->bind_col( $colnum+1 ,\$data[$colnum] ), "bind column "
.$$tcols[$colnum][0] );
- $colnum++;
- }
- my $dumpcol = sprintf $tdata->{dump}, $tdata->{cols}[0][0];
- #ok( $sth->bind_col( $colnum+1 ,\$data[$colnum] ), "bind column DUMP("
.$tdata->{cols}[0][0] .")" );
- $sth->bind_col( $colnum+1 ,\$data[$colnum] );
- my $cnt = 0;
- $sth->execute();
- while ( $sth->fetch() )
- {
- my $row = $cnt + 1;
- my $error = 0;
- my $i = 0;
- for( $i = 0 ; $i < @$tcols; $i++ )
- {
- my $res = $data[$i];
- my $charname = $trows->[$cnt][1] || '';
- my $is_utf8 = utf8::is_utf8( $res ) ? " (uft8)" : "";
- my $description = "row $row: column: $tcols->[$i][0] $is_utf8
$charname";
-
- $error += not cmp_ok_byte_nice($res, $$trows[$cnt][$i],
$description);
- #$sth->trace(0) if $cnt >= 3 ;
- }
- if ( $error )
- {
- warn "# row $row: $dumpcol = " .$data[$i]. "\n" ;
- }
- $cnt++;
- }
- #$sth->trace(0);
- my $trow_cnt = @$trows;
- cmp_ok( $cnt, '==', $trow_cnt, "number of rows fetched" );
-}
-
-sub cmp_ok_byte_nice {
- my ($got, $expected, $description) = @_;
- my $ok1 = cmp_ok( byte_string($got), 'eq', byte_string($expected),
- "byte_string test of $description"
- );
- my $ok2 = cmp_ok( nice_string($got), 'eq', nice_string($expected),
- "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);
- } else {
- #$sql =~ s/ \( */(\n\t/g;
- #$sql =~ s/, */,\n\t/g;
- diag("$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";
- diag($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>";
- diag($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") || '';
- $NLS_LANG =~ s/.*\.//;
- return $NLS_LANG =~ m/utf8/i;
-}
-sub client_nchar_is_utf8 {
- my $NLS_LANG = ora_env_var("NLS_LANG") || '';
- $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';
- diag(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) = @_;
- if ( $lang ) {
- $ENV{NLS_LANG} = "AMERICAN_AMERICA.$lang";
- diag("set \$ENV{NLS_LANG}=AMERICAN_AMERICA.$lang\n") if ( $verbose );
- } else {
- $ENV{NLS_LANG} = ""; # not the same as set_nls_nchar() above which
uses undef
- diag("set \$ENV{NLS_LANG}=''\n") if ( $verbose );
- }
- # 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;
-
- foreach my $c ( @chars )
- {
- if ( $c =~ m/\\x\{08(..)}/ ) {
- $c .= "='" .chr(hex($1)) ."'";
- }
- }
- my $ret = join("",@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 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 [EMAIL PROTECTED]" );
- unlink $sqlfile;
-}
-
-
-
-1;
-
+use strict;
+use warnings;
+use Carp;
+use Data::Dumper;
+use DBI;
+use DBD::Oracle qw(ORA_OCI ora_env_var);
+
+require utf8;
+
+# 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 =~ /^"/; # XXX ugly hack, sufficient here
+ return 0 if $v =~ /^'/; # 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');
+
+# disable diag unless TEST_VERBOSE is set.
+if (!exists($ENV{TEST_VERBOSE})) {
+ $tb->no_diag(1);
+}
+sub long_test_cols
+{
+ my ($type) = @_ ;
+ return
+ [
+ [ lng => $type ],
+ ];
+}
+sub char_cols
+{
+ [
+ [ ch => 'varchar2(20)' ],
+ [ descr => 'varchar2(50)' ],
+ ];
+}
+sub nchar_cols
+{
+ [
+ [ nch => 'nvarchar2(20)' ],
+ [ descr => 'varchar2(50)' ],
+ ];
+}
+sub 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 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
+ );
+}
+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} =~
/^$default/io);
+ $dsn ||= $default;
+ return $dsn;
+}
+
+sub db_handle
+{
+ my $dsn = oracle_test_dsn();
+ my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
+ my $dbh = DBI->connect($dsn, $dbuser, '', {
+ AutoCommit => 1,
+ PrintError => 1,
+ ora_envhp => 0, # force fresh environment (with current NLS env vars)
+ });
+ return $dbh;
+}
+sub show_test_data
+{
+ my ($tdata) = @_;
+ my $rowsR = $tdata->{rows};
+ my $cnt = 0;
+ my $vcnt = 0;
+ foreach my $recR ( @$rowsR )
+ {
+ $cnt++;
+ my $v = $$recR[0];
+ my $byte_string = byte_string($v);
+ my $nice_string = nice_string($v);
+ my $out = sprintf( "row: %3d: nice_string=%s byte_string=%s (%s,
%s)\n",
+ $cnt, $nice_string, $byte_string, $v,
DBI::neat($v));
+ diag($out);
+ }
+ return $cnt;
+}
+
+sub table { 'dbd_ora__drop_me'.($ENV{DBD_ORACLE_SEQ}||''); }
+sub drop_table
+{
+ my ($dbh) = @_;
+ my $table = table();
+ local $dbh->{PrintError} = 0;
+ $dbh->do(qq{ drop table $table }) if $dbh->{Active};
+}
+
+sub insert_handle
+{
+ my ($dbh,$tcols) = @_;
+ my $table = table();
+ my $sql = "insert into $table ( idx, ";
+ my $cnt = 1;
+ foreach my $col ( @$tcols )
+ {
+ $sql .= $$col[0] . ", ";
+ $cnt++;
+ }
+ $sql .= "dt ) values( " . "?, " x $cnt ."sysdate )";
+ my $h = $dbh->prepare( $sql );
+ ok( $h ,"prepared: $sql" );
+ return $h;
+}
+sub insert_test_count
+{
+ my ( $tdata ) = @_;
+ my $rcnt = @{$tdata->{rows}};
+ my $ccnt = @{$tdata->{cols}};
+ return 1 + $rcnt*2 + $rcnt * $ccnt;
+}
+sub insert_rows #1 + rows*2 +rows*ncols tests
+{
+ my ($dbh, $tdata ,$csform) = @_;
+ my $trows = $tdata->{rows};
+ my $tcols = $tdata->{cols};
+ my $table = table();
+ # local $dbh->{TraceLevel} = 4;
+ my $sth = insert_handle($dbh, $tcols);
+
+ my $cnt = 0;
+ foreach my $rowR ( @$trows )
+ {
+ my $colnum = 1;
+ my $attrR = $csform ? { ora_csform => $csform } : {};
+ ok( $sth->bind_param( $colnum++ ,$cnt ) ,"bind_param idx" );
+ for( my $i = 0; $i < @$rowR; $i++ )
+ {
+ my $note = 'withOUT attribute ora_csform';
+ my $val = $$rowR[$i];
+ my $type = $$tcols[$i][1];
+ #print "type=$type\n";
+ my $attr = {};
+ if ( $type =~ m/^nchar|^nvar|^nclob/i )
+ {
+ $attr = $attrR;
+ $note = $attr && $csform ? "with attribute { ora_csform =>
$csform }" : "";
+ }
+ ok( $sth->bind_param( $colnum++ ,$val ,$attr ) ,"bind_param " .
$$tcols[$i][0] ." $note" );
+ }
+ $cnt++;
+ ok( $sth->execute ,"insert row $cnt: $rowR->[-1]" );
+ }
+}
+sub dump_table
+{
+ my ( $dbh ,@cols ) = @_;
+return; # not needed now select_handle() includes a DUMP column
+ my $table = table();
+ my $colstr = '';
+ foreach my $col ( @cols ) {
+ $colstr .= ", " if $colstr;
+ $colstr .= "dump($col)"
+ }
+ my $sql = "select $colstr from $table order by idx" ;
+ print "dumping $table\nprepared: $sql\n" ;
+ my $colnum = 0;
+ my $data = eval { $dbh->selectall_arrayref( $sql ) } || [];
+ my $cnt = 0;
+ while ( my $aref = shift @$data ) {
+ $cnt++;
+ my $colnum = 0;
+ foreach my $col ( @cols ) {
+ print "row $cnt: " ;
+ print "$col=" .$$aref[$colnum] ."\n";
+ $colnum++;
+ }
+ }
+}
+sub select_handle #1 test
+{
+ my ($dbh,$tdata) = @_;
+ my $table = table();
+ my $sql = "select ";
+ foreach my $col ( @{$tdata->{cols}} )
+ {
+ $sql .= $$col[0] . ", ";
+ }
+ $sql .= sprintf "$tdata->{dump}, ", $tdata->{cols}[0][0];
+ $sql .= "dt from $table order by idx" ;
+ my $h = $dbh->prepare( $sql );
+ ok( $h ,"prepared: $sql" );
+ return $h;
+}
+sub select_test_count
+{
+ my ( $tdata ) = @_;
+ my $rcnt = @{$tdata->{rows}};
+ my $ccnt = @{$tdata->{cols}};
+ return 2 + $ccnt + $rcnt * $ccnt * 2;
+}
+sub select_rows # 1 + numcols + rows * cols * 2
+{
+ my ($dbh,$tdata,$csform) = @_;
+ my $table = table();
+ my $trows = $tdata->{rows};
+ my $tcols = $tdata->{cols};
+ my $sth = select_handle($dbh,$tdata)
+ or do { fail(); return };
+ my @data = ();
+ my $colnum = 0;
+ foreach my $col ( @$tcols )
+ {
+ ok( $sth->bind_col( $colnum+1 ,\$data[$colnum] ), "bind column "
.$$tcols[$colnum][0] );
+ $colnum++;
+ }
+ my $dumpcol = sprintf $tdata->{dump}, $tdata->{cols}[0][0];
+ #ok( $sth->bind_col( $colnum+1 ,\$data[$colnum] ), "bind column DUMP("
.$tdata->{cols}[0][0] .")" );
+ $sth->bind_col( $colnum+1 ,\$data[$colnum] );
+ my $cnt = 0;
+ $sth->execute();
+ while ( $sth->fetch() )
+ {
+ my $row = $cnt + 1;
+ my $error = 0;
+ my $i = 0;
+ for( $i = 0 ; $i < @$tcols; $i++ )
+ {
+ my $res = $data[$i];
+ my $charname = $trows->[$cnt][1] || '';
+ my $is_utf8 = utf8::is_utf8( $res ) ? " (uft8)" : "";
+ my $description = "row $row: column: $tcols->[$i][0] $is_utf8
$charname";
+
+ $error += not cmp_ok_byte_nice($res, $$trows[$cnt][$i],
$description);
+ #$sth->trace(0) if $cnt >= 3 ;
+ }
+ if ( $error )
+ {
+ warn "# row $row: $dumpcol = " .$data[$i]. "\n" ;
+ }
+ $cnt++;
+ }
+ #$sth->trace(0);
+ my $trow_cnt = @$trows;
+ cmp_ok( $cnt, '==', $trow_cnt, "number of rows fetched" );
+}
+
+sub cmp_ok_byte_nice {
+ my ($got, $expected, $description) = @_;
+ my $ok1 = cmp_ok( byte_string($got), 'eq', byte_string($expected),
+ "byte_string test of $description"
+ );
+ my $ok2 = cmp_ok( nice_string($got), 'eq', nice_string($expected),
+ "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;
+ diag("$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";
+ diag($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>";
+ diag($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") || '';
+ $NLS_LANG =~ s/.*\.//;
+ return $NLS_LANG =~ m/utf8/i;
+}
+sub client_nchar_is_utf8 {
+ my $NLS_LANG = ora_env_var("NLS_LANG") || '';
+ $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';
+ diag(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) = @_;
+ if ( $lang ) {
+ $ENV{NLS_LANG} = "AMERICAN_AMERICA.$lang";
+ diag("set \$ENV{NLS_LANG}=AMERICAN_AMERICA.$lang\n") if ( $verbose );
+ } else {
+ $ENV{NLS_LANG} = ""; # not the same as set_nls_nchar() above which
uses undef
+ diag("set \$ENV{NLS_LANG}=''\n") if ( $verbose );
+ }
+ # 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;
+
+ foreach my $c ( @chars )
+ {
+ if ( $c =~ m/\\x\{08(..)}/ ) {
+ $c .= "='" .chr(hex($1)) ."'";
+ }
+ }
+ my $ret = join("",@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 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 [EMAIL PROTECTED]" );
+ unlink $sqlfile;
+}
+
+
+
+1;
