#!perl -w
use DBI;
use DBD::Oracle qw(ORA_RSET SQLCS_NCHAR);
use strict;
use Data::Dumper;
use Test::More;
unshift @INC ,'t';
require 'nchar_test_lib.pl';
$| = 1;
$ENV{NLS_DATE_FORMAT} = 'YYYY-MM-DD"T"HH24:MI:SS';
# create a database handle
my $dsn = oracle_test_dsn();
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbh;
eval {$dbh = DBI->connect($dsn, $dbuser, '',{ RaiseError=>1,
AutoCommit=>1,
PrintError => 0,
ora_objects => 1 })};
plan skip_all => "Unable to connect to Oracle" unless $dbh;
plan tests => 65;
my ($schema) = $dbuser =~ m{^([^/]*)};
# Test ora_objects flag
is $dbh->{ora_objects} => 1, 'ora_objects flag is set to 1';
$dbh->{ora_objects} = 0;
is $dbh->{ora_objects} => 0, 'ora_objects flag is set to 0';
# check that our db handle is good
isa_ok($dbh, "DBI::db");
ok( $schema = $dbh->selectrow_array(
"select sys_context('userenv', 'current_schema') from dual"
), 'Fetch current schema name');
my $obj_prefix = "dbd_test_";
my $super_type = "${obj_prefix}_type_A";
my $sub_type = "${obj_prefix}_type_B";
my $table = "${obj_prefix}_obj_table";
my $outer_type = "${obj_prefix}_outer_type";
my $inner_type = "${obj_prefix}_inner_type";
my $list_type = "${obj_prefix}_list_type";
my $nest_table = "${obj_prefix}_nest_table";
my $list_table = "${obj_prefix}_list_table";
sub drop_test_objects {
for my $obj ("TABLE $list_table", "TABLE $nest_table",
"TYPE $list_type", "TYPE $outer_type", "TYPE $inner_type",
"TABLE $table", "TYPE $sub_type", "TYPE $super_type") {
#do not warn if already there
eval {
local $dbh->{PrintError} = 0;
$dbh->do(qq{drop $obj});
};
}
}
&drop_test_objects;
# get the user's privileges
my $privs_sth = $dbh->prepare( 'SELECT PRIVILEGE from session_privs' );
$privs_sth->execute;
my @privileges = map { $_->[0] } @{ $privs_sth->fetchall_arrayref };
my $ora8 = $dbh->func('ora_server_version')->[0] < 9;
my $final = $ora8 ? '':'FINAL';
my $not_final = $ora8 ? '':'NOT FINAL';
SKIP: {
skip q{don't have permission to create type} => 61
unless grep { $_ eq 'CREATE TYPE' } @privileges;
sql_do_ok( $dbh, qq{ CREATE OR REPLACE TYPE $super_type AS OBJECT (
num INTEGER,
name VARCHAR2(20)
) $not_final } );
SKIP: {
skip 'Subtypes new in Oracle 9' => 1 if $ora8;
sql_do_ok( $dbh, qq{ CREATE OR REPLACE TYPE $sub_type UNDER $super_type (
datetime DATE,
amount NUMERIC(10,5)
) $not_final } );
}
sql_do_ok( $dbh, qq{ CREATE TABLE $table (id INTEGER, obj $super_type) });
sql_do_ok( $dbh, qq{ INSERT INTO $table VALUES (1, $super_type(13, 'obj1')) });
SKIP: {
skip 'Subtypes new in Oracle 9' => 2 if $ora8;
sql_do_ok( $dbh, qq{ INSERT INTO $table VALUES (2, $sub_type(NULL, 'obj2',
TO_DATE('2004-11-30 14:27:18', 'YYYY-MM-DD HH24:MI:SS'),
12345.6789)) }
);
sql_do_ok( $dbh, qq{ INSERT INTO $table VALUES (3, $sub_type(5, 'obj3', NULL,
777.666)) } );
}
sql_do_ok( $dbh, qq{ CREATE OR REPLACE TYPE $inner_type AS OBJECT (
num INTEGER,
name VARCHAR2(20)
) $final });
sql_do_ok( $dbh, qq{ CREATE OR REPLACE TYPE $outer_type AS OBJECT (
num INTEGER,
obj $inner_type
) $final });
sql_do_ok( $dbh, qq{ CREATE OR REPLACE TYPE $list_type AS
TABLE OF $inner_type });
sql_do_ok( $dbh, qq{ CREATE TABLE $nest_table(obj $outer_type) });
sql_do_ok( $dbh, qq{ INSERT INTO $nest_table VALUES($outer_type(91, $inner_type(1, 'one'))) }
);
sql_do_ok( $dbh, qq{ INSERT INTO $nest_table VALUES($outer_type(92, $inner_type(0, null))) }
);
sql_do_ok( $dbh, qq{ INSERT INTO $nest_table VALUES($outer_type(93, null)) }
);
sql_do_ok( $dbh, qq{ CREATE TABLE $list_table ( id INTEGER, list $list_type )
NESTED TABLE list STORE AS ${list_table}_list });
sql_do_ok( $dbh, qq{ INSERT INTO $list_table VALUES(81,$list_type($inner_type(null, 'listed'))) } );
# Test old (backward compatible) interface
# test select testing objects
my $sth = $dbh->prepare("select * from $table order by id");
ok ($sth, 'old: Prepare select');
ok ($sth->execute(), 'old: Execute select');
my ( @row1, @row2, @row3 );
@row1 = $sth->fetchrow();
ok (scalar @row1, 'old: Fetch first row');
cmp_ok(ref $row1[1], 'eq', 'ARRAY', 'old: Row 1 column 2 is an ARRAY');
cmp_ok(scalar(@{$row1[1]}), '==', 2, 'old: Row 1 column 2 is has 2 elements');
SKIP: {
skip 'Subtypes new in Oracle 9' => 6 if $ora8;
@row2 = $sth->fetchrow();
ok (scalar @row2, 'old: Fetch second row');
cmp_ok(ref $row2[1], 'eq', 'ARRAY', 'old: Row 2 column 2 is an ARRAY');
cmp_ok(scalar(@{$row2[1]}), '==', 2, 'old: Row 2 column 2 is has 2 elements');
@row3 = $sth->fetchrow();
ok (scalar @row3, 'old: Fetch third row');
cmp_ok(ref $row3[1], 'eq', 'ARRAY', 'old: Row 3 column 2 is an ARRAY');
cmp_ok(scalar(@{$row3[1]}), '==', 2, 'old: Row 3 column 2 is has 2 elements');
}
ok (!$sth->fetchrow(), 'old: No more rows expected');
#print STDERR Dumper(\@row1, \@row2, \@row3);
# Test new (extended) object interface
# enable extended object support
$dbh->{ora_objects} = 1;
# test select testing objects - in extended mode
$sth = $dbh->prepare("select * from $table order by id");
ok ($sth, 'new: Prepare select');
ok ($sth->execute(), 'new: Execute select');
@row1 = $sth->fetchrow();
ok (scalar @row1, 'new: Fetch first row');
cmp_ok(ref $row1[1], 'eq', 'DBD::Oracle::Object', 'new: Row 1 column 2 is an DBD:Oracle::Object');
cmp_ok(uc $row1[1]->type_name, "eq", uc "$schema.$super_type", "new: Row 1 column 2 object type");
is_deeply([$row1[1]->attributes], ['NUM', 13, 'NAME', 'obj1'], "new: Row 1 column 2 object attributes");
SKIP: {
skip 'Subtypes new in Oracle 9' => 8 if $ora8;
@row2 = $sth->fetchrow();
ok (scalar @row2, 'new: Fetch second row');
cmp_ok(ref $row2[1], 'eq', 'DBD::Oracle::Object', 'new: Row 2 column 2 is an DBD::Oracle::Object');
cmp_ok(uc $row2[1]->type_name, "eq", uc "$schema.$sub_type", "new: Row 2 column 2 object type");
my %attrs = $row2[1]->attributes;
$attrs{AMOUNT} = sprintf "%9.4f", $attrs{AMOUNT};
is_deeply( \%attrs, {'NUM', undef, 'NAME', 'obj2',
'DATETIME', '2004-11-30T14:27:18', 'AMOUNT', '12345.6789'}, "new: Row 1 column 2 object attributes");
@row3 = $sth->fetchrow();
ok (scalar @row3, 'new: Fetch third row');
cmp_ok(ref $row3[1], 'eq', 'DBD::Oracle::Object', 'new: Row 3 column 2 is an DBD::Oracle::Object');
cmp_ok(uc $row3[1]->type_name, "eq", uc "$schema.$sub_type", "new: Row 3 column 2 object type");
%attrs = $row3[1]->attributes;
$attrs{AMOUNT} = sprintf "%6.3f", $attrs{AMOUNT};
is_deeply( \%attrs, {'NUM', 5, 'NAME', 'obj3',
'DATETIME', undef, 'AMOUNT', '777.666'}, "new: Row 1 column 2 object attributes");
}
ok (!$sth->fetchrow(), 'new: No more rows expected');
#print STDERR Dumper(\@row1, \@row2, \@row3);
SKIP: {
skip 'Subtypes new in Oracle 9' => 3 if $ora8;
# Test DBD::Oracle::Object
my $obj = $row3[1];
my $expected_hash = {
NUM => 5,
NAME => 'obj3',
DATETIME => undef,
AMOUNT => 777.666,
};
my $attrs = $obj->attr_hash;
$attrs->{AMOUNT} = sprintf "%6.3f", $attrs->{AMOUNT};
is_deeply($attrs, $expected_hash, 'DBD::Oracle::Object->attr_hash');
is_deeply($obj->attr, $expected_hash, 'DBD::Oracle::Object->attr');
is($obj->attr("NAME"), 'obj3', 'DBD::Oracle::Object->attr("NAME")');
}
# try the list table
$sth = $dbh->prepare("select * from $list_table");
ok ($sth, 'new: Prepare select with nested table of objects');
ok ($sth->execute(), 'new: Execute (nested table)');
@row1 = $sth->fetchrow();
ok (scalar @row1, 'new: Fetch first row (nested table)');
is_deeply($row1[1]->[0]->attr, {NUM=>undef, NAME=>'listed'},
'Check propertes of first (and only) item in nested table');
ok (!$sth->fetchrow(), 'new: No more rows expected (nested table)');
#try the nested table
$sth = $dbh->prepare("select * from $nest_table");
ok ($sth, 'new: Prepare select with nested object');
ok ($sth->execute(), 'new: Execute (nested object)');
@row1 = $sth->fetchrow();
ok (scalar @row1, 'new: Fetch first row (nested object)');
is($row1[0]->attr->{NUM}, '91', 'Check obj.num');
is_deeply($row1[0]->attr->{OBJ}->attr, {NUM=>'1', NAME=>'one'}, 'Check obj.obj');
@row2 = $sth->fetchrow();
ok (scalar @row2, 'new: Fetch second row (nested object)');
is($row2[0]->attr->{NUM}, '92', 'Check obj.num');
is_deeply($row2[0]->attr->{OBJ}->attr, {NUM=>'0', NAME=>undef}, 'Check obj.obj');
@row3 = $sth->fetchrow();
ok (scalar @row3, 'new: Fetch third row (nested object)');
is_deeply($row3[0]->attr, {NUM=>'93', OBJ=>undef}, 'Check obj');
ok (!$sth->fetchrow(), 'new: No more rows expected (nested object)');
}
#cleanup
&drop_test_objects;
$dbh->disconnect;
1;
sub sql_do_ok {
my ( $dbh, $sql, $title ) = @_;
$title = $sql unless defined $title;
ok( $dbh->do( $sql ), $title ) or diag $dbh->errstr;
}