Author: byterock
Date: Wed Feb 6 10:37:45 2008
New Revision: 10698
Added:
dbd-oracle/trunk/t/12impdata.t
dbd-oracle/trunk/t/14threads.t
Modified:
dbd-oracle/trunk/Oracle.pm
dbd-oracle/trunk/dbdimp.c
Log:
Patch from Jeffrey Klein for dbi_imp_data code
Modified: dbd-oracle/trunk/Oracle.pm
==============================================================================
--- dbd-oracle/trunk/Oracle.pm (original)
+++ dbd-oracle/trunk/Oracle.pm Wed Feb 6 10:37:45 2008
@@ -212,6 +212,7 @@
(my $user_only = $user) =~ s:/.*::;
my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, {
'Name' => $dbname,
+ 'dbi_imp_data' => $attr->{dbi_imp_data},
# these two are just for backwards compatibility
'USER' => uc $user_only, 'CURRENT_USER' => uc $user_only,
});
Modified: dbd-oracle/trunk/dbdimp.c
==============================================================================
--- dbd-oracle/trunk/dbdimp.c (original)
+++ dbd-oracle/trunk/dbdimp.c Wed Feb 6 10:37:45 2008
@@ -336,7 +336,22 @@
D_imp_drh_from_dbh;
ub2 new_charsetid = 0;
ub2 new_ncharsetid = 0;
+ /* dbi_imp_data code adapted from DBD::mysql */
+ if (DBIc_has(imp_dbh, DBIcf_IMPSET)) {
+ /* dbi_imp_data from take_imp_data */
+ if (DBIc_has(imp_dbh, DBIcf_ACTIVE)) {
+ if (DBIS->debug >= 2)
+ PerlIO_printf(DBILOGFP, "dbd_db_login6 skip connect\n");
+ /* tell our parent we've adopted an active child */
+ ++DBIc_ACTIVE_KIDS(DBIc_PARENT_COM(imp_dbh));
+ return 1;
+ }
+ /* not ACTIVE so connect not skipped */
+ if (DBIS->debug >= 2)
+ PerlIO_printf(DBILOGFP,
+ "dbd_db_login6 IMPSET but not ACTIVE so connect not skipped\n");
+ }
imp_dbh->envhp = imp_drh->envhp; /* will be NULL on first connect */
#if defined(USE_ITHREADS) && defined(PERL_MAGIC_shared_scalar)
@@ -2559,14 +2574,14 @@
(phs->ftype == ORA_NUMBER_TABLE)) {
/* Supported *
}else{*/
- /* All the other types are not supported
+ /* All the other types are not supported
croak("Array bind is supported only for
ORA_%_TABLE types. Unable to bind '%s'.",phs->name);
/*}
}*./
-
-
+
+
/* Add checks for other reference types here ? */
-
+
phs->maxlen = maxlen; /* 0 if not inout */
if (!is_inout) { /* normal bind so take a (new) copy of current value
*/
@@ -2595,7 +2610,7 @@
dTHX;
char *note = "";
/* XXX doesn't check arcode for error, caller is expected to */
-
+
if (phs->indp == 0) { /* is okay */
if (phs->is_inout && phs->alen == SvLEN(sv)) {
Added: dbd-oracle/trunk/t/12impdata.t
==============================================================================
--- (empty file)
+++ dbd-oracle/trunk/t/12impdata.t Wed Feb 6 10:37:45 2008
@@ -0,0 +1,49 @@
+#!/usr/bin/perl
+$| = 1;
+
+## ----------------------------------------------------------------------------
+## 12imptdata.t
+## By Jeffrey Klein,
+## ----------------------------------------------------------------------------
+
+use strict;
+use DBI;
+use Config qw(%Config);
+BEGIN { eval "use threads; use threads::shared;" }
+my $use_threads_err = $@;
+use Test::More;
+
+BEGIN {
+ if ($DBI::VERSION <= 1.601){
+ plan skip_all => "DBI version ".$DBI::VERSION." does not supprt iThreads
use version 1.602 or later";
+ }
+ die $use_threads_err if $use_threads_err; # need threads
+}
+
+use Test::More tests => 7;
+
+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, '', );
+
+my $drh = $dbh->{Driver};
+my ($sess_1) = $dbh->selectrow_array("select userenv('sessionid') from dual");
+
+is $drh->{Kids}, 1, "1 kid";
+is $drh->{ActiveKids}, 1, "1 active kid";
+
+my $imp_data = $dbh->take_imp_data;
+is $drh->{Kids}, 0, "no kids";
+is $drh->{ActiveKids}, 0, "no active kids";
+
+$dbh = DBI->connect( $dsn, $dbuser, '', { dbi_imp_data => $imp_data } );
+my ($sess_2) = $dbh->selectrow_array("select userenv('sessionid') from dual");
+is $sess_1, $sess_2, "got same session";
+
+is $drh->{Kids}, 1, "1 kid";
+is $drh->{ActiveKids}, 1, "1 active kid";
+
+__END__
Added: dbd-oracle/trunk/t/14threads.t
==============================================================================
--- (empty file)
+++ dbd-oracle/trunk/t/14threads.t Wed Feb 6 10:37:45 2008
@@ -0,0 +1,172 @@
+#!/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 supprt iThreads
use version 1.602 or later";
+ }
+ die $use_threads_err if $use_threads_err; # need threads
+}
+
+use strict;
+use DBI;
+
+use Test::More tests => 19;
+
+unshift @INC, 't';
+require 'nchar_test_lib.pl';
+
+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__
