#!perl -w
sub ok ($$;$) {
my($n, $ok, $warn) = @_;
++$t;
die "sequence error, expected $n but actually $t"
if $n and $n != $t;
($ok) ? print "ok $t\n"
: print "# failed test $t at line ".(caller)[2]."\nnot ok $t\n";
if (!$ok && $warn) {
$warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1';
warn "$warn\n";
}
}
use strict;
use DBI qw(neat);
use DBD::Oracle qw(ORA_OCI);
use vars qw($tests);
unshift @INC ,'t';
require 'nchar_test_lib.pl';
$| = 1;
$^W = 1;
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dsn = oracle_test_dsn();
my $dbh = DBI->connect($dsn, $dbuser, '', {
AutoCommit => 0,
PrintError => 1,
FetchHashKeyName => 'NAME_lc',
});
unless($dbh) {
warn "Unable to connect to Oracle ($DBI::errstr)\nTests skipped.\n";
print "1..0\n";
exit 0;
}
eval {
require Data::Dumper;
$Data::Dumper::Useqq = $Data::Dumper::Useqq =1;
$Data::Dumper::Terse = $Data::Dumper::Terse =1;
$Data::Dumper::Indent= $Data::Dumper::Indent=1;
};
# XXX ought to extend tests to check 'blank padded comparision semantics'
my @tests = (
# type: oracle internal type to use for placeholder values
# name: oracle name for type above
# chops_space: set true if type trims trailing space characters
# embed_nul: set true if type allows embedded nul characters
# (also SKIP=1 to skip test, ti=N to trace insert, ts=N to trace select)
{ type=> 1, name=>"VARCHAR2", chops_space=>1, embed_nul=>1, }, # current DBD::Oracle
{ type=> 5, name=>"STRING", chops_space=>0, embed_nul=>0, SKIP=>1, ti=>8 }, # old Oraperl
{ type=>96, name=>"CHAR", chops_space=>0, embed_nul=>1, },
{ type=>97, name=>"CHARZ", chops_space=>0, embed_nul=>0, SKIP=>1, ti=>8 },
);
$tests = 3;
$_->{SKIP} or $tests+=8 for @tests;
print "1..$tests\n";
my ($sth,$tmp);
my $table = "dbd_ora__drop_me" . ($ENV{DBD_ORACLE_SEQ}||'');
# drop table but don't warn if not there
eval {
local $dbh->{PrintError} = 0;
$dbh->do("DROP TABLE $table");
};
ok(0, $dbh->do("CREATE TABLE $table (name VARCHAR2(2), vc VARCHAR2(20), c CHAR(20))"));
my $val_with_trailing_space = "trailing ";
my $val_with_embedded_nul = "embedded\0nul";
for my $test_info (@tests) {
next if $test_info->{SKIP};
my $ph_type = $test_info->{type} || die;
my $name = $test_info->{name} || die;
print "#\n";
print "# testing @{[ %$test_info ]} ...\n";
print "#\n";
if ($test_info->{SKIP}) {
print "# skipping tests\n";
foreach (1..12) { ok(0,1) }
next;
}
$dbh->{ora_ph_type} = $ph_type;
ok(0, $dbh->{ora_ph_type} == $ph_type );
$sth = $dbh->prepare("INSERT INTO $table(name,vc,c) VALUES (?,?,?)");
$sth->trace($test_info->{ti}) if $test_info->{ti};
$sth->execute("ts", $val_with_trailing_space, $val_with_trailing_space);
$sth->execute("en", $val_with_embedded_nul, $val_with_embedded_nul);
$sth->execute("es", '', ''); # empty string
$sth->trace(0) if $test_info->{ti};
$dbh->trace($test_info->{ts}) if $test_info->{ts};
$tmp = $dbh->selectall_hashref(qq{
SELECT name, vc, length(vc) as len, nvl(vc,'ISNULL') as isnull, c
FROM $table
}, "name");
ok(0, keys(%$tmp) == 3);
$dbh->trace(0) if $test_info->{ts};
$dbh->rollback;
delete $_->{name} foreach values %$tmp;
print Data::Dumper::Dumper($tmp);
# check trailing_space behaviour
my $expect = $val_with_trailing_space;
$expect =~ s/\s+$// if $test_info->{chops_space};
my $ok = ($tmp->{ts}->{vc} eq $expect);
if (!$ok && $ph_type==1 && $name eq 'VARCHAR2') {
warn " Placeholder behaviour for ora_type=1 (the default) varies with Oracle version.\n";
warn " Oracle 7 didn't strip trailing spaces, Oracle 8 did, until 9.2.x\n";
warn " Your system doesn't. If that seems odd, let us know.\n";
$ok = 1;
}
ok(0, $ok, sprintf(" using ora_type %d expected %s but got %s for $name",
$ph_type, neat($expect), neat($tmp->{ts}->{vc})) );
# check embedded nul char behaviour
$expect = $val_with_embedded_nul;
$expect =~ s/\0.*// unless $test_info->{embed_nul};
ok(0, $tmp->{en}->{vc} eq $expect, sprintf(" expected %s but got %s for $name",
neat($expect),neat($tmp->{en}->{vc})) );
# check empty string is NULL (irritating Oracle behaviour)
ok(0, !defined $tmp->{es}->{vc});
ok(0, !defined $tmp->{es}->{c});
ok(0, !defined $tmp->{es}->{len});
ok(0, $tmp->{es}->{isnull} eq 'ISNULL');
exit 1 if $test_info->{ti} || $test_info->{ts};
}
ok(0, $dbh->do("DROP TABLE $table"));
ok(0, $dbh->disconnect );
__END__