view release on metacpan or  search on metacpan

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

    else {
        if ($Apache::ServerStarting and $Apache::ServerStarting == 1) {
            debug(2, "$prefix skipping connection during server startup, read the docu !!");
            return $drh->connect(@args);
        }
    }

    # this PerlChildExitHandler is supposed to disconnect all open
    # connections to the database
    if (!$ChildExitHandlerInstalled) {
        $ChildExitHandlerInstalled = 1;
        my $s;
        if (MP2) {
            $s = Apache2::ServerUtil->server;
        }
        elsif (Apache->can('push_handlers')) {
            $s = 'Apache';
        }
        if ($s) {
            debug(2, "$prefix push PerlChildExitHandler");
            $s->push_handlers(PerlChildExitHandler => \&childexit);
        }
    }

    # this PerlCleanupHandler is supposed to initiate a rollback after the
    # script has finished if AutoCommit is off.  however, cleanup can only
    # be determined at end of handle life as begin_work may have been called
    # to temporarily turn off AutoCommit.
    if (!$Rollback{$Idx}) {
        my $r;
        if (MP2) {
            # We may not actually be in a request, but in <Perl> (or
            # equivalent such as startup.pl), in which case this would die.
            eval { $r = Apache2::RequestUtil->request };
        }
        elsif (Apache->can('push_handlers')) {
            $r = 'Apache';
        }
        if ($r) {
            debug(2, "$prefix push PerlCleanupHandler");
            $r->push_handlers("PerlCleanupHandler", sub { cleanup($Idx) });
            # 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 database ?
    $PingTimeOut{$dsn}  = 0 unless $PingTimeOut{$dsn};
    $LastPingTime{$dsn} = 0 unless $LastPingTime{$dsn};
    my $now = time;
    # Must ping if TimeOut = 0 else base on time
    my $needping = ($PingTimeOut{$dsn} == 0 or
                    ($PingTimeOut{$dsn} > 0 and
                     $now - $LastPingTime{$dsn} > $PingTimeOut{$dsn})
                   ) ? 1 : 0;
    debug(2, "$prefix need ping: " . ($needping == 1 ? "yes" : "no"));
    $LastPingTime{$dsn} = $now;

    # check first if there is already a database-handle cached
    # if this is the case, possibly verify the database-handle
    # using the ping-method. Use eval for checking the connection
    # handle in order to avoid problems (dying inside ping) when
    # RaiseError being on and the handle is invalid.
    if ($Connected{$Idx} and (!$needping or eval{$Connected{$Idx}->ping})) {
        debug(2, "$prefix already connected to '$Idx'");

        # Force clean up of handle in case previous transaction failed to
        # clean up the handle
        &reset_startup_state($Idx);

        return (bless $Connected{$Idx}, 'Apache::DBI::db');
    }

    # either there is no database handle-cached or it is not valid,
    # so get a new database-handle and store it in the cache
    delete $Connected{$Idx};
    $Connected{$Idx} = $drh->connect(@args);
    return undef if !$Connected{$Idx};

    # store the parameters of the initial connection in the handle
    set_startup_state($Idx);

    # return the new database handle
    debug(1, "$prefix new connect to '$Idx'");
    return (bless $Connected{$Idx}, 'Apache::DBI::db');
}

# 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::DBI            ";
    debug(2, "$prefix PerlChildInitHandler");

    %Connected = () if MP2;

    if (@ChildConnect) {
        for my $aref (@ChildConnect) {
            shift @$aref;
            DBI->connect(@$aref);
            $LastPingTime{@$aref[0]} = time;
        }
    }

    1;
}

# The PerlChildExitHandler disconnects all open connections
sub childexit {

    my $prefix = "$$ Apache::DBI            ";
    debug(2, "$prefix PerlChildExitHandler");

    foreach my $dbh (values(%Connected)) {
        eval { DBI::db::disconnect($dbh) };
        if ($@) {
            debug(2, "$prefix DBI::db::disconnect failed - $@");
        }
    }