view release on metacpan or  search on metacpan

t/25plsql.t  view on Meta::CPAN

    '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( join( ' ', sort @r ), join( ' ', sort @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;