#!perl -w

##----------------------------------------------------------------------------
## 36lob_leak.pl
## By Martin Evans, Easysoft Limited
##----------------------------------------------------------------------------
## Test we are not leaking temporary lobs
##----------------------------------------------------------------------------

use Test::More;

use DBI;
use Config;
use DBD::Oracle qw(:ora_types);
use strict;
use warnings;
use Data::Dumper;

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) {
   plan tests => 7;
} else {
   $dbh->{PrintError}=1;
   plan skip_all => "Unable to connect to Oracle";
}

# get SID and cached lobs
# if sid not passed in we run 2 tests, get the sid and the cached lobs
# if sid passed in we run 1 test which is to get the cached lobs
sub get_cached_lobs
{
   my ($dbh, $sid) = @_;
   my $cached_lobs;

   if (!defined($sid)) {
     SKIP: {
           eval {
               ($sid) = $dbh->selectrow_array(
                   q/select sid from v$session where audsid =
SYS_CONTEXT('userenv', 'sessionid')/);
           };
           skip 'unable to find sid', 2 if ($@ || !defined($sid));

           pass("found sid $sid");
       };
   }
   if (defined($sid)) {
     SKIP: {
           eval {
               $cached_lobs = $dbh->selectrow_array(
                   q/select CACHE_LOBS from V$TEMPORARY_LOBS where sid
= ?/, undef, $sid);
           };
           skip 'unable to find cached lobs', 1
               if ($@ || !defined($cached_lobs));
           pass("found $cached_lobs cached lobs");
       };
   }
   return ($sid, $cached_lobs);
}

sub setup_test
{
   my ($h) = @_;
   my ($sth, $ev);

   my $fn = 'p_DBD_Oracle_drop_me';

   my $createproc = << "EOT";
CREATE OR REPLACE FUNCTION $fn(pc IN CLOB) RETURN NUMBER AS
BEGIN
   NULL;
   RETURN 0;
END;
EOT

   eval {$h->do($createproc);};
   BAIL_OUT("Failed to create test function - $@") if $@;
   pass("created test function");

   return $fn;
}

sub call_func
{
   my ($dbh, $function, $how) = @_;

   eval {
       my $sth;
       my $sql = qq/BEGIN ? := $function(?); END;/;
       if ($how eq 'prepare') {
           $sth = $dbh->prepare($sql) or die($dbh->errstr);
       } elsif ($how eq 'prepare_cached') {
           $sth = $dbh->prepare_cached($sql) or die($dbh->errstr);
       } else {
           BAIL_OUT("Unknown prepare type $how");
       }
       $sth->{RaiseError} = 1;

       BAIL_OUT("Cannot prepare a call to $function") if !$sth;

       my ($return, $clob);
       $clob = 'x' x 1000;
       $sth->bind_param_inout(1, \$return, 10);
       $sth->bind_param(2, $clob, {ora_type => ORA_CLOB});
       $sth->execute;
   };
   BAIL_OUT("Cannot call $function successfully") if $@;
}


my ($sid, $cached_lobs);
my ($function);
SKIP: {
   ($sid, $cached_lobs) = get_cached_lobs($dbh); # 1 2
   skip 'Cannot find sid/cached lobs', 5 if !defined($cached_lobs);

   $function = setup_test($dbh); # 3
   my $new_cached_lobs;

   foreach my $type (qw(prepare prepare_cached)) {
       for my $count(1..100) {
           call_func($dbh, $function, $type);
       };
       ($sid, $new_cached_lobs) = get_cached_lobs($dbh, $sid);

       # we expect to leak 1 temporary lob as the last statement is
       # cached and the temp lob is not thrown away until you next
       # execute
       if ($new_cached_lobs > ($cached_lobs + 1)) {
           diag("Looks like we might be leaking temporary lobs from
$type");
           fail("old cached lobs: $cached_lobs " .
                    "new cached lobs: $new_cached_lobs");
       } else {
           pass("Not leaking temporary lobs on $type");
       }
       $cached_lobs = $new_cached_lobs;
   }

};

END {
   if ($dbh) {
       local $dbh->{PrintError} = 0;
       local $dbh->{RaiseError} = 1;
       if ($function){
          eval {$dbh->do(qq/drop function $function/);};
          if ($@) {
             diag("function p_DBD_Oracle_drop_me possibly not dropped" .
                    "- check - $@\n") if $dbh->err ne '4043';
          } else {
             note("function p_DBD_Oracle_drop_me dropped");
          }
       }
   }
}