diff --git a/Changes b/Changes index 96eca20b..793aeda9 100644 --- a/Changes +++ b/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 diff --git a/Makefile.PL b/Makefile.PL index 1dbc3462..4eb0b141 100755 --- a/Makefile.PL +++ b/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; diff --git a/Oracle.pm b/Oracle.pm index 65aed504..b3c63aa5 100644 --- a/Oracle.pm +++ b/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 = ''; diff --git a/Oracle.xs b/Oracle.xs index 608c4975..30e508c1 100644 --- a/Oracle.xs +++ b/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 diff --git a/README b/README index 1e8bce34..fd2b28aa 100644 --- a/README +++ b/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 diff --git a/ocitrace.h b/ocitrace.h index 7019a270..b22ae131 100644 --- a/ocitrace.h +++ b/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, \ diff --git a/t/30long.t b/t/30long.t index 627b84b9..bb0b6488 100644 --- a/t/30long.t +++ b/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" ); diff --git a/t/nchar_test_lib.pl b/t/nchar_test_lib.pl index de46e8cf..48fea531 100644 --- a/t/nchar_test_lib.pl +++ b/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") || "", ora_env_var("NLS_NCHAR") || ""; - 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") || "", ora_env_var("NLS_NCHAR") || ""; + 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;