The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl
$| = 1;

## ----------------------------------------------------------------------------
## 14threads.t
## By Jeffrey Klein, 
## ----------------------------------------------------------------------------

BEGIN { eval "use threads; use threads::shared;" }
my $use_threads_err = $@;
use DBI;
use Config qw(%Config);
use Test::More;

BEGIN {
    if ( !$Config{useithreads} || $] < 5.008 ) {
        plan skip_all => "this $^O perl $] not configured to support iThreads";
    } elsif ($DBI::VERSION <= 1.601){
      plan skip_all => "DBI version ".$DBI::VERSION." does not support iThreads. Use version 1.602 or later.";
     }
    die $use_threads_err if $use_threads_err;    # need threads
}

use strict;
use DBI;

use Test::More;

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

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

if ($dbh) {
    plan tests => 19;
    $dbh->disconnect;
} else {
    plan skip_all => "Unable to connect to Oracle";
}

my $last_session : shared;
our @pool : shared;

# run five threads in sequence
# each should get the same session

# TESTS: 5

for my $i ( 0 .. 4 ) {
    threads->create(
        sub {
            my $dbh = get_dbh_from_pool();

            my $session = session_id($dbh);

            if ( $i > 0 ) {
                is $session, $last_session,
                  "session $i matches previous session";
            } else {
                ok $session, "session $i created",
            }

            $last_session = $session;
            free_dbh_to_pool($dbh);
        }
    )->join;
   

}

# TESTS: 1
is scalar(@pool), 1, 'one imp_data in pool';
 
# get two sessions in same thread
# TESTS: 2
threads->create(
    sub {
        my $dbh1 = get_dbh_from_pool();
        my $s1   = session_id($dbh1);

        my $dbh2 = get_dbh_from_pool();
        my $s2   = session_id($dbh2);

        ok $s1 ne $s2, 'thread gets two separate sessions';

        free_dbh_to_pool($dbh1);

        my $dbh3 = get_dbh_from_pool();
        my $s3   = session_id($dbh3);

        is $s3, $s1, 'get same session after free';

        free_dbh_to_pool($dbh2);
        free_dbh_to_pool($dbh3);
    }
)->join;

# TESTS: 1
is scalar(@pool), 2, 'two imp_data in pool';

#trade dbh between threads
my @thr;
my @sem;
use Thread::Semaphore;

# create locked semaphores
for my $i (0..2) {
   push @sem, Thread::Semaphore->new(0);
}

undef $last_session;

# 3 threads, 3 iterations
# TESTS: 9
for my $t ( 0..2 ) {
    $thr[$t] = threads->create(
        sub {
            my $partner = ( $t + 1 ) % 3;

            for my $i ( 1 .. 3 ) {
                $sem[$t]->down;

                my $dbh     = get_dbh_from_pool();
                my $session = session_id($dbh);
                if ( defined $last_session ) {
                    is $session, $last_session,
                      "thread $t, loop $i matches previous session";
                } else {
                    ok $session,
                      "thread $t, loop $i created session";
                }
                $last_session = $session;
                free_dbh_to_pool($dbh);

                # signal next thread
                $sem[$partner]->up;
            }
        }
    );
}

# start thread 0!
$sem[0]->up;

$_->join for @thr;

# TESTS: 1
empty_pool();

is scalar(@pool), 0, 'pool empty';

exit;

sub get_dbh_from_pool {
    my $imp = pop @pool;

    # if pool is empty, $imp is undef
    # in that case, get new dbh
    return connect_dbh($imp);
}

sub free_dbh_to_pool {
    my $imp = $_[0]->take_imp_data or return;
    push @pool, $imp;
}

sub empty_pool {
    get_dbh_from_pool() while @pool;
}

sub connect_dbh {
    my $imp_data = shift;
    my $dsn      = oracle_test_dsn();
    my $dbuser   = $ENV{ORACLE_USERID} || 'scott/tiger';
    DBI->connect( $dsn, $dbuser, '', { dbi_imp_data => $imp_data } );
}

sub session_id {
    my $dbh = shift;
    my ($s) = $dbh->selectrow_array("select userenv('sessionid') from dual");
    return $s;
}
__END__