t/25plsql.t - metacpan.org

#!perl -w
use Test::More;

use DBI;
use DBD::Oracle qw(ORA_RSET SQLCS_NCHAR);
use strict;

unshift @INC ,'t';
require 'nchar_test_lib.pl';

$| = 1;

my $dsn = oracle_test_dsn();
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbh = DBI->connect($dsn, $dbuser, '', { PrintError => 0 });

if ($dbh) {
    # ORA-00900: invalid SQL statement
    # ORA-06553: PLS-213: package STANDARD not accessible
    my $tst = $dbh->prepare(q{declare foo char(50); begin RAISE INVALID_NUMBER; end;});
    if ($dbh->err && ($dbh->err==900 || $dbh->err==6553 || $dbh->err==600)) {
        diag("Your Oracle server doesn't support PL/SQL") if $dbh->err== 900;
        diag("Your Oracle PL/SQL is not properly installed")
            if $dbh->err==6553||$dbh->err==600;
        plan skip_all => 'Oracle server either does not support pl/sql or it is not properly installed';
    }
    plan tests=>82;
} else {
    plan skip_all => "Unable to connect to Oracle \n";
}


my($csr, $p1, $p2, $tmp, @tmp);
#DBI->trace(4,"trace.log");


# --- test raising predefined exception
ok($csr = $dbh->prepare(q{
    begin RAISE INVALID_NUMBER; end;}), 'prepare raising predefined exception');

# ORA-01722: invalid number
ok(! $csr->execute, 'execute predefined exception');
is($DBI::err, 1722, 'err expected 1722 error');
is($DBI::err, 1722, 'err does not get cleared');


# --- test raising user defined exception
ok($csr = $dbh->prepare(q{
    DECLARE FOO EXCEPTION;
    begin raise FOO; end;}), 'prepare user defined expcetion');

# ORA-06510: PL/SQL: unhandled user-defined exception
ok(! $csr->execute, 'execute user defined exception');
is($DBI::err, 6510, 'user exception 6510 error');


# --- test raise_application_error with literal values
ok($csr = $dbh->prepare(q{
    declare err_num number; err_msg char(510);
    begin RAISE_APPLICATION_ERROR(-20101,'app error'); end;}),
  'prepare raise application error with literal values');

# ORA-20101: app error
ok(! $csr->execute, 'execite raise application error with literal values');
is($DBI::err, 20101, 'expected 20101 error');
like($DBI::errstr, qr/app error/, 'app error');


# --- test raise_application_error with 'in' parameters
ok($csr = $dbh->prepare(q{
    declare err_num varchar2(555); err_msg varchar2(510);
    --declare err_num number; err_msg char(510);
    begin
	err_num := :1;
	err_msg := :2;
	raise_application_error(-20000-err_num, 'msg is '||err_msg);
    end;
}), 'prepare raise application error with in params');

ok(! $csr->execute(42, "hello world"),
   'execute raise application error with in params');
is($DBI::err, 20042, 'expected 20042 error');
like($DBI::errstr, qr/msg is hello world/, 'hello world msg');

# --- test named numeric in/out parameters
ok($csr = $dbh->prepare(q{
    begin
	:arg := :arg * :mult;
    end;}), 'prepare named numeric in/out params');

$p1 = 3;
ok($csr->bind_param_inout(':arg', \$p1, 50), 'bind arg');
ok($csr->bind_param(':mult', 2), 'bind mult');
ok($csr->execute, 'execute named numeric in/out params');
is($p1, 6, 'expected 3 * 3 = 6');
# execute 10 times from $p1=1, 2, 4, 8, ... 1024
$p1 = 1;
eval {
    foreach (1..10) { $csr->execute || die $DBI::errstr; };
};
my $ev = $@;
ok(!$ev, 'execute named numeric in/out params 10 times');
is($p1, 1024, 'expected p1 = 1024');

# --- test undef parameters
ok($csr = $dbh->prepare(q{
	declare foo char(500);
	begin foo := :arg; end;}), 'prepare undef parameters');
my $undef;
ok($csr->bind_param_inout(':arg', \$undef,10), 'bind arg');
ok($csr->execute, 'execute undef parameters');

# --- test named string in/out parameters
ok($csr = $dbh->prepare(q{
    declare str varchar2(1000);
    begin
	:arg := nvl(upper(:arg), 'null');
	:arg := :arg || :append;
    end;}), 'prepare named string in/out parameters');

undef $p1;
$p1 = "hello world";
ok($csr->bind_param_inout(':arg', \$p1, 1000), 'bind arg');
ok($csr->bind_param(':append', "!"), 'bind append');
ok($csr->execute, 'execute named string in/out parameters');
is($p1, "HELLO WORLD!", 'expected HELLO WORLD');
# execute 10 times growing $p1 to force realloc
eval {
    foreach (1..10) {
        $p1 .= " xxxxxxxxxx";
        $csr->execute || die $DBI::errstr;
    };
};
$ev = $@;
ok(!$ev, 'execute named string in/out parameters 1- times');
my $expect = "HELLO WORLD!" . (" XXXXXXXXXX!" x 10);
is($p1, $expect, 'p1 as expected');

# --- test binding a null and getting a string back
undef $p1;
ok($csr->execute, 'execute binding a null');
is($p1, 'null!', 'get a null string back');

$csr->finish;


ok($csr = $dbh->prepare(q{
    begin
	:out := nvl(upper(:in), 'null');
    end;}), 'prepare nvl');
#$csr->trace(3);
my $out;
ok($csr->bind_param_inout(':out', \$out, 1000), 'bind out');
ok($csr->bind_param(':in', "foo", DBI::SQL_CHAR()), 'bind in');
ok($csr->execute, 'execute nvl');
is($out, "FOO", 'expected FOO');

ok($csr->bind_param(':in', ""), 'bind empty string');
ok($csr->execute, 'execute empty string');
is($out, "null", 'returned null string');

# --- test out buffer being too small
ok($csr = $dbh->prepare(q{
    begin
	select rpad('foo',200) into :arg from dual;
    end;}), 'prepare test output buffer too small');
#$csr->trace(3);
undef $p1;	# force buffer to be freed
ok($csr->bind_param_inout(':arg', \$p1, 20), 'bind arg');
# Execute fails with:
#	ORA-06502: PL/SQL: numeric or value error
#	ORA-06512: at line 3 (DBD ERROR: OCIStmtExecute)
$tmp = $csr->execute;
#$tmp = undef if DBD::Oracle::ORA_OCI()>=8; # because BindByName given huge max len
ok(!defined $tmp, 'output buffer too small');
# rebind with more space - and it should work
ok($csr->bind_param_inout(':arg', \$p1, 200), 'rebind arg with more space');
ok($csr->execute, 'execute rebind with more space');
is(length($p1), 200, 'expected return length');


# --- test plsql_errstr function
#$csr = $dbh->prepare(q{
#    create or replace procedure perl_dbd_oracle_test as
#    begin
#	  procedure filltab( stuff out tab ); asdf
#    end;
#});
#ok(0, ! $csr);
#if ($dbh->err && $dbh->err == 6550) {	# PL/SQL error
#	warn "errstr: ".$dbh->errstr;
#	my $msg = $dbh->func('plsql_errstr');
#	warn "plsql_errstr: $msg";
#	ok(0, $msg =~ /Encountered the symbol/, "plsql_errstr: $msg");
#}
#else {
#	warn "plsql_errstr test skipped ($DBI::err)\n";
#	ok(0, 1);
#}
#die;

# --- test dbms_output_* functions
$dbh->{PrintError} = 1;
ok($dbh->func(30000, 'dbms_output_enable'), 'dbms_output_enable');

#$dbh->trace(3);
my @ary = ("foo", ("bar" x 15), "baz", "boo");
ok($dbh->func(@ary, 'dbms_output_put'), 'dbms_output_put');

@ary = scalar $dbh->func('dbms_output_get');	# scalar context
ok(@ary==1 && $ary[0] && $ary[0] eq 'foo', 'dbms_output_get foo');

@ary = scalar $dbh->func('dbms_output_get');	# scalar context
ok(@ary==1 && $ary[0] && $ary[0] eq 'bar' x 15, 'dbms_output_get bar');

@ary = $dbh->func('dbms_output_get');			# list context
is(join(':',@ary), 'baz:boo', 'dbms_output_get baz:boo');
$dbh->{PrintError} = 0;
#$dbh->trace(0);

# --- test cursor variables
if (1) {
    my $cur_query = q{
	SELECT object_name, owner
	FROM all_objects
	WHERE object_name LIKE :p1
	ORDER BY object_name
    };
    my $cur1 = 42;
    #$dbh->trace(4);
    my $parent = $dbh->prepare(qq{
	BEGIN OPEN :cur1 FOR $cur_query; END;
    });
    ok($parent, 'prepare cursor');
    ok($parent->bind_param(":p1", "V%"), 'bind p1');
    ok($parent->bind_param_inout(
        ":cur1", \$cur1, 0, { ora_type => ORA_RSET }), 'bind cursor');
    ok($parent->execute(), 'execute for cursor');
    my @r;
    push @r, @tmp while @tmp = $cur1->fetchrow_array;
    ok(@r>0, "rows: ".@r);
    #$dbh->trace(0); $parent->trace(0);

    # compare results with normal execution of query
    my $s1 = $dbh->selectall_arrayref($cur_query, undef, "V%");
    my @s1 = map { @$_ } @$s1;
    is("@r", "@s1", "ref = sql");

    # --- test re-bind and re-execute of same 'parent' statement
    my $cur1_str = "$cur1";
    #$dbh->trace(4); $parent->trace(4);
    ok($parent->bind_param(":p1", "U%"), 'bind p1');
    ok($parent->execute(), 'execute for cursor');
    # must be ref to new handle object
    isnt("$cur1", $cur1_str, 'expected ref to new handle');
    @r = ();
    push @r, @tmp while @tmp = $cur1->fetchrow_array;
    #$dbh->trace(0); $parent->trace(0); $cur1->trace(0);
    my $s2 = $dbh->selectall_arrayref($cur_query, undef, "U%");
    my @s2 = map { @$_ } @$s2;
    is("@r", "@s2", "ref = sql");
}

# test bind_param_inout of param that's not assigned to in executed statement
# See http://www.mail-archive.com/dbi-users@perl.org/msg18835.html
my $sth = $dbh->prepare (q(
    BEGIN
 --     :p1 := :p1 ;
 --     :p2 := :p2 ;
        IF  :p2 != :p3 THEN
            :p1 := 'AAA' ;
            :p2 := 'Z' ;
        END IF ;
END ;));

{
    my ($p1, $p2, $p3) = ('Hello', 'Y', 'Y') ;
    $sth->bind_param_inout(':p1', \$p1, 30) ;
    $sth->bind_param_inout(':p2', \$p2, 1) ;
    $sth->bind_param_inout(':p3', \$p3, 1) ;
    note("Before p1=[$p1] p2=[$p2] p3=[$p3]\n");
    ok($sth->execute, 'test bind_param_inout for non assigned');
    is($p1, 'Hello', 'p1 ok');
    is($p2, 'Y', 'p2 ok');
    is($p3, 'Y', 'p3 ok');
    note("After p1=[$p1] p2=[$p2] p3=[$p3]\n");
}

SKIP: {
    # test nvarchar2 arg passing to functions
    # http://www.nntp.perl.org/group/perl.dbi.users/24217
    my $ora_server_version = $dbh->func("ora_server_version");
    skip "Client/server version < 9.0", 15
	if DBD::Oracle::ORA_OCI() < 9.0 || $ora_server_version->[0] < 9;

    my $func_name = "dbd_oracle_nvctest".($ENV{DBD_ORACLE_SEQ}||'');
    $dbh->do(qq{
	CREATE OR REPLACE FUNCTION $func_name(arg nvarchar2, arg2 nvarchar2)
	RETURN int IS
	BEGIN
	  if arg is null or arg2 is null then
	     return -1;
	  else
	     return 1;
	  end if;
	END;
    }) or skip "Can't create a function ($DBI::errstr)", 15;
    my $sth = $dbh->prepare(qq{SELECT $func_name(?, ?) FROM DUAL}, {
	# Oracle 8 describe fails with ORA-06553: PLS-561: charset mismatch
	ora_check_sql => 0,
    });
    ok($sth, sprintf("Can't prepare select from function (%s)",$DBI::errstr||''));
    skip "Can't select from function ($DBI::errstr)", 14 unless $sth;
    for (1..2) {
	ok($sth->bind_param(1, "foo", { ora_csform => SQLCS_NCHAR }),
           'bind foo');
	ok($sth->bind_param(2, "bar", { ora_csform => SQLCS_NCHAR }),
          'bind bar');
	ok($sth->execute(), 'execute');
	ok(my($returnVal) = $sth->fetchrow_array, 'fetchrow returns value');
	is($returnVal, "1", 'expected return value of 1');
    }
    ok($sth->execute("baz",undef), 'execute with baz');
    ok(my($returnVal) = $sth->fetchrow_array, 'fetchrow_returns value');
    is($returnVal, "-1", 'expected -1 return');
    ok($dbh->do(qq{drop function $func_name}), "drop $func_name");
}


# --- To do
    #   test NULLs at first bind
    #   NULLs later binds.
    #   returning NULLs
    #   multiple params, mixed types and in only vs inout


exit 0;

__END__
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)