Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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  
  


git-svn-id: http://svn.perl.org/modules/dbd-oracle/trunk@11613 50811bd7-b8ce-0310-adc1-d9db26280581
  • Loading branch information...
commit 0d7f97df347fe32ef61a2137e6450bbbe8630c87 1 parent 3e4d62a
byterock authored
View
5 Changes
@@ -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
View
11 Makefile.PL
@@ -1442,8 +1442,13 @@ sub find_headers {
"/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 @@ sub symbol_search {
use strict;
use Config;
+ sub libscan {
+ my($self, $path) = @_;
+ return '' if $path =~ m/\.pl$/;
+ $path;
+ }
+
sub post_initialize {
my $self = shift;
View
16 Oracle.pm
@@ -72,6 +72,7 @@ my $ORACLE_ENV = ($^O eq 'VMS') ? 'ORA_ROOT' : 'ORACLE_HOME';
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 @@ Uses the Oracle OCILobTrim function.
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 @@ can't be used effectively if AutoCommit is enabled).
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 @@ can't be used effectively if AutoCommit is enabled).
}
# 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 = '';
View
18 Oracle.xs
@@ -464,6 +464,24 @@ ora_lob_length(dbh, locator)
}
+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
View
6 README
@@ -110,8 +110,10 @@ The supplied tests will connect to the database using the value of the
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
View
9 ocitrace.h
@@ -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, \
View
12 t/30long.t
@@ -18,8 +18,11 @@ push @test_sets, [ "NCLOB", ORA_CLOB, 0 ] unless ORA_OCI() < 9.0 or $ENV{DBD_ALL
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 @@ sub run_long_tests
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" );
View
1,051 t/nchar_test_lib.pl
@@ -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 \@$sqlfile" );
- 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 \@$sqlfile" );
+ unlink $sqlfile;
+}
+
+
+
+1;
Please sign in to comment.
Something went wrong with that request. Please try again.