.gitignore

*~
p5-dbd-oracle-*/

006-dbh2.t

#!/usr/bin/perl
use strict;
use warnings FATAL=>'all';

=head1 MINIMUM TEST CASE

Shows a successful run but segfaults during Perl's global destruction.

=head2 Fails with

Bionic/internal, F</software/perl-5.30-0/bin/perl>, L<DBI> 1.642,
L<DBD::Oracle> 1.80

=head2 Passes with

Bionic/internal, F</software/perl-5.30-0/bin/perl>, L<DBI> 1.642,
L<DBD::Oracle> 1.76

=cut

use Test::More;
use DBD::Oracle;

our $th;

sub main {
  plan tests => 3;
  $th = Thing->new;

  my $dbh = $th->getDbh;
  note "DBI version is ".$DBI::VERSION;
  note "DBD::Oracle version is ".$DBD::Oracle::VERSION;

  my $method = shift @ARGV;
  my $dbh2 = $th->$method; # provokes segfault during Perl shutdown, only on bionic/sandboxed (openstack)
  isnt($dbh, $dbh2, 'dbh2');
  foreach my $h ($dbh, $dbh2) {
    is_deeply($h->selectall_arrayref("select 2+2 from dual"), [ [ 4 ] ], "2+2");
  }

  if (0) {
    undef $th->{"_dbh2_conn.$$"};
    diag "rescued";
  }
  return 0;
}


exit main();


package Thing;
use strict;
use warnings FATAL=>'all';

# In our internal code, this is a class named "dbconn" for short.
#
# It has responsibility for obtaining the tnsname, username and
# password, then for managing statement handles.

sub new {
  my ($called) = @_;
  my $self = { };
  bless $self, ref($called) || $called;
  return $self;
}

sub getDbh {
  my ($self) = @_;
  return $self->{dbh} ||= do {
    my ($dbi, $user, $pass) = split "///", $ENV{ISSUE_DBI};
    die "Please\n  export ISSUE_DBI=\$dbi///\$user///\$pass\nand try again" unless defined $pass;
    DBI->connect($dbi, $user, $pass);
  };
}

# In our internal code, this method is not in dbconn but in a test
# suite.
#
# It needs to trick dbconn into issuing a second dbh so I can run
# concurrency / database locking experiments.  This is marked as
# "naughty" code, and we don't do this in production!
sub dbh2_original {
  my ($self) = @_;
  my ($extra);
  {
    local $self->{dbh};
    $extra = $self->getDbh;
    # hold on to it, else it evaporates and disconnects the dbh on
    # DESTROY
    $self->{"_dbh2_conn.$$"} = $extra;  # try commenting this line
  }
  return $extra;
}

sub dbh2_var1 {
  my ($self) = @_;
  my ($extra);
  my $orig = $self->{dbh};   # try commenting this line
  {
    local $self->{dbh};      # try commenting this line
    $extra = $self->getDbh;
    $self->{"_dbh2_conn.$$"} = $extra;  # try commenting this line
  }
  return $extra;
}

sub dbh2_var2 {
  my ($self) = @_;
  my ($extra);
  my $orig = delete $self->{dbh};
  {
    $extra = $self->getDbh;
    $self->{"_dbh2_conn.$$"} = $extra;  # try commenting this line
  }
  return $extra;
}

sub dbh2_var3 {
  my ($self) = @_;
  my ($extra);
  {
    local $self->{dbh};      # try commenting this line
    $extra = $self->getDbh;
  }
  return $extra;
}

sub dbh2_var4 {
  my ($self) = @_;
  my ($extra);
  my $orig = $self->{dbh};   # try commenting this line
  {
    local $self->{dbh};      # try commenting this line
    $extra = $self->getDbh;
    $self->{"_dbh2_conn.$$"} = $extra;  # try commenting this line
  }
  return $extra;
}


sub dbh2_simple {
  my ($self) = @_;
  my $old = $self->{old} = delete $self->{dbh};
  return $self->getDbh;
}


1;

006-dbh2.t.sh

#! /bin/sh

# Small script used in isolation to run 006-dbh2.t with minimum
# dependencies.

set -e

### DBD::Oracle from these two places
#
# Assume we have a working Oraclie client library

if ! [ -d p5-dbd-oracle-176 ]; then
    mkdir p5-dbd-oracle-176
    (
	cd p5-dbd-oracle-176
	cpanm -l $PWD ZARQUON/DBD-Oracle-1.76.tar.gz
    )
fi
if ! [ -d p5-dbd-oracle-180 ]; then
    mkdir p5-dbd-oracle-180
    (
	cd p5-dbd-oracle-180
	cpanm -l $PWD MJEVANS/DBD-Oracle-1.80.tar.gz
    )
fi
if ! [ -d p5-dbd-oracle-5d98d93b ]; then
    # https://github.com/perl5-dbi/DBD-Oracle/issues/111#issuecomment-688927636
    mkdir p5-dbd-oracle-5d98d93b
    (
	cd p5-dbd-oracle-5d98d93b
	cpanm -l $PWD https://github.com/perl5-dbi/DBD-Oracle/archive/5d98d93bcedf3317f4ff739841162b521403662a.zip
    )
fi


boom # export ISSUE_DBI=dbi:Oracle:CANT///username///password

_test_with() {
    (
	export PERL5LIB="$PWD/$1/lib/perl5:$PERL5LIB"
	shift
	logfn=$( mktemp /tmp/006-dbh2.t.log.XXXXXX )
	set +e
	perl t/006*t "$@" > $logfn 2>&1
	case "$?" in
	    0)   return 0 ;;
	    139) return 1 ;;
	    *)
		printf "\n\nUnexpected flavour of test failure (exit code %s) -\n" $? >&2
		cat $logfn >&2
		kill -9 $$
		;;
	esac
	rm $logfn
    )
}


N_run=20  # repeats to see Heisenbug
for ora in p5-dbd-oracle-*; do
    for method in dbh2_simple dbh2_original dbh2_var1 dbh2_var2 dbh2_var3 dbh2_var4; do
	printf "** Running with %s %s\t\t" "$ora" $method
	ok=0
	bad=0
	for n in $( seq $N_run ); do
	    if _test_with $ora $method; then
		ok=$(( $ok + 1 ))
	    else
		bad=$(( $bad + 1 ))
	    fi
	done
	echo ok=$ok bad=$bad
    done
done

README.md

See perl5-dbi/DBD-Oracle #111