File Coverage

blib/lib/HealthCheck/Diagnostic/DBHCheck.pm

Criterion	Covered	Total	%
statement	68	69	98.5
branch	32	36	88.8
condition	15	24	62.5
subroutine	11	11	100.0
pod	3	3	100.0
total	129	143	90.2

package HealthCheck::Diagnostic::DBHCheck;

# ABSTRACT: Check a database handle to make sure you have read/write access
use version;
our $VERSION = 'v0.500.1'; # VERSION

use 5.010;
use strict;
use warnings;
use parent 'HealthCheck::Diagnostic';

use Carp;
use Scalar::Util qw( blessed );

sub new {
    my ($class, @params) = @_;

    # Allow either a hashref or even-sized list of params
    my %params = @params == 1 && ( ref $params[0] || '' ) eq 'HASH'
        ? %{ $params[0] } : @params;

    croak("The 'dbh' parameter should be a coderef!")
      if ($params{dbh} && (ref $params{dbh} ne "CODE"));

    return $class->SUPER::new(
        label => 'dbh_check',
        %params
    );
}

sub check {
    my ( $self, %params ) = @_;

   # 1st, try to get dbh from provided parameters
    my $dbh = $params{dbh};
    # 2nd, if invoked with an object (not the class), then get dbh from object
    $dbh ||= $self->{dbh} if ref $self;

    croak("Valid 'dbh' is required") unless $dbh;

    croak("The 'dbh' parameter should be a coderef!")
        unless (ref $dbh eq "CODE");

    my $db_access = $params{db_access}          # Provided call to check()
        // ((ref $self) && $self->{db_access})  # Value from new()
        || "rw";                                # default value

    croak("The value '$db_access' is not valid for the 'db_access' parameter")
        unless ($db_access =~ /^r[ow]$/);

    eval{ local $SIG{__DIE__}; $dbh = $dbh->(%params); };

    if($@) {
        return { status => 'CRITICAL', info => $@ };
    }

    return {
        status => 'UNKNOWN',
        info => "The 'dbh' coderef should return an object!"
    } unless (blessed $dbh);

    my $db_class = $params{db_class}            # Provided in call to check()
        // ((ref $self) && $self->{db_class})   # Value from new
        || "DBI::db";                           # default value

    my $isa = ref $dbh;

    return {
        status => 'UNKNOWN',
        info => "The 'dbh' coderef should return a '$db_class', not a '$isa'"
    } unless ($dbh->isa($db_class));

    my $res = $self->SUPER::check(
        %params,
        dbh       => $dbh,
        db_access => $db_access,
        db_class  => $db_class
    );
    delete $res->{dbh};    # don't include the object in the result

    return $res;
}


sub _read_write_temp_table {
    my (%params) = @_;
    my $dbh      = $params{dbh};
    my $table    = $params{table_name} // "__DBH_CHECK__";
    my $status   = "CRITICAL";

    my $qtable   = $dbh->quote_identifier($table);

    # Drop it like its hot
    $dbh->do("DROP TEMPORARY TABLE IF EXISTS $qtable");

    $dbh->do(
        join(
            "",
            "CREATE TEMPORARY TABLE IF NOT EXISTS $qtable (",
            "check_id INTEGER PRIMARY KEY,",
            "check_string VARCHAR(64) NOT NULL",
            ")"
        )
    );

    $dbh->do(
        join(
            "",
            "INSERT INTO $qtable ",
            "       (check_id, check_string) ",
            "VALUES (1,        'Hello world')",
        )
    );
    my @row = $dbh->selectrow_array(
        "SELECT check_string FROM $qtable WHERE check_id = 1"
    );

    $status = "OK" if ($row[0] && ($row[0] eq "Hello world"));

    $dbh->do("DROP TEMPORARY TABLE $qtable");

    return $status;
}

sub run {
    my ( $self, %params ) = @_;
    my $dbh = $params{dbh};

    # Get db_access from parameters
    my $read_write = ($params{db_access} =~ /^rw$/i);

    my $status = "OK";

    # See if we can ping the DB connection
    if ($dbh->can("ping")) {
        $status = $dbh->ping ? "OK" : "CRITICAL";
    }

    if ($status eq "OK") {
        # See if a simple SELECT works
        my $value  = eval { $dbh->selectrow_array("SELECT 1"); };
        $status = (defined($value) && ($value == 1)) ? "OK" : "CRITICAL";
    }

    $status = _read_write_temp_table(%params)
        if (($status eq "OK") && $read_write);

    # Generate the human readable info string
    my $info = sprintf(
        "%s %s %s check of %s%s",
        $status eq "OK" ? "Successful" : "Unsuccessful",
        $dbh->{Driver}->{Name},
        $read_write ? "read write" : "read only",
        $dbh->{Name},
        $dbh->{Username} ? " as $dbh->{Username}" : "",
    );

    return { status => $status, info => $info };
}

1;

__END__