view release on metacpan or  search on metacpan

lib/Apache/Backend/POE.pm  view on Meta::CPAN

    my $alias = shift || 'backend';
    # sanity check
    if ($timeout =~ /\-*\d+/) {
        $PingTimeOut{"poe:$alias"} = $timeout;
    }
}

# the connect method called from POE::connect

sub connect {
	my $poe = shift;
    
	my $prefix = "$$ Apache::Backend::POE            ";
	print STDERR "$prefix ref: ".ref($poe)." in connect\n" if $Apache::Backend::POE::DEBUG > 1;

    my @args = map { defined $_ ? $_ : "" } @_;
	$Idx = join(',',@args);
	my %opts = @args;
	
	# defaults
	$opts{alias} ||= 'backend';
	
    my $dsn = "poe:$opts{alias}";
	
	print STDERR "$prefix dsn: $dsn  args:".join(',',@args)."\n" if $Apache::Backend::POE::DEBUG;


    # don't cache connections created during server initialization; they
    # won't be useful after ChildInit, since multiple processes trying to
    # work over the same connection simultaneously will receive
    # unpredictable results.
    if ($Apache::ServerStarting and $Apache::ServerStarting == 1) {
        print STDERR "$prefix skipping connection during server startup, read the docs !!\n" if $Apache::Backend::POE::DEBUG > 1;
		return Apache::Backend::POE::Connection->new(@args)->connect($poe);
    }

 	# I plan to have transaction support

    # this PerlCleanupHandler is supposed to initiate a rollback after the script has finished if AutoCommit is off.
#    my $needCleanup = ($opts{AutoCommit}) ? 1 : 0;
    # TODO - Fix mod_perl 2.0 here
#    if(!$Rollback{$Idx} and !$needCleanup and Apache->can('push_handlers')) {
#        print STDERR "$prefix push PerlCleanupHandler\n" if $Apache::Backend::POE::DEBUG > 1;
#        Apache->push_handlers("PerlCleanupHandler", \&cleanup);
#        # make sure, that the rollback is called only once for every 
#        # request, even if the script calls connect more than once
#        $Rollback{$Idx} = 1;
#    }

    # do we need to ping the connection ?
    $PingTimeOut{$dsn}  = 0 unless $PingTimeOut{$dsn};
    $LastPingTime{$dsn} = 0 unless $LastPingTime{$dsn};
    my $now = time;
    my $needping = (($PingTimeOut{$dsn} == 0 or $PingTimeOut{$dsn} > 0)
		    and (($now - $LastPingTime{$dsn}) >= $PingTimeOut{$dsn})
		   ) ? 1 : 0;
#    print STDERR "$prefix need ping: ".($needping == 1 ? "yes" : "no")." \n" if $Apache::Backend::POE::DEBUG > 1;
    $LastPingTime{$dsn} = $now;

    # check first if there is already a object cached
    # if this is the case, possibly verify the object 
    # using the ping-method. Use eval for checking the connection 
    # handle in order to avoid problems (dying inside ping) when 
    # handle is invalid.
#	require Data::Dumper;
#	print STDERR Data::Dumper->Dump([\%Connected]);
	
    #if ($Connected{$Idx} and (!$needping or eval{$Connected{$Idx}->ping})) {
	$needping = 1;
	PING: {
		if ($Connected{$Idx}) {
			if ($needping) {
				print STDERR "$prefix going to ping\n" if $Apache::Backend::POE::DEBUG > 1;
				
				my $rt = eval{ $Connected{$Idx}->ping };
				
				print STDERR "$prefix ping rt: ----------- $rt\n" if $Apache::Backend::POE::DEBUG > 1;
				last PING unless ($rt == 1);
				if ($@) {
					print STDERR "$prefix ping error: $@\n" if $Apache::Backend::POE::DEBUG;
					last PING;
				}
			}
			print STDERR "$prefix using cached connection to '$Idx'\n" if $Apache::Backend::POE::DEBUG;
   			return (bless $Connected{$Idx}, 'Apache::Backend::POE::Conn');
	    }
	}

	
    # either there is no object cached or it is not valid,
    # so get a new object and store it in the cache
    delete $Connected{$Idx};
	$Connected{$Idx} = Apache::Backend::POE::Connection->new(@args)->connect($poe);
    return undef if !$Connected{$Idx};

    # return the new object
    print STDERR "$prefix new connect to '$Idx'\n" if $Apache::Backend::POE::DEBUG;
    return (bless $Connected{$Idx}, 'Apache::Backend::POE::Conn');
}


# 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::Backend::POE            ";
    print STDERR "$prefix PerlChildInitHandler\n" if $Apache::Backend::POE::DEBUG > 1;
    if (@ChildConnect) {
        foreach my $aref (@ChildConnect) {
            my $class = shift @$aref;
            my $conn = Apache::Backend::POE::Connection->new(@$aref);
			
			my $idx = join(',',(map { defined $_ ? $_ : "" } @$aref));
			delete $Connected{$idx};
			$Connected{$idx} = $conn->connect($class);
				
			my %opts = @$aref;

			# defaults
			$opts{alias} ||= 'backend';