File Coverage

blib/lib/DBIx/Timeout.pm

Criterion	Covered	Total	%
statement	15	52	28.8
branch	0	12	0.0
condition	0	3	0.0
subroutine	5	9	55.5
pod	1	1	100.0
total	21	77	27.2

package DBIx::Timeout;

require 5.008;    # v5.8.0+ needed for safe signals

use warnings;
use strict;

our $VERSION = '1.01';

use Params::Validate qw(validate CODEREF);
use Carp qw(croak);
use POSIX qw(_exit);

our $TIMEOUT_EXIT_CODE = 29;

sub call_with_timeout {
    my $pkg = shift;

    my %args =
      validate(@_,
               {dbh     => {isa  => 'DBI::db'},
                code    => {type => CODEREF},
                timeout => 1
               });
    my ($dbh, $code, $timeout) = @args{('dbh', 'code', 'timeout')};

    my $child_pid = $pkg->_fork_child($dbh, $timeout);

    # run code, trapping error since it may have come from the timeout
    # connection killing
    eval { $code->() };
    my $err = $@;

    # signal the child that processing is done - will wake up from
    # sleep if timeout didn't already pass.  It's ok if this fails,
    # that means the child is probably already done.
    kill USR1 => $child_pid;

    # reap the child, examining exit code to determine if timeout fired
    if (waitpid $child_pid, 0) {
        my $exit_code = $? >> 8;
        if ($exit_code == $TIMEOUT_EXIT_CODE) {
            return 0;
        }
    } else {
        croak("waitpid() failed: $!");
    }

    # the error wasn't a timeout, rethrow
    die $err if $err;

    # everything is all right
    return 1;
}

# forks off the child process
sub _fork_child {
    my ($pkg, $dbh, $timeout) = @_;

    # pull a list of active handles for use after the fork
    my %drivers    = DBI->installed_drivers();
    my @active_dbh =
      grep { $_ and $_->isa('DBI::db') and $_->{Active} }
      map { @{$_->{ChildHandles}} } values %drivers;

    # do the fork, return in the parent
    my $child_pid = fork();
    croak("Failed to fork(): $!") unless defined $child_pid;
    return $child_pid if $child_pid;

    # do the dance needed to keep open DBI connections from causing
    # errors when this child exits
    foreach my $active_dbh (@active_dbh) {
        $active_dbh->{InactiveDestroy} = 1;
    }

    # setup a (safe) signal handler for USR1 which will exit early
    # from sleep()
    local $SIG{USR1} = sub { _exit(0) };

    # now running in the child, sleep for $timeout seconds
    sleep $timeout;

    # turn off USR1 handler, signalling now won't kill us in the
    # middle of killing the parent's thread
    $SIG{USR1} = 'IGNORE';

    # woke up, time to kill parent's thread
    $pkg->_kill_connection($dbh);

    # tell the parent what happened (use POSIX::_exit() to make sure
    # the parent really gets the message - otherwise END blocks can
    # change the exit code)
    _exit($TIMEOUT_EXIT_CODE);
}


# MySQL specific thread-killer
sub _kill_connection {
    my ($self, $dbh) = @_;

    my $thread_id = $dbh->{thread_id};

    my $new_dbh = $dbh->clone();
    $new_dbh->{InactiveDestroy} = 0;
    $new_dbh->do("KILL $thread_id");
}


1;

__END__