File Coverage

blib/lib/HealthCheck/Diagnostic/DBHCheck.pm

Criterion	Covered	Total	%
statement	65	68	95.5
branch	27	30	90.0
condition	14	24	58.3
subroutine	11	11	100.0
pod	3	3	100.0
total	120	136	88.2

package HealthCheck::Diagnostic::DBHCheck;

# ABSTRACT: Check a database handle to make sure you have read/write access
use version;
our $VERSION = 'v0.500.3'; # 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(
        tags  => [ 'dbh_check' ],
        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]$/;

    $dbh = $dbh->(%params);

    croak "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;

    croak "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 it's 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";

    RUN_TESTS: {

        # See if we can ping the DB connection
        if ($dbh->can("ping") && !$dbh->ping) {
            $status = "CRITICAL";
            last RUN_TESTS;
        }

        # See if a simple SELECT works
        my $value = eval { $dbh->selectrow_array("SELECT 1"); };
        unless (defined $value && $value == 1) {
            $status = "CRITICAL";
            last RUN_TESTS;
        }

        $status = _read_write_temp_table(%params) if $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__