File Coverage

blib/lib/DBIx/Log4perl/db.pm

Criterion	Covered	Total	%
statement	25	263	9.5
branch	0	150	0.0
condition	0	85	0.0
subroutine	8	31	25.8
pod	15	16	93.7
total	48	545	8.8

# $Id: db.pm 245 2006-07-25 14:20:59Z martin $
use strict;
use warnings;
use DBI;
use Log::Log4perl;
use Data::Dumper;

package DBIx::Log4perl::db;
@DBIx::Log4perl::db::ISA = qw(DBI::db DBIx::Log4perl);
use DBIx::Log4perl::Constants qw (:masks $LogMask);

# $_glogger is not relied upon - it is just a fallback
my $_glogger;

my $_counter;                   # to hold sub to count

BEGIN {
    my $x = sub {
        my $start = shift;
        return sub {$start++}};
    $_counter = &$x(0);         # used to count dbh connections
}


sub STORE{
    my $dbh = shift;
    my @args = @_;

    my $h = $dbh->{private_DBIx_Log4perl};
    # as we don't set private_DBIx_Log4perl until the connect method sometimes
    # $h will not be set
    $dbh->_dbix_l4p_debug($h, 2, "STORE($h->{dbh_no})", @args)
        if ($h && ($h->{logmask} & DBIX_L4P_LOG_INPUT));


    return $dbh->SUPER::STORE(@args);
}

sub get_info
{
    my ($dbh, @args) = @_;

    my $h = $dbh->{private_DBIx_Log4perl};
    my $value = $dbh->SUPER::get_info(@args);

    $dbh->_dbix_l4p_debug($h, 2, "get_info($h->{dbh_no})", @args, $value)
        if ($h->{logmask} & DBIX_L4P_LOG_INPUT);
    return $value;
}
sub prepare {
    my($dbh, @args) = @_;

    my $h = $dbh->{private_DBIx_Log4perl};
    my $ctr = $h->{new_stmt_no}(); # get a new unique stmt counter in this dbh
    if (($h->{logmask} & (DBIX_L4P_LOG_INPUT|DBIX_L4P_LOG_SQL)) &&
            (caller !~ /^DBIx::Log4perl/o) &&
                (caller !~ /^DBD::/o)) { # e.g. from selectall_arrayref
        $dbh->_dbix_l4p_debug($h, 2, "prepare($h->{dbh_no}.$ctr)", $args[0]);
    }

    my $sth = $dbh->SUPER::prepare(@args);
    if ($sth) {
        $sth->{private_DBIx_Log4perl} = $h;
        $sth->{private_DBIx_st_no} = $ctr;
    }

    return $sth;
}

sub prepare_cached {
    my($dbh, @args) = @_;

    my $h = $dbh->{private_DBIx_Log4perl};
    my $ctr = $h->{new_stmt_no}();
    if (($h->{logmask} & (DBIX_L4P_LOG_INPUT|DBIX_L4P_LOG_SQL)) &&
            (caller !~ /^DBIx::Log4perl/o) &&
                (caller !~ /^DBD::/o)) { # e.g. from selectall_arrayref
        $dbh->_dbix_l4p_debug($h, 2,
                              "prepare_cached($h->{dbh_no}.$ctr)", $args[0]);
    }

    my $sth = $dbh->SUPER::prepare_cached(@args);
    if ($sth) {
        $sth->{private_DBIx_Log4perl} = $h;
        $sth->{private_DBIx_st_no} = $ctr;
    }
    return $sth;
}

sub do {
    my ($dbh, @args) = @_;
    my $h = $dbh->{private_DBIx_Log4perl};

    $h->{Statement} = $args[0];
    $dbh->_dbix_l4p_debug($h, 2, "do($h->{dbh_no})", @args)
        if ($h->{logmask} & (DBIX_L4P_LOG_INPUT|DBIX_L4P_LOG_SQL));

    my $affected = $dbh->SUPER::do(@args);

    if (!defined($affected)) {
        $dbh->_dbix_l4p_error(2, 'do error for ', @args)
            if (($h->{logmask} & DBIX_L4P_LOG_ERRCAPTURE) &&
                    !($h->{logmask} & DBIX_L4P_LOG_INPUT)); # not already logged
    } elsif (defined($affected) && $affected eq '0E0' &&
                 ($h->{logmask} & DBIX_L4P_LOG_WARNINGS)) {
        $dbh->_dbix_l4p_warning(2, 'no effect from ', @args);
    } elsif (($affected ne '0E0') && ($h->{logmask} & DBIX_L4P_LOG_INPUT)) {
        $dbh->_dbix_l4p_debug($h, 2, "affected($h->{dbh_no})", $affected);
        $dbh->_dbix_l4p_debug($h, 2, "\t" . $dbh->SUPER::errstr)
            if (!defined($affected));
    }
    return $affected;
}

sub selectrow_array {
    my ($dbh, @args) = @_;

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

    if ($h->{logmask} & (DBIX_L4P_LOG_INPUT|DBIX_L4P_LOG_SQL)) {
        if ((scalar(@args) > 0) && (ref $args[0])) {
            $dbh->_dbix_l4p_debug($h,
                2,
                "selectrow_array($h->{dbh_no}." .
                    $args[0]->{private_DBIx_st_no} . ")", @args);
        } else {
            $dbh->_dbix_l4p_debug($h, 2,
                                  "selectrow_array($h->{dbh_no})", @args);
        }
    }

    if (wantarray) {
	my @ret = $dbh->SUPER::selectrow_array(@args);
	$dbh->_dbix_l4p_debug($h, 2, "result($h->{dbh_no})", @ret)
	  if ($h->{logmask} & DBIX_L4P_LOG_OUTPUT);
	return @ret;

    } else {
	my $ret = $dbh->SUPER::selectrow_array(@args);
	$dbh->_dbix_l4p_debug($h, 2, "result($h->{dbh_no})", $ret)
	  if ($h->{logmask} & DBIX_L4P_LOG_OUTPUT);
	return $ret;
    }
}

sub selectrow_arrayref {
    my ($dbh, @args) = @_;

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

    if ($h->{logmask} & (DBIX_L4P_LOG_INPUT|DBIX_L4P_LOG_SQL)) {
        if ((scalar(@args) > 0) && (ref $args[0])) {
            $dbh->_dbix_l4p_debug(
                $h, 2,
                "selectrow_arrayref($h->{dbh_no}." .
                    $args[0]->{private_DBIx_st_no} . ")", @args);
        } else {
            $dbh->_dbix_l4p_debug(
                $h, 2, "selectrow_arrayref($h->{dbh_no})", @args);
        }
    }

    my $ref = $dbh->SUPER::selectrow_arrayref(@args);
    $dbh->_dbix_l4p_debug($h, 2, "result($h->{dbh_no})", $ref)
      if ($h->{logmask} & DBIX_L4P_LOG_OUTPUT);
    return $ref;
}

sub selectrow_hashref {
    my ($dbh, @args) = @_;

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

    if ($h->{logmask} & (DBIX_L4P_LOG_INPUT|DBIX_L4P_LOG_SQL)) {
        if ((scalar(@args) > 0) && (ref $args[0])){
            $dbh->_dbix_l4p_debug(
                $h, 2,
                "selectrow_hashref($h->{dbh_no}." .
                    $args[0]->{private_DBIx_st_no} . ")", @args)
        } else {
            $dbh->_dbix_l4p_debug($h, 2,
                                  "selectrow_hashref($h->{dbh_no})", @args);
        }
    }

    my $ref = $dbh->SUPER::selectrow_hashref(@args);
    # no need to show result - fetch will do this
    return $ref;

}

sub selectall_arrayref {
    my ($dbh, @args) = @_;

    my $h = $dbh->{private_DBIx_Log4perl};
    if ($h->{logmask} & (DBIX_L4P_LOG_INPUT|DBIX_L4P_LOG_SQL)) {
        if ((scalar(@args) > 0) && (ref $args[0])) {
            $dbh->_dbix_l4p_debug(
                $h, 2,
                "selectall_arrayref($h->{dbh_no}." .
                    $args[0]->{private_DBIx_st_no} . ")", @args);
        } else {
            $dbh->_dbix_l4p_debug(
                $h, 2, "selectall_arrayref($h->{dbh_no})", @args);
        }
    }

    my $ref = $dbh->SUPER::selectall_arrayref(@args);
    $dbh->_dbix_l4p_debug($h, 2, "result($h->{dbh_no})", $ref)
      if ($h->{logmask} & DBIX_L4P_LOG_OUTPUT);
    return $ref;
}

sub selectall_hashref {
    my ($dbh, @args) = @_;

    my $h = $dbh->{private_DBIx_Log4perl};
    if ($h->{logmask} & (DBIX_L4P_LOG_INPUT|DBIX_L4P_LOG_SQL)) {
        if ((scalar(@args) > 0) && (ref $args[0])) {
            $dbh->_dbix_l4p_debug(
                $h, 2,
                "selectall_hashref($h->{dbh_no}." .
                    $args[0]->{private_DBIx_st_no} . ")", @args);
        } else {
            $dbh->_dbix_l4p_debug($h, 2,
                                  "selectall_hashref($h->{dbh_no})", @args);
        }
    }

    my $ref = $dbh->SUPER::selectall_hashref(@args);
    # no need to show result - fetch will do this
    return $ref;

}

sub _make_counter {
    my $start = shift;
    return sub {$start++}
};

sub connected {

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

    my %h = ();
    $h{dbh_no} = &$_counter();
    $h{new_stmt_no} = _make_counter(0); # get a new stmt count for this dbh

    if ($attr) {
      # check we have not got dbix_l4p_init without dbix_l4p_log or vice versa
	my ($a, $b) = (exists($attr->{dbix_l4p_init}),
		       exists($attr->{dbix_l4p_class}));
	croak ('dbix_l4p_init specified without dbix_l4p_class or vice versa')
	  if (($a xor $b));
	# if passed a Log4perl log handle use that
	if (exists($attr->{dbix_l4p_logger})) {
	    $h{logger} = $attr->{dbix_l4p_logger};
	} elsif ($a && $b) {
	    Log::Log4perl->init($attr->{dbix_l4p_init});
	    $h{logger} = Log::Log4perl->get_logger($attr->{dbix_l4p_class});
	    $h{init} = $attr->{dbix_l4p_init};
	    $h{class} = $attr->{dbix_l4p_class};
	} else {
	    $h{logger} = Log::Log4perl->get_logger('DBIx::Log4perl');
	}
	# save log mask
	$h{logmask} = $attr->{dbix_l4p_logmask}
	  if (exists($attr->{dbix_l4p_logmask}));
        # save error regexp
        $h{err_regexp} = $attr->{dbix_l4p_ignore_err_regexp}
            if (exists($attr->{dbix_l4p_ignore_err_regexp}));
	# remove our attrs from connection attrs
	#delete $attr->{dbix_l4p_init};
	#delete $attr->{dbix_l4p_class};
	#delete $attr->{dbix_l4p_logger};
	#delete $attr->{dbix_l4p_logmask};
        #delete $attr->{dbix_l4p_ignore_err_regexp};
    }
    # take global log mask if non defined
    $h{logmask} = $LogMask unless (exists($h{logmask}));

    $h{logger} = Log::Log4perl->get_logger('DBIx::Log4perl')
        unless (exists($h{logger}));
    $_glogger = $h{logger};

    # make sure you don't change the depth before calling get_logger:
    local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 4;

    $h{dbd_specific} = 0;
    $h{driver} = $dbh->{Driver}->{Name};

    $dbh->{private_DBIx_Log4perl} = \%h;

    if ($h{logmask} & DBIX_L4P_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)]));
	no strict 'refs';
	my $v = "DBD::" . $dbh->{Driver}->{Name} . "::VERSION";
	$h{logger}->info("DBI: " . $DBI::VERSION,
			 ", DBIx::Log4perl: " . $DBIx::Log4perl::VERSION .
			   ", Driver: " . $h{driver} . "(" .
			     $$v . ")");
    }

    #
    # If capturing errors then save any error handler and set_err Handler
    # passed to us and replace with our own.
    #
    if ($h{logmask} & DBIX_L4P_LOG_ERRCAPTURE) {
	$h{HandleError} = $attr->{HandleError}
	    if (exists($attr->{HandleError}));
	$h{HandleSetErr} = $attr->{HandleSetErr}
	    if (exists($attr->{HandleSetErr}));
	$dbh->{HandleError} = \&_error_handler;
	$dbh->{HandleSetErr} = \&_set_err_handler;
    }
    return;

}
sub clone {
    my ($dbh, @args) = @_;

    my $h = $dbh->{private_DBIx_Log4perl};
    if ($h->{logmask} & DBIX_L4P_LOG_CONNECT) {
        $dbh->_dbix_l4p_debug($h, 2, "clone($h->{dbh_no})", @args);
    }

    return $dbh->SUPER::clone(@args);
}

sub disconnect {
    my $dbh = shift;

    if ($dbh) {
	my $h;
	eval {
	    # Avoid
	    # (in cleanup) Can't call method "FETCH" on an undefined value
	    $h = $dbh->{private_DBIx_Log4perl};
	};
	if (!$@ && $h && defined($h->{logger})) {
            if ($h->{logmask} & DBIX_L4P_LOG_CONNECT) {
                local $Log::Log4perl::caller_depth =
                    $Log::Log4perl::caller_depth + 2;
                $dbh->_dbix_l4p_debug($h, 2, "disconnect($h->{dbh_no})");
            }
	}
    }
    return $dbh->SUPER::disconnect;

}

sub begin_work {
    my $dbh = shift;
    my $h = $dbh->{private_DBIx_Log4perl};

    $dbh->_dbix_l4p_debug($h, 2, "start transaction($h->{dbh_no})")
        if ($h->{logmask} & DBIX_L4P_LOG_TXN);

    return $dbh->SUPER::begin_work;
}

sub rollback {
    my $dbh = shift;
    my $h = $dbh->{private_DBIx_Log4perl};

    $dbh->_dbix_l4p_debug($h, 2, "roll back($h->{dbh_no})")
        if ($h->{logmask} & DBIX_L4P_LOG_TXN);

    return $dbh->SUPER::rollback;
}

sub commit {
    my $dbh = shift;

    my $h = $dbh->{private_DBIx_Log4perl};
    $dbh->_dbix_l4p_debug($h, 2, "commit($h->{dbh_no})")
        if ($h->{logmask} & DBIX_L4P_LOG_TXN);

    return $dbh->SUPER::commit;
}

sub last_insert_id {
    my ($dbh, @args) = @_;
    my $h = $dbh->{private_DBIx_Log4perl};

    $dbh->_dbix_l4p_debug($h, 2,
	sub {Data::Dumper->Dump([\@args], ["last_insert_id($h->{dbh_no})"])})
      if ($h->{logmask} & DBIX_L4P_LOG_INPUT);

    my $ret = $dbh->SUPER::last_insert_id(@args);
    $dbh->_dbix_l4p_debug($h, 2, sub {"\t" . DBI::neat($ret)})
      if ($h->{logmask} & DBIX_L4P_LOG_INPUT);
    return $ret;
}


#
# Error handler to capture errors and log them
# Whatever, errors are passed on.
# if the user of DBIx::Log4perl passed in an error handler that is called
# before returning.
#
sub _error_handler {
    my ($msg, $handle, $method_ret) = @_;

    local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1;

    my $dbh = $handle;
    my $lh;
    my $h = $handle->{private_DBIx_Log4perl};
    my $out = '';

    $lh = $_glogger;
    $lh = $h->{logger} if ($h && exists($h->{logger}));
    return 0 if (!$lh);

    if ($h && exists($h->{err_regexp})) {
        if ($dbh->err =~ $h->{err_regexp}) {
            goto FINISH;
        }
    }
    # start with error message, state and err
    $out .=  '  ' . '=' x 60 . "\n  $msg\n";
    $out .= "err() = " . $handle->err . "\n";
    $out .= "state() = " . $handle->state . "\n";

    if ($DBI::lasth) {
	$out .= "  lasth type: $DBI::lasth->{Type}\n"
	    if ($DBI::lasth->{Type});
	$out .= "  lasth Statement ($DBI::lasth):\n    " .
	    "$DBI::lasth->{Statement}\n"
		if ($DBI::lasth->{Statement});
    }
    # get db handle if we have an st
    my $type = $handle->{Type};
    my $sql;
    if ($type eq 'st') {	# given statement handle
	$dbh = $handle->{Database};
	$sql = $handle->{Statement};
    } else {
	# given db handle
	# We've got other stmts under this db but we'll deal with those later
	$sql = 'Possible SQL: ';
	$sql .= "/$h->{Statement}/" if (exists($h->{Statement}));
	$sql .= "/$dbh->{Statement}/"
	  if ($dbh->{Statement} &&
		(exists($h->{Statement}) &&
		 ($dbh->{Statement} ne $h->{Statement})));
    }

    my $dbname = exists($dbh->{Name}) ? $dbh->{Name} : "";
    my $username = exists($dbh->{Username}) ? $dbh->{Username} : "";
    $out .= "  DB: $dbname, Username: $username\n";
    $out .= "  handle type: $type\n  SQL: " . DBI::neat($sql) . "\n";
    $out .= '  db Kids=' . $dbh->{Kids} .
	', ActiveKids=' . $dbh->{ActiveKids} . "\n";
    $out .= "  DB errstr: " . $handle->errstr . "\n"
	if ($handle->errstr && ($handle->errstr ne $msg));

    if (exists($h->{ParamValues}) && $h->{ParamValues}) {
	$out .= "  ParamValues captured in HandleSetErr:\n    ";
	foreach (sort keys %{$h->{ParamValues}}) {
	    $out .= "$_=" . DBI::neat($h->{ParamValues}->{$_}) . ",";
	}
	$out .= "\n";
    }
    if ($type eq 'st') {
	my $str = "";
	if ($handle->{ParamValues}) {
	    foreach (sort keys %{$handle->{ParamValues}}) {
		$str .= "$_=" . DBI::neat($handle->{ParamValues}->{$_}) . ",";
	    }
	}
	$out .= "  ParamValues: $str\n";
	$out .= "  " .
	  Data::Dumper->Dump([$handle->{ParamArrays}], ['ParamArrays'])
	      if ($handle->{ParamArrays});
    }
    my @substmts;
    # get list of statements under the db
    push @substmts, $_ for (grep { defined } @{$dbh->{ChildHandles}});
    $out .= "  " . scalar(@substmts) . " sub statements:\n";
    if (scalar(@substmts)) {
	foreach my $stmt (@substmts) {
	    $out .= "  stmt($stmt):\n";
	    $out .= '    SQL(' . $stmt->{Statement} . ")\n  "
		if ($stmt->{Statement} &&
		    (exists($h->{Statement}) &&
		     ($h->{Statement} ne $stmt->{Statement})));
	    if (exists($stmt->{ParamValues}) && $stmt->{ParamValues}) {
		$out .= '   Params(';
		foreach (sort keys %{$stmt->{ParamValues}}) {
		    $out .= "$_=" . DBI::neat($stmt->{ParamValues}->{$_}) . ",";
		}
		$out .= ")\n";
	    }
	}
    }

    if (exists($dbh->{Callbacks})) {
        $out .= "  Callbacks exist for " .
            join(",", keys(%{$dbh->{Callbacks}})) . "\n";
    }
    local $Carp::MaxArgLen = 256;
    $out .= "  " .Carp::longmess("DBI error trap");
    $out .= "  " . "=" x 60 . "\n";
    $lh->fatal($out);

  FINISH:
    if ($h && exists($h->{ErrorHandler})) {
      return $h->{ErrorHandler}($msg, $handle, $method_ret);
    } else {
      return 0;			# pass error on
    }
}

#
# set_err handler so we can capture ParamValues before a statement
# is destroyed.
# If the use of DBIx::Log4perl passed in an error handler that is
# called before returning.
#
sub _set_err_handler {
    my ($handle, $err, $errstr, $state, $method) = @_;

    # Capture ParamValues
    if ($handle) {
	my $h = $handle->{private_DBIx_Log4perl};
	$h->{ParamValues} = $handle->{ParamValues}
	    if (exists($handle->{ParamValues}));
	return $h->{HandleSetErr}(@_) if (exists($h->{HandleSetErr}));
    }
    return 0;
}


1;