view release on metacpan or  search on metacpan

lib/Apache/DBI/Cache.pm  view on Meta::CPAN

    unless( @undef_at_cleanup ) {
      if( exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION}==2 ) {
	require Apache2::RequestUtil;
	Apache2::RequestUtil->request
	    ->push_handlers(PerlCleanupHandler=>\&request_cleanup);
      } elsif( exists $INC{'Apache.pm'} and Apache->can( 'push_handlers' ) ) {
	Apache->push_handlers(PerlCleanupHandler=>\&request_cleanup);
      }
    }
    push @undef_at_cleanup, @l;
  }
  sub request_cleanup {
    $LOG->(2, "request_cleanup:");
    foreach my $v (@undef_at_cleanup) {
      $LOG->(2, "    undefining ${$v}");
      undef ${$v};
    }
    @undef_at_cleanup=();
  }
}

sub connect_on_init {
  # provide a handler which creates all connections during server startup

  # store connections
  push @ChildConnect, [@_];
}


# the connect method called from DBI::connect
our %patched_classes=('Apache::DBI::Cache'=>1);
sub connect {
  my $class = shift;
  unshift @_, $class if ref $class;
  my $drh    = shift;
  my @args   = map { defined $_ ? $_ : "" } @_;

  unless( 3 == $#args and ref $args[3] eq "HASH" ) {
    @args=(@args[0..2], {});
  }

  my ($Idx, $statIdx, $ctx);
  if( exists $plugin{$drh->{Name}} ) {
    my @l=$plugin{$drh->{Name}}->[0]->(@args);
    if( @l ) {
      my $nocache;
      ($ctx, $nocache)=splice @l, 4, 2;
      @args[0..2]=@l[0..2];
      %{$args[3]}=%{$l[3]};
      return $drh->connect(@args) if( $nocache );
    } else {
      return $drh->connect(@args);
    }
  }
  my $dsn="dbi:$drh->{Name}:$args[0]";

  my $RootClass=delete $args[3]->{RootClass};
  unless( defined $RootClass ) {
    # this is a very ugly hack
    package		# this line break should make the CPAN indexer happy
      DB;		# to get @DB::args set by caller()
    for( my $i=1; my @l=caller($i++); ) {
      if( $l[3] eq 'DBI::connect' ) {
	$RootClass=$DB::args[0] unless( $DB::args[0] eq 'DBI' );
	last;
      }
    }
  }

  $Idx    =join $DELIMITER, $drh->{Name}, $args[0], $args[1], $args[2];
  $statIdx=join $DELIMITER, $drh->{Name}, $args[0], $args[1];

  # should we default to '__undef__' or something for undef values?
  map { $Idx .= "$DELIMITER$_=" .
	  (defined $args[3]->{$_}
	   ? $args[3]->{$_}
	   : '');
      } sort keys %{$args[3]};

  if( defined $RootClass ) {
    unless( $patched_classes{$RootClass} ) {
      # this is a very ugly hack
      $patched_classes{$RootClass}=1;
      no strict 'refs';
      no warnings 'redefine';
      *{$RootClass.'::db::disconnect'}=\&Apache::DBI::Cache::db::disconnect;
      *{$RootClass.'::db::DESTROY'}=\&Apache::DBI::Cache::db::DESTROY;
    }
    $args[3]->{RootClass}=$RootClass;
  } else {
    $args[3]->{RootClass}=__PACKAGE__;
  }

  if( exists $Connected{$Idx} ) {
    while( my $dbh=shift @{$Connected{$Idx}} ) {
      local $GLOBAL_DESTROY=2;
      if( eval{$dbh->ping} ) {
	if( exists $plugin{$drh->{Name}} ) {
	  unless( $plugin{$drh->{Name}}->[1]->($dbh, @args, $ctx) ) {
	    _statop( $statIdx,
		     4, 1,	# plugin failure
		     1, -1,	# decr. free count
		     0, -1 );	# decr. handle count
	    $LOG->(2, "reusing connection to '$Idx' failed due to plugin error");
	    undef $dbh;
	    next;
	  }
	}
	_statop( $statIdx,
		 2, 1,		# incr. usage count
		 1, -1 );	# decr. free count
	$LOG->(2, "reusing connection to '$Idx'");
	$dbh->{$PRIVATE}->{disconnected}=0;
	return $dbh;
      } else {
	_statop( $statIdx,
		 3, 1,		# ping failure
		 1, -1,		# decr. free count
		 0, -1 );	# decr. handle count
	$LOG->(2, "reusing connection to '$Idx' failed due to PING failure");
	undef $dbh;
      }