File Coverage

blib/lib/Apache/BabyConnect.pm

Criterion	Covered	Total	%
statement	8	12	66.6
branch	3	6	50.0
condition	2	6	33.3
subroutine	4	4	100.0
pod			n/a
total	17	28	60.7

package Apache::BabyConnect;

our @ISA = qw();
our $VERSION = '0.93';

use strict;

die "
Apache::BabyConnect cannot start without setting the environment
variable BABYCONNECT. You may have forgotten to set BABYCONNECT
environment variable prior to loading the Apache::BabyConnect
module.
In the /etc/httpd/conf.d/perl.conf you need to setup the environment
variable before loading the Apache::BabyConnect module. For instance,
if you have loaded the Apache::BabyConnect from a startup script
using the PerlRequire directive, you can setup the BABYCONNECT
environment variable simply by using the directive PerlSetEnv prior
to loading the startup script:

PerlSetEnv BABYCONNECT /opt/DBI-BabyConnect-$VERSION/configuration
PerlRequire /opt/DBI-BabyConnect-$VERSION/startupscripts/babystartup.pl
Alias /perl /var/www/perl

    SetHandler perl-script
    PerlResponseHandler ModPerl::Registry
    PerlOptions +ParseHeaders
    Options +ExecCGI


" unless $ENV{BABYCONNECT};
use constant MP2 => (exists $ENV{MOD_PERL_API_VERSION} &&
					 $ENV{MOD_PERL_API_VERSION} == 2) ? 1 : 0;

BEGIN {
	if (MP2) {
		require mod_perl2;
		require Apache2::Module;
		require Apache2::ServerUtil;
	}
	elsif (defined $modperl::VERSION && $modperl::VERSION > 1 &&
			 $modperl::VERSION < 1.99) {
		require Apache;
	}
}

########################################################################################
# DBI::BabyConnect needs to be called with caching and persistence enabled
use DBI::BabyConnect(1,1);

use Carp ();

$Apache::BabyConnect::VERSION = '1.00';

$Apache::BabyConnect::DEBUG = 3;

my @ChildConnect; # connections to be established with each httpd child
my $parent_pid;

########################################################################################
########################################################################################
sub debug {
  print STDERR "$_[1]\n" if $Apache::BabyConnect::DEBUG >= $_[0];
}

########################################################################################
########################################################################################
# connect_on_init is called in the script babystartup.pl to provide a PerlChildInitHandler
# that will be hooked to a DBI::BabyConnect instance.
#
# The connect_on_init will request a DBI::BabyConnect instance to manage a DBI connection whose
# parameters are being described with the database descriptor. Each child
# is hooked to such an instance, and the instance is being persisted during the
# life time of the child.
# Because all childs are being started with the same database descriptor, therefore
# they can access the database concurrently. You should be careful on how to use
# the connection. Refer to Apache::BabyConnect documentation, and the script testbaby.pl
# to understand how the pool of connections work.
# You can request new connection from any Perl script, and the connection will be cached
# only if the database descriptor cannot be found within the child (httpd child) own
# DBI::BabyConnect instance cache.
# The caching of connection per each httpd child (or its hooked instance DBI::BabyConnect instance)
# is maintained within the DBI::BabyConnect itself, and each entry in the cache is
# identified with the concatenation of the child kernel process ID and the database descriptor.
#
sub connect_on_init {
	if (MP2) {
		if (!@ChildConnect) {
			my $s = Apache2::ServerUtil->server;
			debug(1, "\n***!!!!!!!!! $$ connect_on_init / MP2 Apache2::ServerUtil->server NOT ChildConnect === @ChildConnect\n\n");
			$s-> push_handlers(PerlChildInitHandler => \&childinit);
		}
	}
	else {
		Carp::carp("Apache.pm was not loaded\n")
			  and return unless $INC{'Apache.pm'};

		if (!@ChildConnect and Apache->can('push_handlers')) {
			Apache->push_handlers(PerlChildInitHandler => \&childinit);
		}
	}

	debug(1, "\n*** connect_on_init / store connections ===  $$   @_\n\n");

	# store connections
	$parent_pid = $$;
	push @ChildConnect, [@_];
	#foreach (@ChildConnect) { print STDERR "************** Childconnect: @$_\n"; #}
}

########################################################################################
########################################################################################
# The PerlChildInitHandler creates all connections during server startup.
# Note: this handler runs in every child server, but not in the main server.
sub childinit {
	my $prefix = "	   $$ Apache::BabyConnect			";
	debug(2, "$prefix PerlChildInitHandler");

	while (@ChildConnect) {
		for my $aref (@ChildConnect) {
			debug(2, "\n\n************** Childconnect: @$aref");
			my @da = @$aref;
			shift @da;
			my %da;
			while (my($l,$r)=splice @da, 0, 2) {
				$da{$l} = $r;
			}
			my ($arg_iconf,$arg_errlog,$arg_tralog,$arg_tralev) =
				@{ %da } { qw(DESCRIPTOR ERROR_FILE TRACE_FILE TRACE_LEVEL) };
			$arg_errlog ||= "";
			$arg_tralog ||= "";
			$arg_tralev ||= "";
			#my $arg_iconf = ${@$aref}[1];
			#my $arg_errlog = ${@$aref}[2] || "";
			#my $arg_tralog = ${@$aref}[3] || "";
			#my $arg_tralev = ${@$aref}[4] || "";
			debug(2, "        Child / ${@$aref}[0] requesting an instance of Apache::BabyConnect($arg_iconf) ");
			debug(2, "              HookError($arg_errlog)");
			debug(2, "              HookTracing($arg_tralog)  with TraceLevel=$arg_tralev) ");
			my $cnn = DBI::BabyConnect->new($arg_iconf);
			# this redirection seems to work, but the need need debugging because it is altering the args!!!!!!!!
			length($arg_errlog) > 2 && $cnn ->HookError(">>$arg_errlog");
			#${@$aref}[2] && $cnn ->HookError(">>$arg_errlog");
			$arg_tralev ||= 1; # if trace level not specified then assume 1
			length($arg_tralog) > 2 && $cnn ->HookTracing(">>$arg_tralog",$arg_tralev);
			#${@$aref}[3] && $cnn ->HookTracing(">>$arg_tralog",$arg_tralev);
		}
		shift @ChildConnect;
		# fudge this for now, need debugging!!!!!!!!
		last if @ChildConnect == 1;
	}

	1;
}

########################################################################################
########################################################################################
# The cleanup phase from within mod_perl will execute some code immediately after the
# request has been served (the client went away) and before the request object is destroyed.
#
# The PerlCleanupHandler does nothing since Apache::BabyConnect relies on DBI::BabyConnect
# to handle all DBI functions such as rollback when AutoCommit is off
sub cleanup {

	1;
}

########################################################################################
########################################################################################
# ref: http://perl.apache.org/docs/2.0/api/Apache2/ServerUtil.html

sub get_child_init_handlers {
	my $s = Apache2::ServerUtil->server;
	my $handlers_list = $s-> get_handlers('PerlChildInitHandler');
	#a list of references to the handler subroutines
	return $handlers_list;
}

sub get_child_exit_handlers {
	my $s = Apache2::ServerUtil->server;
	my $handlers_list = $s-> get_handlers('PerlChildExitHandler') || [];
	return $handlers_list;
}

sub parent_pid {
	return $parent_pid;
}

sub cpids {
	my @a = split(/\n/,`ps  --ppid $parent_pid`);
	my @cpid;
	foreach (@a) {
		if ($_ =~ m/^(\d+)/) {
			push(@cpid,$1);
		}
	}
	return @cpid;
}
########################################################################################
########################################################################################

if (MP2) {
	if (Apache2::Module::loaded('Apache2::Status')) {
		Apache2::Status->menu_item(
								   'BabyConnect' => 'BabyConnet for DBI connections',
								  );
	}
}
else {
	if ($INC{'Apache.pm'}		# is Apache loaded?
			and Apache->can('module')   # really loaded?
			and Apache->module('Apache::Status')) { # and has an Apache::Status?
		Apache::Status->menu_item(
								'BabyConnect' => 'BabyConnect for DBI connections',
								);
	}
}

1;

__END__