File Coverage

blib/lib/DBIx/Log4perl.pm

Criterion	Covered	Total	%
statement	24	105	22.8
branch	0	50	0.0
condition	0	12	0.0
subroutine	8	23	34.7
pod	4	4	100.0
total	36	194	18.5

# $Id: Log4perl.pm 279 2006-09-01 18:36:01Z martin $
require 5.008;

use strict;
use warnings;
use Carp qw(croak cluck);
use Log::Log4perl;
use Data::Dumper;

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

our $VERSION = '0.26';
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_L4P_LOG_DEFAULT
		       DBIX_L4P_LOG_ALL
		       DBIX_L4P_LOG_INPUT
		       DBIX_L4P_LOG_OUTPUT
		       DBIX_L4P_LOG_CONNECT
		       DBIX_L4P_LOG_TXN
		       DBIX_L4P_LOG_ERRCAPTURE
		       DBIX_L4P_LOG_WARNINGS
		       DBIX_L4P_LOG_ERRORS
		       DBIX_L4P_LOG_DBDSPECIFIC
		       DBIX_L4P_LOG_DELAYBINDPARAM
		       DBIX_L4P_LOG_SQL
		     );
our %EXPORT_TAGS= (masks => \@EXPORT_MASKS);
Exporter::export_ok_tags('masks'); # all tags must be in EXPORT_OK

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

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

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

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

    local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + $level
        if $level;

    if (scalar(@args) > 1) {
	$h->{logger}->debug(
	    sub {Data::Dumper->Dump([\@args], [$thing])})
    } elsif (ref($thing) eq 'CODE') {
	$h->{logger}->debug($thing);
    } elsif (ref($args[0])) {
	$h->{logger}->debug(
	    sub {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_l4p_info {
    my ($self, $level, $thing) = @_;

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

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

    local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + $level
        if $level;

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

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

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

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

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

    local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + $level
        if $level;

    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_l4p_error {
    my ($self, $level, $thing, @args) = @_;

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

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

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

    local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + $level
        if $level;

    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_l4p_attr_map {
    return {dbix_l4p_logger => 'logger',
	    dbix_l4p_init => 'init',
	    dbix_l4p_class => 'class',
	    dbix_l4p_logmask => 'logmask',
            dbix_l4p_ignore_err_regexp => 'err_regexp'
	   };
}

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

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

    my $m = _dbix_l4p_attr_map();

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

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

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

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

    my $m = _dbix_l4p_attr_map();

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

    if (!exists($m->{$item})) {
	warn "$item does not exist";
	return undef;
    }
    $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);

    #
    # 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.
    #
    my $h = $dbh->{private_DBIx_Log4perl};
    $h->{dbd_specific} = 1;
    if (($h->{logger}->is_debug()) &&
            ($h->{logmask} & DBIX_L4P_LOG_DBDSPECIFIC) &&
                ($h->{driver} eq 'Oracle')) {
	$dbh->func('dbms_output_enable');
    } else {
	$h->{logmask} &= ~DBIX_L4P_LOG_DBDSPECIFIC;
    }
    $h->{dbd_specific} = 0;
    return $dbh;
}

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

1;

__END__