File Coverage

blib/lib/DBIx/LogAny.pm

Criterion	Covered	Total	%
statement	56	111	50.4
branch	17	54	31.4
condition	6	18	33.3
subroutine	12	23	52.1
pod	4	4	100.0
total	95	210	45.2

# $Id$
package DBIx::LogAny;
require 5.008;

use strict;
use warnings;
use Carp qw(croak cluck);
use Log::Any;
use Data::Dumper;
use Scalar::Util qw(blessed);

use DBIx::LogAny::Constants qw (:masks $LogMask);
use DBIx::LogAny::db;
use DBIx::LogAny::st;

our $VERSION = '0.06';
require Exporter;
our @ISA = qw(Exporter DBI);		# look in DBI for anything we don't do

our @EXPORT = ();		# export nothing by default
our @EXPORT_MASKS = qw(DBIX_LA_LOG_DEFAULT
		       DBIX_LA_LOG_ALL
		       DBIX_LA_LOG_INPUT
		       DBIX_LA_LOG_OUTPUT
		       DBIX_LA_LOG_CONNECT
		       DBIX_LA_LOG_TXN
		       DBIX_LA_LOG_ERRCAPTURE
		       DBIX_LA_LOG_WARNINGS
		       DBIX_LA_LOG_ERRORS
		       DBIX_LA_LOG_DBDSPECIFIC
		       DBIX_LA_LOG_DELAYBINDPARAM
		       DBIX_LA_LOG_SQL
               DBIX_LA_LOG_STORE
		     );
our %EXPORT_TAGS= (masks => \@EXPORT_MASKS);
Exporter::export_ok_tags('masks'); # all tags must be in EXPORT_OK

sub _dbix_la_debug {
    my ($self, $h, $level, $thing, @args) = @_;

    $h = $self->{private_DBIx_LogAny} if !defined($h);

    return unless $h->{logger}->is_debug();

    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Quotekeys = 0;

    $args[0] = $args[0]->{Statement} if blessed($args[0]) and
        blessed($args[0])->isa('DBI::st') and
            defined ($args[0]->{Statement});

    if (scalar(@args) > 1) {
        $h->{logger}->debug(
            Data::Dumper->Dump([\@args], [$thing]))
    } elsif (ref($thing) eq 'CODE') {
        $h->{logger}->debug($thing);
    } elsif (ref($args[0])) {
        $h->{logger}->debug(
            Data::Dumper->Dump([$args[0]], [$thing]))
    } elsif (scalar(@args) == 1) {
        if (!defined($args[0])) {
            $h->{logger}->debug("$thing:");
        } else {
            $h->{logger}->debug("$thing: " . DBI::neat($args[0]));
        }
    } else {
        $h->{logger}->debug($thing);
    }
    return;
}

sub _dbix_la_info {
    my ($self, $level, $thing) = @_;

    my $h = $self->{private_DBIx_LogAny};

    return unless $h->{logger}->is_info();

    $h->{logger}->info($thing);

    return;
}
sub _dbix_la_warning {
    my ($self, $level, $thing, @args) = @_;

    my $h = $self->{private_DBIx_LogAny};

    return unless $h->{logger}->is_warn();

    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Quotekeys = 0;

    if (scalar(@args) > 1) {
	$h->{logger}->warn(
	    sub {Data::Dumper->Dump([\@args], [$thing])})
    } elsif (ref($args[0])) {
	$h->{logger}->warn(
	    sub {Data::Dumper->Dump([$args[0]], [$thing])})
    } else {
	$h->{logger}->warn("$thing: " . DBI::neat($args[0]));
    }
    return;
}

sub _dbix_la_error {
    my ($self, $level, $thing, @args) = @_;

    my $h = $self->{private_DBIx_LogAny};

    return unless $h->{logger}->is_error();

    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Quotekeys = 0;

    if (scalar(@args) > 1) {
	$h->{logger}->error(
	    sub {Data::Dumper->Dump([\@args], [$thing])})
    } elsif (ref($thing) eq 'CODE') {
        $h->{logger}->error($thing);
    } elsif (ref($args[0])) {
	$h->{logger}->error(
	    sub {Data::Dumper->Dump([$args[0]], [$thing])})
    } else {
	$h->{logger}->error("$thing: " . DBI::neat($args[0]));
    }
    return;
}

sub _dbix_la_attr_map {
    return {
	    dbix_la_logmask => 'logmask',
        dbix_la_ignore_err_regexp => 'err_regexp',
        dbix_la_category => 'category',
        dbix_la_logger => 'logger'
	   };
}

sub dbix_la_getattr {
    my ($self, $item) = @_;

    croak ('wrong arguments - dbix_la_getattr(attribute_name)')
      if (scalar(@_) != 2 || !defined($_[1]));

    my $m = _dbix_la_attr_map();

    my $h = $self->{private_DBIx_LogAny};

    if (!exists($m->{$item})) {
        warn "$item does not exist";
        return;
    }
    return $h->{$m->{$item}};
}

sub dbix_la_setattr {
    my ($self, $item, $value) = @_;

    croak ('wrong arguments - dbix_la_setattr(attribute_name, value)')
      if (scalar(@_) != 3 || !defined($_[1]));

    my $m = _dbix_la_attr_map();

    my $h = $self->{private_DBIx_LogAny};

    if (!exists($m->{$item})) {
        warn "$item does not exist";
        return;
    }
    $h->{$m->{$item}} = $value;
    1;
}

sub connect {

    my ($drh, $dsn, $user, $pass, $attr) = @_;

    my $dbh = $drh->SUPER::connect($dsn, $user, $pass, $attr);
    return $dbh if (!$dbh);

    my $h = $dbh->{private_DBIx_LogAny};

    if ($h->{logmask} & DBIX_LA_LOG_CONNECT) {
        local $Data::Dumper::Indent = 0;
        $h->{logger}->debug(
            "connect($h->{dbh_no}): " .
                (defined($dsn) ? $dsn : '') . ', ' .
                    (defined($user) ? $user : '') . ', ' .
                        Data::Dumper->Dump([$attr], [qw(attr)]))
            if $h->{logger}->is_debug;
        no strict 'refs';
        my $v = "DBD::" . $dbh->{Driver}->{Name} . "::VERSION";
        $h->{logger}->info("DBI: " . $DBI::VERSION,
                         ", DBIx::LogAny: " . $DBIx::LogAny::VERSION .
                             ", Driver: " . $h->{driver} . "(" .
                                 $$v . ")")
            if $h->{logger}->is_info;
    }

    #
    # Enable dbms_output for DBD::Oracle else turn off DBDSPECIFIC as we have
    # no support for DBDSPECIFIC in any other drivers.
    # BUT only enable it if the log handle is doing debug as we only call
    # dbms_output_get in that case.
    #
    $h->{dbd_specific} = 1;
    if (($h->{logger}->is_debug()) &&
            ($h->{logmask} & DBIX_LA_LOG_DBDSPECIFIC) &&
                ($h->{driver} eq 'Oracle')) {
        $dbh->func('dbms_output_enable');
    } else {
        $h->{logmask} &= ~DBIX_LA_LOG_DBDSPECIFIC;
    }
    $h->{dbd_specific} = 0;
    return $dbh;
}

sub dbix_la_logdie
{
    my ($drh, $msg) = @_;
    _error_handler($msg, $drh);
    die "$msg";
}

1;

__END__